(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * Finite sets library : conversion to old [Finite_sets] *)

Require Import Ensembles Finite_sets.
Require Import FSetInterface FSetProperties OrderedTypeEx DecidableTypeEx.

(** * Going from [FSets] with usual Leibniz equality
    to the good old [Ensembles] and [Finite_sets] theory. *)

Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U).
 Module MP:= WProperties_fun U M.
 Import M MP FM Ensembles Finite_sets.

 Definition mkEns : M.t -> Ensemble M.elt :=
   fun s x => M.In x s.

 Notation " !! " := mkEns.

 Lemma In_In : forall s x, M.In x s <-> In _ (!!s) x.
 Proof.
 unfold In; compute; auto with extcore.
 Qed.

 Lemma Subset_Included : forall s s',  s[<=]s'  <-> Included _ (!!s) (!!s').
 Proof.
 unfold Subset, Included, In, mkEns; intuition.
 Qed.

 Notation " a === b " := (Same_set M.elt a b) (at level 70, no associativity).

 Lemma Equal_Same_set : forall s s', s[=]s' <-> !!s === !!s'.
 Proof.
 intros.
 rewrite double_inclusion.
 unfold Subset, Included, Same_set, In, mkEns; intuition.
 Qed.

 Lemma empty_Empty_Set : !!M.empty === Empty_set _.
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intro; set_iff; inversion 1.
 Qed.

 Lemma Empty_Empty_set : forall s, Empty s -> !!s === Empty_set _.
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intros.
 destruct(H x H0).
 inversion H0.
 Qed.

 Lemma singleton_Singleton : forall x, !!(M.singleton x) === Singleton _ x .
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intro; set_iff; inversion 1; try constructor; auto.
 Qed.

 Lemma union_Union : forall s s', !!(union s s') === Union _ (!!s) (!!s').
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intro; set_iff; inversion 1; [ constructor 1 | constructor 2 | | ]; auto.
 Qed.

 Lemma inter_Intersection : forall s s', !!(inter s s') === Intersection _ (!!s) (!!s').
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intro; set_iff; inversion 1; try constructor; auto.
 Qed.

 Lemma add_Add : forall x s, !!(add x s) === Add _ (!!s) x.
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intro; set_iff; inversion 1; auto with sets.
 inversion H0.
 constructor 2; constructor.
 constructor 1; auto.
 Qed.

 Lemma Add_Add : forall x s s', MP.Add x s s' -> !!s' === Add _ (!!s) x.
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intros.
 red in H; rewrite H in H0.
 destruct H0.
 inversion H0.
 constructor 2; constructor.
 constructor 1; auto.
 red in H; rewrite H.
 inversion H0; auto.
 inversion H1; auto.
 Qed.

 Lemma remove_Subtract : forall x s, !!(remove x s) === Subtract _ (!!s) x.
 Proof.
 unfold Same_set, Included, mkEns, In.
 split; intro; set_iff; inversion 1; auto with sets.
 split; auto.
 contradict H1.
 inversion H1; auto.
 Qed.

 Lemma mkEns_Finite : forall s, Finite _ (!!s).
 Proof.
 intro s; pattern s; apply set_induction; clear s; intros.
 intros; replace (!!s) with (Empty_set elt); auto with sets.
 symmetry; apply Extensionality_Ensembles.
 apply Empty_Empty_set; auto.
 replace (!!s') with (Add _ (!!s) x).
 constructor 2; auto.
 symmetry; apply Extensionality_Ensembles.
 apply Add_Add; auto.
 Qed.

 Lemma mkEns_cardinal : forall s, cardinal _ (!!s) (M.cardinal s).
 Proof.
 intro s; pattern s; apply set_induction; clear s; intros.
 intros; replace (!!s) with (Empty_set elt); auto with sets.
 rewrite cardinal_1; auto with sets.
 symmetry; apply Extensionality_Ensembles.
 apply Empty_Empty_set; auto.
 replace (!!s') with (Add _ (!!s) x).
 rewrite (cardinal_2 H0 H1); auto with sets.
 symmetry; apply Extensionality_Ensembles.
 apply Add_Add; auto.
 Qed.

 (** we can even build a function from Finite Ensemble to FSet
     ... at least in Prop. *)

 Lemma Ens_to_FSet : forall e : Ensemble M.elt, Finite _ e ->
   exists s:M.t, !!s === e.
 Proof.
 induction 1.
 exists M.empty.
 apply empty_Empty_Set.
 destruct IHFinite as (s,Hs).
 exists (M.add x s).
 apply Extensionality_Ensembles in Hs.
 rewrite <- Hs.
 apply add_Add.
 Qed.

End WS_to_Finite_set.

Module S_to_Finite_set (U:UsualOrderedType)(M: Sfun U) :=
  WS_to_Finite_set U M.


(** printing elimination %\coqdoctac{elimination}% *)
(** printing noconf %\coqdoctac{noconf}% *)
(** printing simp %\coqdoctac{simp}% *)
(** printing by %\coqdockw{by}% *)
(** printing rec %\coqdockw{rec}% *)
(** printing Coq %\Coq{}% *)
(** printing funelim %\coqdoctac{funelim}% *)
(** printing Derive %\coqdockw{Derive}% *)
(** printing Signature %\coqdocclass{Signature}% *)
(** printing Subterm %\coqdocclass{Subterm}% *)
(** printing NoConfusion %\coqdocclass{NoConfusion}% *)
(** * Polynomials

  Polynomials and a reflexive tactic for solving boolean goals (using
  heyting or classical boolean algebra).  Original version by Rafael
  Bocquet, 2016. Updated to use Equations for all definitions by M. Sozeau,
  2016-2017. If running this interactively you can ignore the printing
  and hide directives which are just used to instruct coqdoc. *)
(* begin hide *)
Require Import Program.Basics Program.Tactics.
From Equations Require Import Equations.
Require Import ZArith Lia.
Require Import Psatz.
Require Import NPeano.
Require Import Nat.
Require Import Coq.Vectors.VectorDef.

Set Keyed Unification.

Notation vector := Vector.t.
Arguments nil {A}.
Arguments cons {A} _ {n}.

Derive Signature for vector eq.
Coercion Bool.Is_true : bool >-> Sortclass.

Notation pack := Signature.signature_pack.

Lemma Is_true_irrel (b : bool) (p q : b) : p = q.
Proof.
  destruct b. destruct p, q. reflexivity.
  destruct p.
Defined.
#[local] Hint Resolve Is_true_irrel : core.
Check Zpos.
Check Zneg.
Check positive.
Check NoConfusion.
About Signature.
Check Signature.signature_pack.
(* end hide *)

(** We start with a simple definition deciding if some integer is equal
    to [0] or not. Integers are encoded using an inductive type [Z]
    with three constructors [Z0], [Zpos] and [Zneg], the latter two
    taking [positive] numbers as arguments. There is a single
    representant of [0] which we discriminate here. The second clause
    actually captures both the [Zpos] and [Zneg] constructors.  *)

Equations IsNZ (z : Z) : bool :=
  IsNZ Z0 := false; IsNZ _ := true.

(** The specification of this test is that it returns true iff the variable is indeed
    different from [0] w.r.t. the standard Leibniz equality. We elide a simple proof
    by case analysis. Note that we use an implicit coercion from [bool] to [Prop] here,
    as is usual when doing boolean reflection. *)

Lemma IsNZ_spec z : IsNZ z <-> (z <> 0)%Z.
Proof.
  funelim (IsNZ z); unfold not; split; intros;
    (discriminate || contradiction || constructor).
Qed.

(** *** Multivariate polynomials

   Using an indexed inductive type, we ensure that polynomials of
   %$\mathbb{Z}[(X_i)_{i \in \mathbb{N}}]$% have a unique
   representation.  The first index indicates that the polynom is
   null. The second index gives the number of free variables. *)

Inductive poly : bool -> nat -> Type :=
| poly_z : poly true O
| poly_c (z : Z) : IsNZ z -> poly false O
| poly_l {n b} (Q : poly b n) : poly b (S n)
| poly_s {n b} (P : poly b n) (Q : poly false (S n)) :
    poly false (S n).

(**
- [poly_z] represents the null polynomial.
- [poly_c c] represents the constant polynomial [c] where [c] is non-zero (i.e. has a proof of [IsNZ c]).
- [poly_l n Q] represents the injection of [Q], a
  polynomial on [n] variables, as a polynomial on [n+1] variables.
- Finally, [poly_s P Q : poly _ (S n)] represents $P + X_n * Q$
  where [P] cannot mention the variable $X_n$ but [Q] can mention
  the variables up to and including $X_n$, and the multiplication is
  not trivial as [Q] is non-null.

These indices enforce a canonical
representation by ordering the multiplications of the variables.  A
similar encoding is actually used in the [ring] tactic of [Coq]. *)

Derive Signature NoConfusion NoConfusionHom for poly.
Derive Subterm for poly.

(** In addition to the usual eliminators of the inductive type
  generated by [Coq], we automatically derive a few constructions on
  this [poly] datatype, and the [mono] datatype that follows,
  that will be used by the [Equations] command:

- Its [Signature]: as described earlier %(\S \ref{sec:deppat})%, this is
  the packing of a polynomial with its two indices, a boolean and a
  natural number in this case.
- Its [NoConfusion] property used to
  simplify equalities between constructors of the [poly] type
  (equation %\ref{eqn:noconf}%).
- Finally, its [Subterm] relation, to be used when performing
  well-founded recursion on [poly]. *)

(** *** Monomials

  Monomials represent parts of polynoms, and one can compute the
  coefficient constant by which each monomial is multiplied in a given
  polynom. Again the index of a [mono] gives the number of its free variables. *)

Inductive mono : nat -> Type :=
| mono_z : mono O
| mono_l : forall {n}, mono n -> mono (S n)
| mono_s : forall {n}, mono (S n) -> mono (S n).

Derive Signature NoConfusion NoConfusionHom Subterm for mono.

(** Our first interesting definition computes the coefficient in [Z] by which
    a monomial [m] is multiplied in a polynomial [p]. *)

Equations get_coef {n} (m : mono n) {b} (p : poly b n) : Z by wf (pack m) mono_subterm :=
get_coef mono_z     poly_z       := 0%Z;
get_coef mono_z     (poly_c z _) := z;
get_coef (mono_l m) (poly_l p)   := get_coef m p;
get_coef (mono_l m) (poly_s p _) := get_coef m p;
get_coef (mono_s m) (poly_l _)   := 0%Z;
get_coef (mono_s m) (poly_s p1 p2) := get_coef m p2.

(** The definition can be done using either the usual structural
  recursion of [Coq] or well-founded recursion. If we use structural
  recursion, the guardness check might not be able to verify the
  automatically generated proof that the function respects its graph, as
  it involves too much rewriting due to dependent pattern-matching. We
  could prove it using a dependent induction instead of using the raw
  fixpoint combinator as the recursion is on direct subterms of the
  monomial, but in general it could be arbitrarily complicated, so we
  present a version allowing deep pattern-matching and recursion. Note
  that this means we lose the definitional behavior of [get_coef] during
  proofs on open terms, but this can advantageously be replaced using
  explicit [rewrite] calls, providing much more control over
  simplification than the reduction tactics, especially in presence of
  recursive functions. The [get_coef] function still uses no axioms,
  so it can be used to compute as part of a reflexive tactic for example.

  We want to do recursion on the (dependent) [m : mono n] argument,
  using the derived [mono_subterm] relation, which expects an element in
  the signature of [mono], [{ n : nat & mono n }], so we use [pack m] to
  lift [m] into its signature type ([pack] is just an abbreviation for
  the [signature_pack] overloaded constant defined in %\S
  \ref{sec:deppat}%).

  The rest of the definition is standard: to fetch a monomial
  coefficient, we simultaneously pattern-match on the monomial and
  polynomial. Note that many cases are impossible due to the invariants
  enforced in [poly] and [mono]. For example [mono_z] can only match
  polynomials built from [poly_z] or [poly_c], etc. *)

(** *** Two detailed proofs

  The monomial decomposition is actually a complete characterization
  of a polynomial: two polynomials with the same coefficients for every
  monomial are the same. *)

(** To show this, we need a lemma that shows that every non-null polynomial,
    has a monomial with non-null coefficient:
    this proof is done by dependent induction on the polynomial [p].
    Note that the index of [p] rules out the [poly_z] case. *)

Lemma poly_nz {n} (p : poly false n) : exists m, IsNZ (get_coef m p).
Proof with (autorewrite with get_coef; auto).
  intros. depind p.
  exists mono_z...
  destruct IHp. exists (mono_l x)...
  destruct IHp2. exists (mono_s x)...
Qed.

Notation " ( x ; p ) " := (existT _ x p).

Theorem get_coef_eq {n} b1 b2
  (p1 : poly b1 n) (p2 : poly b2 n) :
  (forall (m : mono n), get_coef m p1 = get_coef m p2) ->
  (b1 ; p1) = (b2 ; p2) :> { null : _ & poly null n}.
Proof with (simp get_coef in *; auto).

  (** Throughout the proof, we use the [simp] tactic defined by
      %\Equations% which is a wrapper around [autorewrite] using the hint
      database associated to the constant [get_coef]: the database
      contains the defining equations of [get_coef] as rewrite rules
      that can be used to simplify calls to [get_coef] in the goal. *)

intros Hcoef.
induction p1 as [ | z Hz | n b p1 | n b p1 IHp q1 IHq ]
  in b2, p2, Hcoef |- *;
[dependent elimination p2 as [poly_z | poly_c z i] |
 dependent elimination p2 as [poly_z | poly_c z' i'] |
 dependent elimination p2 as
     [@poly_l n b' p2 | @poly_s n b' p2 q2] ..].
  all:(intros; try rename n0 into n; auto;
      try (specialize (Hcoef mono_z); simp get_coef in Hcoef; subst z;
           (elim i || elim Hz ||
            ltac:(repeat f_equal; auto)); fail)).
  - specialize (IHp1 _ p2). forward IHp1. intro m.
    specialize (Hcoef (mono_l m))... clear Hcoef.

    (** We first do an induction on [p1] and then eliminate (dependently)
        [p2], the first two branches need to consider variable-closed [p2]s
        while the next two branches have [p2 : poly _ (S n)], hence the [poly_l]
        and [poly_s] patterns. The elided rest of the tactic solves simple subgoals.

      We now focus on the case for [poly_l] on both sides.
      After some simplifications of the induction hypothesis using
      the [Hcoef] hypothesis, we get to the following goal:
[[
  (b, b' : bool) (n : nat) (p1 : poly b n) (p2 : poly b' n)
  IHp1 : (b; p1) = (b'; p2)
  ============================
  (b; poly_l p1) = (b'; poly_l p2)
]]

  The [IHp1] hypothesis, as a general equality between dependent
  pairs can again be eliminated dependently to substitute [b'] by
  [b] and [p2] by [p1] simultaneously, using
  [dependent elimination IHp1 as [eq_refl]], leaving us with
  a trivial subgoal. *)
(* begin hide *)
    dependent elimination IHp1 as [eq_refl].
    reflexivity.
  - destruct (poly_nz q2) as [m HNZ].
    specialize (Hcoef (mono_s m))...
    rewrite <- Hcoef in HNZ; elim HNZ.

  - destruct (poly_nz q1) as [m HNZ].
    specialize (Hcoef (mono_s m))...
    rewrite Hcoef in HNZ; elim HNZ.

  - forward (IHq _ q2).
    intro m. specialize (Hcoef (mono_s m))...
    apply f_equal.
    forward (IHp _ p2).
    intro. specialize (Hcoef (mono_l m))...
    depelim IHp.
    now depelim IHq.
Qed.
(* end hide *)

(** The next step is to give an evaluation semantics to polynomials.
    We program [eval p v] where [v] is a valuation in [Z] for all the
    variables in [p : poly _ n]. *)

Equations eval {n} {b} (p : poly b n) (v : Vector.t Z n) : Z :=
  eval poly_z         nil           := 0%Z;
  eval (poly_c z _)   nil           := z;
  eval (poly_l p)     (cons _ xs)   := eval p xs;
  eval (poly_s p1 p2) (cons y ys) :=
    (eval p1 ys + y * eval p2 (cons y ys))%Z.

(** It is quite clear that two equal polynomials should have the
    same value for any valuation. To show this, we first need to prove
    that evaluating a null polynomial always computes to [0], whichever
    valuation is used. *)
(* begin hide *)
Check eval.
Lemma poly_nz_eval' : forall {n},
                          (forall (p : poly false n), exists v, IsNZ (eval p v)) ->
                          (forall (p : poly false (S n)),
                           exists v, forall m, exists x,
                                 IsNZ x /\
                                 (Z.abs (x * eval p (Vector.cons x v)) > Z.abs m)%Z).
Proof with (simp eval).
  depind p.
  - destruct (H p) as [v Hv].
    exists v; intros; exists (1 + Z.abs m)%Z...
    rewrite IsNZ_spec in Hv |- *. nia.
  - destruct (IHp2 H) as [v Hv]; exists v; intros.
    destruct (Hv (Z.abs (eval p1 v) + Z.abs m)%Z) as [x [Hx0 Hx1]]; exists x...
    split; auto. rewrite IsNZ_spec in Hx0.
    nia.
Qed.

Lemma poly_nz_eval : forall {n},
    (forall (p : poly false n), exists v, IsNZ (eval p v))
    /\ (forall (p : poly false (S n)),
           exists v, forall m, exists x,
                 IsNZ x /\
                 (Z.abs (x * eval p (Vector.cons x v)) > Z.abs m)%Z).
Proof with (autorewrite with eval; auto using poly_nz_eval').
  depind n; match goal with
            | [ |- ?P /\ ?Q ] => assert (HP : P); [|split;[auto|]]
            end...
  depelim p; exists Vector.nil...
  - destruct IHn as [IHn1 IHn2]; depelim p.
    + destruct (IHn1 p) as [v Hv]; exists (Vector.cons 0%Z v)...
    + destruct (IHn2 p2) as [v Hv].
      destruct (Hv (eval p1 v)) as [x [_ Hx]].
      exists (Vector.cons x v)...
      rewrite IsNZ_spec; nia.
Qed.
(* end hide *)
(** This is a typical case where the proof directly follows the definition
  of [eval]. Instead of redoing the same case splits and induction that
  the function performs, we can directly appeal to its elimination
  principle using the [funelim] tactic. *)

Lemma poly_z_eval {n} (p : poly true n) v : eval p v = 0%Z.
Proof.
  funelim (eval p v); [ reflexivity | assumption ].
Qed.

(** This leaves us with two goals as the [true] index in [p] implies
  that the [poly_c] and [poly_s] clauses do not need to be considered.
  We have to show [0 = 0] for the case [p = poly_z] and [eval q v = 0]
  for the [poly_l] recursive constructor, in which case the conclusion
  directly follows from the induction hypothesis correspondinng to the
  recursive call. The second subgoal is hence discharged with an
  [assumption] call.

  Addition is defined on two polynomials with the same number of variables and returns
  a (possibly null) polynomial with the same number of variables.
  We define an injection function to constructs objects in the dependent pair type
  [{b : bool & poly b n}]. *)

Definition apoly {n b} := existT (fun b => poly b n) b.

(** The definition shows the [with] feature of Equations, allowing to
    add a nested pattern-matching while defining the function, here in
    one case to inject an integer into a polynomial and in the
    [poly_s], [poly_s] case to inspect a recursive call. *)

Notation " x .1 " := (projT1 x) (at level 3, format "x .1").
Notation " x .2 " := (projT2 x) (at level 3, format "x .2").

Equations plus {n} {b1} (p1 : poly b1 n) {b2} (p2 : poly b2 n) : { b : bool & poly b n } :=
  plus poly_z        poly_z          := apoly poly_z;
  plus poly_z        (poly_c y ny)   := apoly (poly_c y ny);
  plus (poly_c x nx) poly_z          := apoly (poly_c x nx);
  plus (poly_c x nx) (poly_c y ny)   with (x + y)%Z => {
                 | Z0 => apoly poly_z ;
                 | Zpos z' => apoly (poly_c (Zpos z') I) ;
                 | Zneg z' => apoly (poly_c (Zneg z') I) };
  plus (poly_l p1)    (poly_l p2)    := apoly (poly_l (plus p1 p2).2);
  plus (poly_l p1)    (poly_s p2 q2) := apoly (poly_s (plus p1 p2).2 q2);
  plus (poly_s p1 q1) (poly_l p2)    := apoly (poly_s (plus p1 p2).2 q1);

  plus (poly_s p1 q1) (poly_s p2 q2) with plus q1 q2 => {
       | (false ; q3) => apoly (poly_s (plus p1 p2).2 q3);
       | (true  ; _)  => apoly (poly_l (plus p1 p2).2) }.

(** The functional elimination principle can be derived all the same
    for [plus], allowing us to make quick work of the proof that it
    is a morphism for evaluation: *)

Lemma plus_eval : forall {n} {b1} (p1 : poly b1 n) {b2} (p2 : poly b2 n) v,
    (eval p1 v + eval p2 v)%Z = eval (plus p1 p2).2 v.
Proof with (simp plus eval; auto with zarith).
  Ltac X := (simp plus eval; auto with zarith).
    intros until p2.
    let f := constr:(fun_elim (f:=@plus)) in apply f; intros; depelim v; X; try rewrite <- H; X.
  - rewrite Heq in Hind.
    specialize (Hind (Vector.cons h v)).
    rewrite poly_z_eval in Hind. nia.
  - rewrite Heq in Hind. rewrite <- Hind. nia.
Qed.
#[local] Hint Rewrite <- @plus_eval : eval.

(** We skip the rest of the operations definition, [poly_mult], [poly_neg] and
    [poly_substract]. *)

Equations poly_neg {n} {b} (p : poly b n) : poly b n :=
  poly_neg poly_z := poly_z;
  poly_neg (poly_c (Z.pos a) p) := poly_c (Z.neg a) p;
  poly_neg (poly_c (Z.neg a) p) := poly_c (Z.pos a) p;
  poly_neg (poly_l p) := poly_l (poly_neg p);
  poly_neg (poly_s p q) := poly_s (poly_neg p) (poly_neg q).

Lemma neg_eval : forall {n} {b1} (p1 : poly b1 n) v,
    (- eval p1 v)%Z = eval (poly_neg p1) v.
Proof.
  Ltac XX := (autorewrite with poly_neg plus eval; auto with zarith).
  depind p1; depelim v; XX. destruct z; depelim i; XX.
  rewrite <- IHp1_1; rewrite <- IHp1_2; nia.
Qed.
#[local] Hint Rewrite <- @neg_eval : eval.

(** Equality can be decided using the difference of polynoms *)
Lemma poly_diff_z_eq : forall {n} {b1} (p1 : poly b1 n) {b2} (p2 : poly b2 n),
    (plus p1 (poly_neg p2)).1 = true ->
    (_ ; p1) = (_; p2) :> { null : bool & poly null n }.
Proof.
  intros.
  depind p1; depelim p2; auto;
    try (autorewrite with poly_neg plus in H; discriminate; fail).
  - destruct z; destruct i; autorewrite with poly_neg plus in *; discriminate.
  - f_equal; destruct z as [ | z | z], z0 as [ | z0 | z0 ]; depelim i; depelim i0; autorewrite with poly_neg plus in H.
    assert (z = z0).
    remember (Z.pos z + Z.neg z0)%Z as z1; destruct z1; try discriminate; simpl in H; nia.
    subst; auto.
    remember (Z.pos z + Z.pos z0)%Z as z1; destruct z1; try discriminate.
    remember (Z.neg z + Z.neg z0)%Z as z1; destruct z1; try discriminate.
    assert (z = z0).
    remember (Z.neg z + Z.pos z0)%Z as z1; destruct z1; try discriminate; simpl in H; nia.
    subst; auto.
  - autorewrite with poly_neg plus in H.
    specialize (IHp1 _ p2 H).
    depelim IHp1. auto.
  - autorewrite with poly_neg plus in H.
    specialize (IHp1_1 _ p2_1); specialize (IHp1_2 _ p2_2).
    remember (plus p1_2 (poly_neg p2_2)) as P; remember (plus p1_1 (poly_neg p2_1)) as Q.
    destruct P as [bP P]; destruct Q as [bQ Q].
    destruct bP; destruct bQ; simpl in H; try rewrite <- HeqQ in H; try discriminate.
    specialize (IHp1_1 eq_refl); specialize (IHp1_2 eq_refl).
    depelim IHp1_1; try depelim IHp1_2; auto.
Qed.

(**
 *** Two polynomials with the same values are syntacically equal.
 This is shown using [poly_nz_eval]: the difference of two polynomials with the same values is null.
 Then use [poly_diff_z_eq]
 *)
Theorem poly_eval_eq : forall {n} {b1} (p1 : poly b1 n) {b2} (p2 : poly b2 n),
    (forall v, eval p1 v = eval p2 v) ->
    (b1 ; p1) = (b2; p2) :> { b : bool & poly b n}.
Proof.
  intros.
  remember (plus p1 (poly_neg p2)) as P; destruct P as [b P]; destruct b.
  - apply poly_diff_z_eq; inversion HeqP; auto.
  - exfalso.
    destruct (@poly_nz_eval n) as [H0 _]; destruct (H0 P) as [v H1].
    assert (eval P v = eval (plus p1 (poly_neg p2)).2 v); [inversion HeqP; auto|].
    rewrite H2 in H1; autorewrite with eval in H1; rewrite (H v) in H1.
    rewrite IsNZ_spec in H1.
    nia.
Qed.

(**
 *** Multiplication of polynomials

  This definition is a bit more laborious as there are inductive cases to treat on the second argument:
  it is not a simple structurally recursive definition.
 *)

(** The [poly_l_or_s] definition is a smart constructor to construct
    [p + X * q] when [q] can be null. *)

Equations poly_l_or_s {n} {b1} (p1 : poly b1 n) {b2} (p2 : poly b2 (S n)) :
  {b : bool & poly b (S n)} :=
poly_l_or_s p1 (b2 := true) p2 := apoly (poly_l p1);
poly_l_or_s p1 (b2 := false) p2 := apoly (poly_s p1 p2).

Lemma poly_l_or_s_eval : forall {n} {b1} (p1 : poly b1 n) {b2} (p2 : poly b2 (S n)) h v,
    eval (poly_l_or_s p1 p2).2 (Vector.cons h v) =
    (eval p1 v + h * eval p2 (Vector.cons h v))%Z.
Proof.
  intros.
  funelim (poly_l_or_s p1 p2); simp eval; trivial. rewrite poly_z_eval. nia.
Qed.
#[local] Hint Rewrite @poly_l_or_s_eval : eval.

(* [mult (poly_l p) q = mult_l q (mult p)] *)

Equations mult_l {n} {b2} (p2 : poly b2 (S n)) (m : forall {b2} (p2 : poly b2 n), { b : bool & poly b n }) :
  { b : bool & poly b (S n) } :=
  mult_l (poly_l p2) m := apoly (poly_l (m _ p2).2);
  mult_l (poly_s p1 p2) m := poly_l_or_s (m _ p1).2 (mult_l p2 m).2.

(* [mult (poly_s p1 p2) q = mult_s q (mult p1) (mult p2)] *)

Equations mult_s {n} {b2} (p2 : poly b2 (S n))
     (m1 : forall {b2} (p2 : poly b2 n), { b : bool & poly b n })
     (m2 : forall {b2} (p2 : poly b2 (S n)), { b : bool & poly b (S n) }) :
    { b : bool & poly b (S n) } :=
  mult_s (poly_l p1) m1 m2 := poly_l_or_s (m1 _ p1).2 (m2 _ (poly_l p1)).2;
  mult_s (poly_s p2 q2) m1 m2 :=
    poly_l_or_s (m1 _ p2).2
                (plus (m2 _ (poly_l p2)).2 (mult_s q2 m1 m2).2).2.

(** Finally, the multiplication definition. This relies on the
   guard condition being able to unfold the definitions of [mult_l] and [mult_s] to
   see that multiplication is well-guarded. *)

Equations mult n b1 (p1 : poly b1 n) b2 (p2 : poly b2 n) : { b : bool & poly b n } :=
    mult ?(0) ?(true) poly_z        b2 _ := apoly poly_z;
    mult ?(0) ?(false) (poly_c x nx) ?(true) poly_z := apoly poly_z;
    mult ?(0) ?(false) (poly_c x nx) ?(false) (poly_c y ny) :=
    match (x * y)%Z with
      | Z0 => apoly poly_z
      | Zpos z' => apoly (poly_c (Zpos z') I)
      | Zneg z' => apoly (poly_c (Zneg z') I)
    end;
    mult ?(S n) ?(b) (@poly_l n b p1)    b2 q := mult_l q (mult _ _ p1);
    mult ?(S n) ?(false) (@poly_s n b p1 q1) b2 q := mult_s q (mult _ _ p1) (mult _ _ q1).
Arguments mult {n} {b1} p1 {b2} p2.

(** The proof that multiplication is a morphism for evaluation works as usual by induction,
    using previously proved lemma to get equations in [Z] that the [nia] tactic can handle. *)

Lemma mult_eval : forall {n} {b1} (p1 : poly b1 n) {b2} (p2 : poly b2 n) v,
    (eval p1 v * eval p2 v)%Z = eval (mult p1 p2).2 v.
Proof with (autorewrite with mult mult_l mult_s eval; auto with zarith).
  Ltac Y := (autorewrite with mult mult_l mult_s eval; auto with zarith).
  depind p1; try (depind p2; intros; depelim v; Y; simpl; Y; fail).
  depind p2; intros; depelim v; Y; simpl; Y; destruct (z * z0)%Z; simpl...
  - assert (mult_l_eval : forall {b2} (q : poly b2 (S n)) v h,
               eval (mult_l q (@mult _ _ p1)).2 (Vector.cons h v) =
               (eval q (Vector.cons h v) * eval p1 v)%Z).
    + depind q; intros; Y;
        rewrite <- IHp1...
      rewrite IHq2; auto; nia.
    + intros; depelim v; Y; simpl; Y; rewrite mult_l_eval...
  - assert (mult_s_eval :
              forall {b2} (q : poly b2 (S n)) v h,
                let mp := mult_s q (@mult _ _ p1_1) (@mult _ _ p1_2) in
                  eval mp.2 (Vector.cons h v) =
                  (eval q (Vector.cons h v) * (eval p1_1 v + h * eval p1_2 (Vector.cons h v)))%Z).
    + depind q; intros; Y; simpl; Y.
      rewrite <- IHp1_1, <- IHp1_2; Y; nia.
      rewrite <- IHp1_1. rewrite IHq2, <- IHp1_2; auto; Y; nia.
    + intros; depelim v; Y; simpl; Y; rewrite mult_s_eval...
Qed.
#[local] Hint Rewrite <- @mult_eval : eval.
(** ** Boolean formulas

  Armed with these definitions, we can define a reflexive tactic that
  solves boolean tautologies using a translation into polynomials on [Z].
  We start with the syntax of our formulas, including variables of some type
  [A], constants, conjunction disjunction and negation: *)

Inductive formula {A} :=
| f_var : A -> formula
| f_const : bool -> formula
| f_and : formula -> formula -> formula
| f_or : formula -> formula -> formula
| f_not : formula -> formula.

(** The have a straightforward evaluation semantics to booleans, assuming
    an interpretation of the variables into booleans. *)

Equations eval_formula {A} (v : A -> bool) (f : @formula A) : bool :=
  eval_formula f (f_var v)   := f v;
  eval_formula f (f_const b) := b;
  eval_formula f (f_and a b) := andb (eval_formula f a) (eval_formula f b);
  eval_formula f (f_or a b)  := orb (eval_formula f a) (eval_formula f b);
  eval_formula f (f_not v)   := negb (eval_formula f v).

(** [close_formula] allows to obtain a formula with a fixed finite number of free variables from
   a formula with with variables in [nat]. *)
Definition close_formula : @formula nat -> { n : nat & forall m, m >= n -> @formula (Fin.t m) }.
Proof.
  intro f; depind f.
  - unshelve eapply (S a ; _); intros m p; apply f_var.
    apply @Fin.of_nat_lt with (p := a). lia.
  - exact (O ; (fun _ _ => f_const b)).
  - destruct IHf1 as [n1 e1]; destruct IHf2 as [n2 e2].
    apply (existT _ (max n1 n2)); intros m p; apply f_and; [apply e1|apply e2]; nia.
  - destruct IHf1 as [n1 e1]; destruct IHf2 as [n2 e2].
    apply (existT _ (max n1 n2)); intros m p; apply f_or; [apply e1|apply e2]; nia.
  - destruct IHf as [n e].
    apply (existT _ n); intros m p; apply f_not; apply e; nia.
Defined.

Definition close_formulas (f1 f2 : @formula nat) :
  { n : nat & (@formula (Fin.t n) * @formula (Fin.t n))%type }.
Proof.
  destruct (close_formula f1) as [n1 e1]; destruct (close_formula f2) as [n2 e2].
  apply (existT _ (max n1 n2)); apply pair; [apply e1|apply e2]; nia.
Defined.

(** Definitions of constant 0 [poly_zero] and 1 [poly_one] polynomials along with variable polynomials
    [poly_var] and corresponding evaluation lemmas *)

Fixpoint poly_zero {n} : poly true n :=
  match n with
  | O   => poly_z
  | S m => poly_l poly_zero
  end.
Lemma zero_eval : forall n v, 0%Z = eval (@poly_zero n) v.
Proof. intros; rewrite poly_z_eval; auto. Qed.
#[local] Hint Rewrite <- @zero_eval : eval.

Fixpoint poly_one {n} : poly false n :=
  match n with
  | O   => poly_c 1%Z I
  | S m => poly_l poly_one
  end.
Lemma one_eval : forall n v, 1%Z = eval (@poly_one n) v.
Proof. depind n; depelim v; intros; simpl; autorewrite with eval; auto. Qed.
#[local] Hint Rewrite <- @one_eval : eval.

(** We define an injection of variables represented as indices in [Fin.t n] into
    non-null polynoms of [n] variables: *)

Equations poly_var {n} (f : Fin.t n) : poly false n :=
  poly_var Fin.F1     := poly_s poly_zero poly_one;
  poly_var (Fin.FS f) := poly_l (poly_var f).

(** We can show that evaluation of the corresponding polynomial corresponds to
    simply fetching the value at the index in the valuation. *)

Lemma var_eval : forall n f v, Vector.nth v f = eval (@poly_var n f) v.
Proof with autorewrite with poly_var eval in *; simpl; auto with zarith.
  induction f; depelim v; intros...
Qed.
#[local] Hint Rewrite <- @var_eval : eval.

(** Finally, we explain our interpretation of formulas as polynomials: *)

Equations poly_of_formula {n} (f : @formula (Fin.t n)) : { b : bool & poly b n } :=
  poly_of_formula (f_var v)       := apoly (poly_var v);
  poly_of_formula (f_const false) := apoly poly_zero;
  poly_of_formula (f_const true)  := apoly poly_one;
  poly_of_formula (f_not a)       := plus poly_one (poly_neg (poly_of_formula a).2);
  poly_of_formula (f_and a b)     := mult (poly_of_formula a).2 (poly_of_formula b).2;
  poly_of_formula (f_or a b)      := plus (poly_of_formula a).2
                                          (plus (poly_of_formula b).2
          (poly_neg (mult (poly_of_formula a).2 (poly_of_formula b).2).2)).2.

(** The central theorem is that evaluating the formula in some valuation
    is the same as evaluating the translated polynomial. *)

Theorem poly_of_formula_eval :
  forall {n} (f : @formula (Fin.t n)) (v : Vector.t bool n),
    (if eval_formula (Vector.nth v) f then 1%Z else 0%Z) =
    eval (poly_of_formula f).2 (Vector.map (fun x : bool => if x then 1%Z else 0%Z) v).
(* begin hide *)
Proof.
  intros. funelim (poly_of_formula f); intros;
    autorewrite with eval_formula poly_of_formula eval in *; trivial.
  - erewrite Vector.nth_map; auto.
  - rewrite <- H, <- H0; destruct (eval_formula (Vector.nth v) a); destruct (eval_formula (Vector.nth v) b); auto.
  - rewrite <- H, <- H0; destruct (eval_formula (Vector.nth v) a); destruct (eval_formula (Vector.nth v) b); auto.
  - rewrite <- H; destruct (eval_formula (Vector.nth v) a); auto.
Qed.
(* end hide *)

(** From this, we can derive that two boolean formulas are equivalent if
    the translated polynomials are themselves _syntactically_ equal,
    thanks to their canonical representation. *)

Lemma correctness_heyting : forall {n} (f1 f2 : @formula (Fin.t n)),
    poly_of_formula f1 = poly_of_formula f2 ->
    forall v, eval_formula (Vector.nth v) f1 = eval_formula (Vector.nth v) f2.
Proof.
  intros n f1 f2 H v.
  assert (H1 := poly_of_formula_eval f1 v); assert (H2 := poly_of_formula_eval f2 v).
  remember (eval_formula (Vector.nth v) f1) as b1; remember (eval_formula (Vector.nth v) f2) as b2.
  rewrite H in H1; rewrite <- H1 in H2.
  destruct b1; destruct b2; simpl in *; (discriminate || auto).
Qed.

(** *** Completeness

  For which theory do we have completeness? If you were attentive you might
  have guessed that the encodings of disjunction and conjunction are only
  complete for heyting boolean algebras but not classical boolean algebra,
  where negation is involutive.

  One can avoid this problem by doing a reduction transformation on polynomials.
  The interested reader can look at the development for that part.
  Completeness can be derived for the reducing version of the translation.
 *)

Equations reduce_aux {n} {b1} (p1 : poly b1 n) {b2} (p2 : poly b2 (S n)) : { b : bool & poly b (S n) } :=
reduce_aux p1 (poly_l p2) := poly_l_or_s p1 (poly_l p2);
reduce_aux p1 (poly_s p2_1 p2_2) := poly_l_or_s p1 (plus (poly_l p2_1) p2_2).2.

Equations reduce {n} {b} (p : poly b n) : { b : bool & poly b n } :=
  reduce poly_z       := apoly poly_z;
  reduce (poly_c x y) := apoly (poly_c x y);
  reduce (poly_l p)   := apoly (poly_l (reduce p).2);
  reduce (poly_s p q) := reduce_aux (reduce p).2 (reduce q).2.

Theorem reduce_eval :
  forall {n} {b} (p : poly b n) (v : Vector.t bool n),
    eval p (Vector.map (fun x : bool => if x then 1%Z else 0%Z) v) =
    eval (reduce p).2 (Vector.map (fun x : bool => if x then 1%Z else 0%Z) v).
Proof.
  Ltac YY := autorewrite with reduce reduce_aux eval; auto.
  depind p; intros; depelim v; YY.
  - rewrite IHp1, (IHp2 (Vector.cons h v)).
    remember (reduce p2) as P.
    destruct P as [bP P]. simpl. depelim P; simpl; YY.
    destruct h; nia.
Qed.

Inductive is_reduced : forall {b} {n}, poly b n -> Prop :=
| is_reduced_z : is_reduced poly_z
| is_reduced_c : forall {z} {i}, is_reduced (poly_c z i)
| is_reduced_l : forall {b} {n} (p : poly b n), is_reduced p -> is_reduced (poly_l p)
| is_reduced_s : forall {b1} {n} (p : poly b1 n) (q : poly false n),
    is_reduced p -> is_reduced q -> is_reduced (poly_s p (poly_l q))
.
Derive Signature for is_reduced.

Lemma is_reduced_compat_plus : forall {n} {b1} (p1 : poly b1 n) (Hp1 : is_reduced p1)
                                      {b2} (p2 : poly b2 n) (Hp2 : is_reduced p2),
    is_reduced (plus p1 p2).2.
Proof.
  intros.
  depind Hp1; depelim Hp2; autorewrite with plus; unfold apoly; cbn; try constructor; auto.
  remember (z+z0)%Z as Z; destruct Z; constructor.
  specialize (IHHp1_2 _ q0 Hp2_2).
  remember (plus q q0) as Q; destruct Q as [bQ Q].
  destruct bQ; simpl. constructor; auto. constructor; auto.
Qed.

Lemma is_reduced_compat_neg : forall {n} {b1} (p1 : poly b1 n) (Hp1 : is_reduced p1),
    is_reduced (poly_neg p1).
Proof.
  intros. depind Hp1; try destruct z, i; autorewrite with poly_neg; try constructor; auto.
Qed.

Lemma is_reduced_ok : forall {b} {n} (p : poly b n), is_reduced (reduce p).2.
Proof.
  depind p; try constructor; auto.
  autorewrite with reduce reduce_aux.
  remember (reduce p2) as P2; destruct P2 as [bP2 P2]; depelim P2.
  destruct bP2; simpl. constructor. auto. constructor; auto. depelim IHp2. auto.

  depelim IHp2. autorewrite with reduce_aux plus. unfold apoly. simpl.
  assert (R := is_reduced_compat_plus _ IHp2_1 _ IHp2_2).
  remember (plus P2_1 q) as P3; destruct P3 as [bP3 P3]. simpl.
  simpl in *.
  destruct bP3; simpl; constructor; auto.
Qed.

Lemma red_ok : forall {n} {b} (p : poly b n),
    is_reduced p ->
    (forall v, eval p (Vector.map (fun x : bool => if x then 1%Z else 0%Z) v) = 0%Z) ->
    b = true.
Proof.
  intros n b p Hp H; depind Hp.
  - auto.
  - specialize (H Vector.nil); autorewrite with eval in H; destruct z, i; discriminate.
  - apply IHHp. intro v. specialize (H (Vector.cons false v)). autorewrite with eval in H. auto.
  - assert (b1 = true).
    + apply IHHp1. intro v. specialize (H (Vector.cons false v)). autorewrite with eval in H. simpl in H. rewrite Z.add_0_r in H. auto.
    + subst. apply IHHp2.
      intro v. specialize (H (Vector.cons true v)). simpl in H. autorewrite with eval in H. rewrite poly_z_eval in H. nia.
Qed.

(** We have completeness for this form: *)

Lemma correctness_classical : forall {n} (f1 f2 : @formula (Fin.t n)),
    reduce (poly_of_formula f1).2 = reduce (poly_of_formula f2).2 <->
    forall v, eval_formula (Vector.nth v) f1 = eval_formula (Vector.nth v) f2.
Proof.
  intros n f1 f2; split.
  - intros H v.
    assert (H1 := poly_of_formula_eval f1 v); assert (H2 := poly_of_formula_eval f2 v).
    rewrite reduce_eval in H1; rewrite reduce_eval in H2.
    remember (eval_formula (Vector.nth v) f1) as b1; remember (eval_formula (Vector.nth v) f2) as b2.
    rewrite H in H1; rewrite <- H1 in H2.
    destruct b1; destruct b2; simpl in *; (discriminate || auto).
  - intros.
    assert ((plus (reduce (poly_of_formula f1).2).2
                  (poly_neg (reduce (poly_of_formula f2).2).2)).1 = true).
    + apply red_ok with (p := (plus (reduce (poly_of_formula f1).2).2
                                    (poly_neg (reduce (poly_of_formula f2).2).2)).2).
      * auto using is_reduced_compat_plus, is_reduced_ok, is_reduced_compat_neg.
      * intro; autorewrite with eval.
        assert (H1 := poly_of_formula_eval f1 v); assert (H2 := poly_of_formula_eval f2 v).
        rewrite <- !reduce_eval, <- H1, <- H2, (H v); nia.
    + apply poly_diff_z_eq in H0.
      remember (reduce (poly_of_formula f1).2) as P1; destruct P1 as [bP1 P1].
      remember (reduce (poly_of_formula f2).2) as P2; destruct P2 as [bP2 P2].
      destruct bP1; destruct bP2; auto; simpl in H0; depelim H0; auto.
Qed.

(** One can check that all definitions here are axiom free, and only the proofs
    which depend on unfolding lemmas use the [functional_extensionality_dep] axiom. *)

(** *** Reflexive tactic

  From this it is possible to derive a tactic for checking equivalence of boolean
  formulas. We skip the standard reification machinery and check on a few examples
  that indeed our tactic computes. *)

Ltac list_add a l :=
    let rec aux a l n :=
        match l with
          | nil => constr:((n, cons a l))
          | cons a _ => constr:((n, l))
          | cons ?x ?l =>
            match aux a l (S n) with (?n, ?l) => constr:((n, cons x l)) end
        end in
    aux a l 0.

Ltac vector_of_list l :=
  match l with
  | nil => constr:(Vector.nil)
  | cons ?x ?xs => constr:(Vector.cons x xs)
  end.

(** Reify boolean formulas with variables in [nat] *)

Ltac read_formula f l :=
  match f with
  | true => constr:((@f_const nat true, l))
  | false => constr:((@f_const nat false, l))
  | orb ?x ?y => match read_formula x l with (?x', ?l') =>
                    match read_formula y l' with (?y', ?l'') => constr:((f_or x' y', l''))
                    end end
  | andb ?x ?y => match read_formula x l with (?x', ?l') =>
                     match read_formula y l' with (?y', ?l'') => constr:((f_and x' y', l''))
                     end end
  | negb ?x => match read_formula x l with (?x', ?l') => constr:((f_not x', l')) end
  | _ => match list_add f l with (?n, ?l') => constr:((f_var n, l')) end
  end.

Ltac read_formulas x y :=
  match read_formula x (@nil bool) with (?x', ?l) =>
  match read_formula y l with (?y', ?l') => constr:(((x', y'), l'))
  end end.

(** The final reflexive tactic, taking either of the correctness lemmas as argument. *)

Ltac bool_tauto_with f :=
  intros;
  match goal with
  | [ |- ?x = ?y ] =>
    match read_formulas x y with
    | ((?x', ?y'), ?l) =>
      let ln := fresh "l" in
      let xyn := fresh "xy" in
      let nn := fresh "n" in
      let xn := fresh "x" in
      let yn := fresh "y" in
      match vector_of_list l with ?lv => pose (ln := lv) end;
      pose (xyn := close_formulas x' y');
      pose (n := xyn.1); pose (xn := fst xyn.2); pose (yn := snd xyn.2);
      cbv in xyn, n, xn, yn;
      assert (H : eval_formula (Vector.nth ln) xn = eval_formula (Vector.nth ln) yn);
      [ apply f; vm_compute; reflexivity
      | exact H
      ]
    end
  end.

(** Examples *)

Goal forall a b, andb a b = andb b a.
  bool_tauto_with @correctness_heyting.
Qed.
Goal forall a b, andb (negb a) (negb b) = negb (orb a b).
  bool_tauto_with @correctness_heyting.
Qed.
Goal forall a b, orb (negb a) (negb b) = negb (andb a b).
  bool_tauto_with @correctness_heyting.
Qed.

Example neg_involutive: forall a, orb (negb a) a = true.
Fail bool_tauto_with @correctness_heyting.
bool_tauto_with @correctness_classical.
Qed.


Require Import Utf8.
Require Import Cpdt.CpdtTactics.
From Coq Require Import Strings.String.

(* Set Implicit Arguments.  *)

(* Implicit Types V: Set. *)

Inductive inc (V: Set) : Set :=
  | VZ : inc V
  | VS : V -> inc V.

Arguments VZ {V}.
Arguments VS {V}.

Inductive ty : Set :=
  | ty_bool : ty
  | ty_arrow : ty -> ty -> ty
  | ty_top  : ty
  | ty_rcdt : string -> ty -> ty
  | ty_intsct : ty -> ty -> ty.

Inductive Exp (V: Set) : Set :=
  | e_var  : V -> Exp V
  (* functions *)
  | e_abs  : ty -> Exp (inc V) -> Exp V
  | e_app  : Exp V -> Exp V -> Exp V
  (* Boolean *)
  | e_if   : Exp V -> Exp V -> Exp V -> Exp V
  | e_true : Exp V
  | e_false : Exp V
  (* Record, term tagging *)
  | e_top : Exp V
  | e_intsctrcd : Exp V -> string -> Exp V -> Exp V
  | e_prj  : string -> Exp V -> Exp V.

Arguments e_var {V}.
Arguments e_true {V}.
Arguments e_false {V}.
Arguments e_if {V}.
Arguments e_app {V}.
Arguments e_top {V}.
Arguments e_prj {V}.
Arguments e_intsctrcd {V}.
Arguments e_abs {V}.

Notation "∅" := (Empty_set).

Definition empty_fun {T} : ∅ → T :=
  λ y, match y with end.

Notation Exp0 := (Exp Empty_set).

(* Actually allowed mapping of substitution *)
Inductive val {V : Set} : Exp V -> Prop :=
  | v_var  : forall v, val (e_var v)
  | v_true : val (e_true)
  | v_false: val (e_false)
  | v_abs  : forall T body, val (e_abs T body)
  | v_top  : val (e_top)
  | v_intsctrcd : forall name t1 t2, val t1 -> val t2 -> val (e_intsctrcd t1 name t2).

(* Why at this point
I don't think need v_intsct to work on well-formed term
I mean well-formed as no intersection between record and lambda
*)

Notation Val V
  := {e | val (V:= V) e}.

(* Definition Val_as_Exp {V : Set} (v : Val V) : Exp V :=
  match v with
  | exist _ k _ => k
  end. *)

(*
(* Evaluation Context *)
Inductive ECtx (V: Set) : Set :=
  | ec_hole : ECtx V
  | ec_app0 : ECtx V -> Exp V -> ECtx V
  | ec_app1 : Val V -> ECtx V -> ECtx V
  | ec_if0  : ECtx V -> Exp V -> Exp V -> ECtx V
  | ec_rcdt0: string -> ECtx V -> ECtx V
  | ec_intsct0 : ECtx V -> Exp V -> ECtx V
  | ec_intsct1 : Val V -> ECtx V -> ECtx V.

  Arguments ec_hole {V}.
  Arguments ec_app0 {V}.
  Arguments ec_app1 {V}.
  Arguments ec_if0 {V}.
  Arguments ec_rcdt0 {V}.
  Arguments ec_intsct0 {V}.
  Arguments ec_intsct1 {V}. *)

Section EvaluationContext.

Hint Constructors Exp val.

Ltac destruct_ALL :=
    repeat
      match goal with
      | [h : _ \/ _ |- _ ] => destruct h; subst; eauto
      | [h : _ /\ _ |- _ ] => destruct h; subst; eauto
      | [h : exists _ , _ |- _ ] => destruct h; subst; eauto
      | [h : Some _ = Some _ |- _] => inversion h; subst; eauto
      | [h : {_} + {_} |- _] => destruct h; subst; eauto
      end.

Theorem val_dec:
  forall V e,
    {val (V := V) e} + {~ (val (V := V) e)}.
  intros V e.
  Ltac try_both_side :=
    try (left; eauto; fail);
  try (right; intros H;
    inversion H; subst; eauto; fail
  ).
  induction e; eauto;
  try_both_side;
  try destruct_ALL;
  try_both_side.
Qed.
(*
Fixpoint plug_in {V : Set} (e: ECtx V) (t : Exp V) : Exp V :=
    match e with
    | ec_hole => t
    | ec_app0 a b => e_app (plug_in a t) b
    | ec_app1 a b => e_app (proj1_sig a) (plug_in b t)
    | ec_if0 cond br1 br2 => e_if (plug_in cond t) br1 br2
    | ec_rcdt0 s e => e_rcdt s (plug_in e t)
    | ec_intsct0 e0 t1 => e_intsct (plug_in e0 t) t1
    | ec_intsct1 v0 e1 => e_intsct (proj1_sig v0) (plug_in e1 t)
    end.

Theorem ECtx_Fill_In:
  forall V (t : Exp V),
  exists ectx t0,
  t = plug_in ectx t0.

intros V t.
destruct t.
 (* Var  *)
assert (e_var v = plug_in ec_hole (e_var v)); eauto.
assert (e_abs t t0 = plug_in ec_hole (e_abs t t0)); eauto.
Admitted. *)

(* I think I lose the deterministic of step,
    not really lose just hard to prove.
    Unless ECtx V changes to a better definition
    to prove plug_in as injective.
    *)

(* Then it is substitution *)

End EvaluationContext.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(**********************************************************************
     Aux.v

     Auxillary functions & Theorems
  **********************************************************************)
Require Export List.
Require Export Arith.
Require Export Tactic.
Require Import Inverse_Image.
Require Import Wf_nat.

(**************************************
   Some properties on list operators: app, map,...
**************************************)

Section List.
Variables (A : Set) (B : Set) (C : Set).
Variable f : A ->  B.

(**************************************
  An induction theorem for list based on length
**************************************)

Theorem list_length_ind:
 forall (P : list A ->  Prop),
 (forall (l1 : list A),
  (forall (l2 : list A), length l2 < length l1 ->  P l2) ->  P l1) ->
 forall (l : list A),  P l.
intros P H l;
 apply well_founded_ind with ( R := fun (x y : list A) => length x < length y );
 auto.
apply wf_inverse_image with ( R := lt ); auto.
apply lt_wf.
Qed.

Definition list_length_induction:
 forall (P : list A ->  Set),
 (forall (l1 : list A),
  (forall (l2 : list A), length l2 < length l1 ->  P l2) ->  P l1) ->
 forall (l : list A),  P l.
intros P H l;
 apply well_founded_induction
      with ( R := fun (x y : list A) => length x < length y ); auto.
apply wf_inverse_image with ( R := lt ); auto.
apply lt_wf.
Qed.

Theorem in_ex_app:
 forall (a : A) (l : list A),
 In a l ->  (exists l1 : list A , exists l2 : list A , l = l1 ++ (a :: l2)  ).
intros a l; elim l; clear l; simpl; auto.
intros H; case H.
intros a1 l H [H1|H1]; auto.
exists (nil (A:=A)); exists l; simpl; auto.
rewrite H1; auto.
case H; auto; intros l1 [l2 Hl2]; exists (a1 :: l1); exists l2; simpl; auto.
rewrite Hl2; auto.
Qed.

(**************************************
 Properties on app
**************************************)

Theorem length_app:
 forall (l1 l2 : list A),  length (l1 ++ l2) = length l1 + length l2.
intros l1; elim l1; simpl; auto.
Qed.

Theorem app_inv_head:
 forall (l1 l2 l3 : list A), l1 ++ l2 = l1 ++ l3 ->  l2 = l3.
intros l1; elim l1; simpl; auto.
intros a l H l2 l3 H0; apply H; injection H0; auto.
Qed.

Theorem app_inv_tail:
 forall (l1 l2 l3 : list A), l2 ++ l1 = l3 ++ l1 ->  l2 = l3.
intros l1 l2; generalize l1; elim l2; clear l1 l2; simpl; auto.
intros l1 l3; case l3; auto.
intros b l H; absurd (length ((b :: l) ++ l1) <= length l1).
simpl; rewrite length_app; auto with arith.
rewrite <- H; auto with arith.
intros a l H l1 l3; case l3.
simpl; intros H1; absurd (length (a :: (l ++ l1)) <= length l1).
simpl; rewrite length_app; auto with arith.
rewrite H1; auto with arith.
simpl; intros b l0 H0; injection H0.
intros H1 H2; rewrite H2, (H _ _ H1); auto.
Qed.

Theorem app_inv_app:
 forall l1 l2 l3 l4 a,
 l1 ++ l2 = l3 ++ (a :: l4) ->
  (exists l5 : list A , l1 = l3 ++ (a :: l5) ) \/
  (exists l5 , l2 = l5 ++ (a :: l4) ).
intros l1; elim l1; simpl; auto.
intros l2 l3 l4 a H; right; exists l3; auto.
intros a l H l2 l3 l4 a0; case l3; simpl.
intros H0; left; exists l; injection H0; intros; subst; auto.
intros b l0 H0; case (H l2 l0 l4 a0); auto.
injection H0; auto.
intros [l5 H1].
left; exists l5; injection H0; intros; subst; auto.
Qed.

Theorem app_inv_app2:
 forall l1 l2 l3 l4 a b,
 l1 ++ l2 = l3 ++ (a :: (b :: l4)) ->
  (exists l5 : list A , l1 = l3 ++ (a :: (b :: l5)) ) \/
  ((exists l5 , l2 = l5 ++ (a :: (b :: l4)) ) \/
   l1 = l3 ++ (a :: nil) /\ l2 = b :: l4).
intros l1; elim l1; simpl; auto.
intros l2 l3 l4 a b H; right; left; exists l3; auto.
intros a l H l2 l3 l4 a0 b; case l3; simpl.
case l; simpl.
intros H0; right; right; injection H0; split; auto.
rewrite H2; auto.
intros b0 l0 H0; left; exists l0; injection H0; intros; subst; auto.
intros b0 l0 H0; case (H l2 l0 l4 a0 b); auto.
injection H0; auto.
intros [l5 HH1]; left; exists l5; injection H0; intros; subst; auto.
intros [H1|[H1 H2]]; auto.
right; right; split; auto; injection H0; intros; subst; auto.
Qed.

Theorem same_length_ex:
 forall (a : A) l1 l2 l3,
 length (l1 ++ (a :: l2)) = length l3 ->
  (exists l4 ,
   exists l5 ,
   exists b : B ,
   length l1 = length l4 /\ (length l2 = length l5 /\ l3 = l4 ++ (b :: l5))   ).
intros a l1; elim l1; simpl; auto.
intros l2 l3; case l3; simpl; (try (intros; discriminate)).
intros b l H; exists (nil (A:=B)); exists l; exists b; (repeat (split; auto)).
intros a0 l H l2 l3; case l3; simpl; (try (intros; discriminate)).
intros b l0 H0.
case (H l2 l0); auto.
intros l4 [l5 [b1 [HH1 [HH2 HH3]]]].
exists (b :: l4); exists l5; exists b1; (repeat (simpl; split; auto)).
rewrite HH3; auto.
Qed.

(**************************************
  Properties on map
**************************************)

Theorem in_map_inv:
 forall (b : B) (l : list A),
 In b (map f l) ->  (exists a : A , In a l /\ b = f a ).
intros b l; elim l; simpl; auto.
intros tmp; case tmp.
intros a0 l0 H [H1|H1]; auto.
exists a0; auto.
case (H H1); intros a1 [H2 H3]; exists a1; auto.
Qed.

Theorem in_map_fst_inv:
 forall a (l : list (B * C)),
 In a (map (fst (B:=_)) l) ->  (exists c , In (a, c) l ).
intros a l; elim l; simpl; auto.
intros H; case H.
intros a0 l0 H [H0|H0]; auto.
exists (snd a0); left; rewrite <- H0; case a0; simpl; auto.
case H; auto; intros l1 Hl1; exists l1; auto.
Qed.

Theorem length_map: forall l,  length (map f l) = length l.
intros l; elim l; simpl; auto.
Qed.

Theorem map_app: forall l1 l2,  map f (l1 ++ l2) = map f l1 ++ map f l2.
intros l; elim l; simpl; auto.
intros a l0 H l2; rewrite H; auto.
Qed.

Theorem map_length_decompose:
 forall l1 l2 l3 l4,
 length l1 = length l2 ->
 map f (app l1 l3) = app l2 l4 ->  map f l1 = l2 /\ map f l3 = l4.
intros l1; elim l1; simpl; auto; clear l1.
intros l2; case l2; simpl; auto.
intros; discriminate.
intros a l1 Rec l2; case l2; simpl; clear l2; auto.
intros; discriminate.
intros b l2 l3 l4 H1 H2.
injection H2; clear H2; intros H2 H3.
case (Rec l2 l3 l4); auto.
intros H4 H5; split; auto.
subst; auto.
Qed.

(**************************************
  Properties of flat_map
**************************************)

Theorem in_flat_map:
 forall (l : list B) (f : B ->  list C) a b,
 In a (f b) -> In b l ->  In a (flat_map f l).
intros l g; elim l; simpl; auto.
intros a l0 H a0 b H0 [H1|H1]; apply in_or_app; auto.
left; rewrite H1; auto.
right; apply H with ( b := b ); auto.
Qed.

Theorem in_flat_map_ex:
 forall (l : list B) (f : B ->  list C) a,
 In a (flat_map f l) ->  (exists b , In b l /\ In a (f b) ).
intros l g; elim l; simpl; auto.
intros a H; case H.
intros a l0 H a0 H0; case in_app_or with ( 1 := H0 ); simpl; auto.
intros H1; exists a; auto.
intros H1; case H with ( 1 := H1 ).
intros b [H2 H3]; exists b; simpl; auto.
Qed.

(**************************************
  Properties of fold_left
**************************************)

Theorem fold_left_invol:
  forall (f: A -> B -> A) (P: A -> Prop) l a,
  P a ->  (forall x y, P x -> P (f x y)) -> P (fold_left f l a).
intros f1 P l; elim l; simpl; auto.
Qed.

Theorem fold_left_invol_in:
  forall (f: A -> B -> A) (P: A -> Prop) l a b,
  In b l -> (forall x, P (f x b)) -> (forall x y, P x -> P (f x y)) ->
  P (fold_left f l a).
intros f1 P l; elim l; simpl; auto.
intros a1 b HH; case HH.
intros a1 l1 Rec a2 b [V|V] V1 V2; subst; auto.
apply fold_left_invol; auto.
apply Rec with (b := b); auto.
Qed.

End List.

(**************************************
  Propertie of list_prod
**************************************)

Theorem length_list_prod:
 forall (A : Set) (l1 l2 : list A),
  length (list_prod l1 l2) = length l1 * length l2.
intros A l1 l2; elim l1; simpl; auto.
intros a l H; rewrite length_app; rewrite length_map; rewrite H; auto.
Qed.

Theorem in_list_prod_inv:
 forall (A B : Set) a l1 l2,
 In a (list_prod l1 l2) ->
  (exists b : A , exists c : B , a = (b, c) /\ (In b l1 /\ In c l2)  ).
intros A B a l1 l2; elim l1; simpl; auto; clear l1.
intros H; case H.
intros a1 l1 H1 H2.
case in_app_or with ( 1 := H2 ); intros H3; auto.
case in_map_inv with ( 1 := H3 ); intros b1 [Hb1 Hb2]; auto.
exists a1; exists b1; split; auto.
case H1; auto; intros b1 [c1 [Hb1 [Hb2 Hb3]]].
exists b1; exists c1; split; auto.
Qed.


Require Export Coq.Lists.List.
Require Import Coq.Program.Equality.
From Chapter10 Require Export sysf_pat.
Require Import Coq.Program.Tactics.

Ltac inv H := inversion H; try clear H; try subst.

Ltac autorevert x :=
  try (match goal with
    | [y : ?Y |- ?claim] =>
      try (match x with y => idtac end; fail 1);
        match goal with [z : _ |- _] =>
          match claim with context[z] =>
            first
              [ match Y with context[z] => revert y; autorevert x end
              | match y with z => revert y; autorevert x end]
          end
        end
       end).

Definition ctx n := fin n -> ty n.
Definition dctx m n := fin m -> ty n.
Definition empty {X} : fin 0 -> X :=  fun x => match x with end.

Inductive unique {X} : list (nat * X) -> Prop :=
| unil : unique nil
| ucons l x xs : unique xs -> (forall x, ~ In (l, x) xs) ->  unique (cons (l,x) xs).

Hint Constructors unique.

Lemma unique_map {X Y: Type} {f : X -> Y} (xs : list (nat * X)) :
  unique xs -> unique (map (prod_map (fun x => x) f) xs).
Proof.
  intros.
  induction H; cbn; eauto.
  constructor; eauto.
  intros z A. rewrite in_map_iff in A. destruct A as ((?&?)&?&?).
  inv H1. eapply H0; eauto.
Qed.

Lemma unique_spec {X} (xs : list (nat * X)) :
  unique xs -> (forall l x y, In (l, x) xs -> In (l, y) xs -> x = y).
Proof.
  induction 1; intros; cbn in *.
  - contradiction.
  - destruct H1 as [|]; destruct H2 as [|]; try inversion H1; try inversion H2; subst; eauto; firstorder.
Qed.

Lemma in_map {X Y: Type} {f : X -> Y} (xs : list (nat * X)) l x:
  In (l, x) xs -> In (l, f x) (map (prod_map (fun x => x) f) xs).
Proof.
  unfold prod_map.
  induction xs;  cbn; eauto.
  - destruct a; eauto. intros [|]; eauto. inversion H; eauto.
Qed.

Definition label_equiv {X Y} (xs : list (nat * X)) (ys : list (nat * Y)) :=
   (forall i, (exists s, In (i, s) xs) <-> (exists A, In (i, A) ys)).

Lemma label_equiv_map {X X' Y Y': Type} {f : X -> X'} {g : Y -> Y'} (xs : list (nat * X)) (ys : list (nat * Y)) :
  label_equiv xs ys -> label_equiv (map (prod_map (fun x => x) f) xs) (map (prod_map (fun x => x) g) ys).
Proof.
  intros H. intros l.
  unfold prod_map. split; intros (?&?).
  - rewrite in_map_iff in H0. destruct H0 as ((?&?)&?&?). inv H0.
  unfold label_equiv in H. specialize (H l). assert (exists x0, In (l, x0) xs) by eauto.
  apply H in H0. destruct H0 as (?&?). exists (g x). rewrite in_map_iff. exists (l, x). eauto.
- rewrite in_map_iff in H0. destruct H0 as ((?&?)&?&?). inv H0.
  unfold label_equiv in H. specialize (H l). assert (exists x0, In (l, x0) ys) by eauto.
  apply H in H0. destruct H0 as (?&?). exists (f x). rewrite in_map_iff. exists (l, x). eauto.
Qed.

Hint Resolve unique_map label_equiv_map.

Definition update {X} (ts : list (nat * X)) l x : list (nat * X) :=
  map (fun p => if (Nat.eqb (fst p) l) then (l, x) else p) ts.

Lemma unique_update {X} (xs :list (nat * X)) l x :
  unique xs -> unique (update xs l x).
Proof.
  unfold update. intros H.
  induction xs; eauto. inv H. specialize (IHxs H2). cbn.
  destruct (Nat.eqb l0 l) eqn: H; cbn; eauto.
  - constructor; eauto. intros. apply PeanoNat.Nat.eqb_eq in H. subst. intros HH. apply in_map_iff in HH. destruct HH as (?&?&?). destruct x2. cbn in *.  destruct (Nat.eqb n l) eqn: HHH; eauto.
    apply PeanoNat.Nat.eqb_eq in HHH. subst. inv H. eapply H3. eauto. inv H. eapply H3. eauto.
  - constructor; eauto. intros z HH. apply in_map_iff in HH. destruct HH as ((?&?)&?&?). cbn in *.
    destruct (Nat.eqb n l) eqn:HHH; inversion H0; eauto. subst. apply PeanoNat.Nat.eqb_eq in HHH. subst. eapply H3. eauto. subst. eapply H3; eauto.
Qed.

Lemma natequiv_update {X Y} (xs :list (nat * X)) l x (ys: list (nat * Y)):
  label_equiv xs ys -> label_equiv (update xs l x) ys.
Proof.
  enough (label_equiv xs (update xs l x)).
  - intros A i. unfold label_equiv in H, A. now rewrite <- A, H.
  - clear ys. unfold label_equiv. induction xs; cbn; eauto.
    + intros _. split; eauto.
    + destruct a. intros i. cbn. split.
      * intros (?&?). destruct H; eauto.
        -- inv H. destruct (Nat.eqb i l) eqn:HH; eauto. apply PeanoNat.Nat.eqb_eq in HH. subst. eauto. -- assert (exists s, In (i, s) xs) by eauto. apply IHxs in H0. destruct H0 as (?&?). eauto.
      * intros (?&?). destruct H.
        -- destruct (Nat.eqb n l) eqn:HH; eauto. apply PeanoNat.Nat.eqb_eq in HH. subst. inv H. eauto.
        -- assert (exists A, In (i, A) (update xs l x)) by eauto. apply IHxs in H0.
           destruct H0. eauto.
Qed.

Lemma update_char {X} (xs : list (nat * X)) l x i s:
  In (i, s) (update xs l x) -> In (i, s) xs \/ (l = i /\ s = x).
Proof.
  induction xs; eauto. destruct a. cbn.
  destruct (Nat.eqb n l); intros [|]; try inversion H; eauto.
  all: destruct (IHxs H); eauto.
Qed.

Lemma list_dec {X} (P Q : X -> Prop) xs (IH : forall x, In x xs -> P x \/ Q x) :
  (forall x, In x xs -> P x) \/ (exists x, In x xs /\ Q x).
Proof.
  induction xs; cbn; eauto.
  - left. cbn. intros _ [].
  - cbn in IH. assert (forall x, In x xs -> P x \/ Q x) by firstorder.
    destruct (IHxs H) as [|(x&?&?)].
    + assert (P a \/ Q a) as[|] by eauto; cbn; eauto. left. intros z [->|]; cbn; eauto.
    + right. cbn. eauto.
Qed.

Hint Resolve unique_update natequiv_update.

(** POPLMark 1B. *)
Reserved Notation "'SUB' Delta |- A <: B" (at level 68, A at level 99, no associativity).

Inductive sub {n} (Delta : ctx n) : ty n -> ty n -> Prop :=
| SA_top A :
    SUB Delta |- A <: top
| SA_Refl x :
    SUB Delta |- var_ty x <: var_ty x
| SA_Trans x  B :
     SUB Delta |- (Delta x) <: B ->  SUB Delta |- var_ty x <: B
| SA_arrow A1 A2 B1 B2 :
    SUB Delta |- B1 <: A1 -> SUB Delta |- A2 <: B2 ->
    SUB Delta |- arr A1 A2 <: arr B1 B2
| SA_all (A1: ty n) (A2: ty (S n)) B1 B2 :
    SUB Delta |- B1 <: A1 -> @sub (S n) ((B1 .:  Delta) >> ⟨↑⟩) A2 B2 ->
    SUB Delta |- all A1 A2 <: all B1 B2
| SA_rec (xs ys : list (nat * ty n)) : (forall l T', In (l, T') ys -> exists T, In (l, T) xs /\ SUB Delta |- T <: T') ->
                       unique xs -> unique ys -> SUB Delta |- recty xs <: recty ys
where "'SUB' Delta |- A <: B" := (sub Delta A B).

Hint Constructors sub.

Lemma sub_rec :  forall P : forall n : nat, ctx n -> ty n -> ty n -> Prop,
       (forall (n : nat) (Delta : ctx n) (A : ty n), P n Delta A top) ->
       (forall (n : nat) (Delta : ctx n) (x : fin n), P n Delta (var_ty x) (var_ty x)) ->
       (forall (n : nat) (Delta : ctx n) (x : fin n) (B : ty n),
        SUB Delta |- Delta x <: B -> P n Delta (Delta x) B -> P n Delta (var_ty x) B) ->
       (forall (n : nat) (Delta : ctx n) (A1 A2 B1 B2 : ty n),
        SUB Delta |- B1 <: A1 ->
        P n Delta B1 A1 ->
        SUB Delta |- A2 <: B2 -> P n Delta A2 B2 -> P n Delta (arr A1 A2) (arr B1 B2)) ->
       (forall (n : nat) (Delta : ctx n) (A1 : ty n) (A2 : ty (S n)) (B1 : ty n) (B2 : ty (S n)),
        SUB Delta |- B1 <: A1 ->
        P n Delta B1 A1 ->
        SUB (B1 .: Delta) >> ⟨↑⟩ |- A2 <: B2 ->
        P (S n) ((B1 .: Delta) >> ⟨↑⟩) A2 B2 -> P n Delta (all A1 A2) (all B1 B2)) ->
       (forall (n : nat) (Delta : ctx n) (xs ys : list (nat * ty n)),
        (forall (i : nat) (T' : ty n),
         In (i, T') ys -> exists  (T : ty n), In (i, T) xs /\ SUB Delta |- T <: T' /\ P _ Delta T T') ->
        unique xs -> unique ys -> P n Delta (recty xs) (recty ys)) ->
       forall (n : nat) (Delta : ctx n) (t t0 : ty n), SUB Delta |- t <: t0 -> P n Delta t t0.
Proof. intros P. fix IH 11.
  intros. induction H5; try now (clear IH; eauto).
  eapply H4. intros. destruct (H5 _ _ H8) as (T&?&?).
  exists T. repeat split; eauto. all: eauto.
Qed.

Lemma ty_rec
     : forall P : forall nty : nat, ty nty -> Prop,
       (forall (nty : nat) (f : fin nty), P nty (var_ty f)) ->
       (forall nty : nat, P nty top) ->
       (forall (nty : nat) (t : ty nty), P nty t -> forall t0 : ty nty, P nty t0 -> P nty (arr t t0)) ->
       (forall (nty : nat) (t : ty nty),
        P nty t -> forall t0 : ty (S nty), P (S nty) t0 -> P nty (all t t0)) ->
       (forall (nty : nat) (l : list (nat * ty nty)), (forall i t, In (i,t) l -> P _ t) -> P nty (recty l)) ->
       forall (nty : nat) (t : ty nty), P nty t.
Proof.
  intros P. fix IH 7. intros.
  induction t; try now (clear IH; eauto).
  eapply H3. intros. induction l.
  - contradiction.
  - destruct H4 as [|].
    + destruct a. specialize (IH H H0 H1 H2 H3 _ t0). intros. inv H4. apply IH.
    + now apply IHl.
Qed.

Section Pattern.

(** We assume that the subtyping relation is reflexive.
A proof requires a well-formedness condition.*)
Variable sub_refl : forall  n (Delta : ctx n) A, SUB Delta |- A <: A.

Lemma sub_weak m n (Delta1: ctx m) (Delta2: ctx n) A1 A2 A1' A2' (xi: fin m -> fin n) :
  SUB Delta1 |- A1 <: A2 ->
 (forall x, (Delta1 x)⟨xi⟩ = Delta2 (xi x)) ->
  A1' = A1⟨xi⟩ -> A2' = A2⟨xi⟩ ->
  SUB Delta2 |- A1' <: A2' .
Proof.
  intros H. autorevert H. induction H using @sub_rec; intros; subst; asimpl; cbn; econstructor; eauto.
  - eapply IHsub2; try reflexivity.
    auto_case; eauto. rewrite <- H1. now asimpl.
  - intros l T' HH. rewrite in_map_iff in HH. destruct HH as ([]&HH&?).
    inv HH. destruct (H _ _ H3) as (?&?&?&?).
    exists (x⟨xi⟩). split; eauto. apply in_map; eauto.
 Qed.

Lemma sub_weak1 n (Delta : ctx n) A A' B B' C :
  SUB Delta |- A <: B ->  A' = A⟨↑⟩ ->  B' = B⟨↑⟩ -> SUB ((C .: Delta) >> ⟨↑⟩) |- A' <: B'.
Proof. intros. eapply sub_weak;  eauto. intros x. now asimpl. Qed.

Definition transitivity_at {n} (B: ty n) := forall m Gamma (A : ty m) C  (xi: fin n -> fin m),
  SUB Gamma |- A <: B⟨xi⟩ -> SUB Gamma |- B⟨ xi⟩ <: C ->  SUB Gamma |- A <: C.

Lemma transitivity_proj n (Gamma: ctx n) A B C :
  transitivity_at B ->
  SUB Gamma |- A <: B -> SUB Gamma |- B <: C -> SUB Gamma |- A <: C.
Proof. intros H. specialize (H n Gamma A C id).  now asimpl in H. Qed.

Hint Resolve transitivity_proj.

Lemma transitivity_ren m n B (xi: fin m -> fin n) : transitivity_at B -> transitivity_at B⟨xi⟩.
Proof. unfold transitivity_at. intros. eapply H; asimpl in H0; asimpl in H1; eauto. Qed.

Lemma sub_narrow n (Delta Delta': ctx n) A C :
  (forall x, SUB Delta' |- Delta' x <: Delta x) ->
  (forall x, Delta x = Delta' x \/ transitivity_at (Delta x)) ->
  SUB Delta |- A <: C -> SUB Delta' |- A <: C.
Proof with asimpl;eauto.
  intros H H' HH. autorevert HH. induction HH using sub_rec; intros; eauto.
  - destruct (H' x); eauto. rewrite H0 in *. eauto.
  - constructor; eauto.
    eapply IHHH2.
    + auto_case; try apply sub_refl.
      eapply sub_weak; try reflexivity. eapply H. now asimpl.
    + auto_case. destruct (H' f);  eauto using transitivity_ren.
      rewrite H0. now left.
  - econstructor; eauto. intros l T' HH.
    destruct (H _ _ HH) as (T&?&?&?). exists  T.
    split; eauto.
Qed.

Corollary sub_trans' n (B : ty n): transitivity_at B.
Proof with asimpl;eauto.
  unfold transitivity_at.
  autorevert B. induction B using ty_rec; intros...
  - depind H...
  - depind H... depind H0...
  - depind H... depind H1...
  - depind H... depind H1...
    econstructor... clear IHsub0 IHsub3 IHsub1 IHsub2.
    eapply IHB2; eauto.
    + asimpl in *. eapply sub_narrow; try eapply H0.
      * auto_case.
        eapply sub_weak with (xi := ↑); try reflexivity; eauto. now asimpl.
      * intros [x|]; try cbn; eauto. right. apply transitivity_ren. apply transitivity_ren. eauto.
    + asimpl in H1_0. auto.
  - depind H0... depind H3...
    econstructor; eauto. intros.
    destruct (H5 _ _ H6) as (T&?&?). rewrite in_map_iff in H7.
    destruct H7 as ((?&?)&?&?). inv H7.
    edestruct (H2 l0 (t⟨xi⟩)) as (T&?&?).
    + apply in_map_iff. exists (l0, t). eauto.
    + eauto.
Qed.

Corollary sub_trans n (Delta  : ctx n) A B C:
  SUB Delta |- A <: B -> SUB Delta |- B <: C -> SUB Delta |- A <: C.
Proof. eauto using sub_trans'. Qed.

Lemma sub_substitution m m' (sigma : fin m -> ty m') Delta (Delta': ctx m') A B:
   (forall x ,  SUB Delta' |- sigma x <: (Delta x)[sigma] ) ->
   SUB Delta |- A <: B -> SUB Delta' |- subst_ty sigma A <: subst_ty sigma B.
Proof.
    intros eq H. autorevert H. induction H using sub_rec; try now (econstructor; eauto).
  - intros. asimpl. eapply sub_refl.
  - intros. asimpl. eauto. cbn in *. eauto using sub_trans.
  - intros. asimpl. econstructor; eauto.
    asimpl. eapply IHsub2.
    auto_case; asimpl; cbn; eauto using sub_refl.
    eapply sub_weak; try reflexivity. eapply eq.
    all: try now asimpl.
  - intros. asimpl. econstructor; eauto. intros. rewrite in_map_iff in H2. destruct H2 as ((?&?)&?&?).
    inv H2. destruct (H _ _ H3) as (T&?&?&?).
    exists (T[sigma]). split; eauto. apply in_map. eauto.
Qed.

(** POPLMark Challenge 2b *)

Variable pat_ty : forall {m} (p: nat), pat m -> ty m ->  (fin p -> (ty m)) -> Prop.
Variable pat_eval : forall {m n} p, pat m -> tm m n -> (fin p -> (tm m n)) -> Prop.
Variable pat_ty_subst: forall {m n} (sigma: fin m -> ty n) p pt A Gamma, pat_ty m p pt A Gamma -> pat_ty n p (pt[sigma]) (A[sigma]) (Gamma >>  subst_ty sigma).

Inductive value {m n}: tm m n -> Prop :=
| Value_abs A s : value(abs A s)
| Value_tabs A s : value(tabs A s)
| Value_rec xs : (forall i s, In (i, s) xs -> value s) -> value (rectm xs).

Reserved Notation "'TY' Delta ; Gamma |- A : B"
  (at level 68, A at level 99, no associativity,
   format "'TY'  Delta ; Gamma  |-  A  :  B").

Inductive has_ty {m n} (Delta : ctx m) (Gamma : dctx  n m) : tm m n -> ty m -> Prop :=
| T_Var  x :
    TY Delta;Gamma |- var_tm x : Gamma x
  | T_abs (A: ty m) B (s: tm m (S n)):
    @has_ty m (S n) Delta (A .: Gamma) s B   ->
    TY Delta;Gamma |- abs A s : arr A B
| T_app A B s t: TY Delta;Gamma |- s : arr A B  -> TY Delta;Gamma |- t : A -> TY Delta;Gamma |- app s t : B
| T_tabs A B s : @has_ty (S m) n ((A .: Delta) >> ⟨↑⟩) (Gamma >> ⟨↑⟩) s B -> TY Delta;Gamma |- tabs A s : all A B
| T_Tapp A B A' s B' : TY Delta;Gamma |- s : all A B -> SUB Delta |- A' <: A -> B' = B[A'..] ->  TY Delta;Gamma |- tapp s A' : B'
| T_Rcd xs As : unique xs -> unique As -> label_equiv xs As
                -> (forall i A s, In (i, s) xs -> In (i, A) As -> TY Delta; Gamma |- s : A) -> TY Delta;Gamma |- rectm xs : recty As
| T_Proj xs j A As: TY Delta; Gamma |- xs : recty As -> In (j, A) As -> TY Delta; Gamma |- proj xs j : A
| letpat_ty p (pt: pat m) (s : tm m n) (t: tm m (p + n)) A (B : ty m) (Gamma': fin p -> ty m): has_ty Delta Gamma s A -> pat_ty _ p pt A Gamma' -> @has_ty m (p + n) Delta (scons_p p Gamma' Gamma) t B ->  has_ty Delta Gamma (letpat  p pt s t) B
| T_Sub A B s :
    TY Delta;Gamma |- s : A  -> SUB Delta |- A <: B   ->
    TY Delta;Gamma |- s : B
where "'TY' Delta ; Gamma |- s : A" := (has_ty Delta Gamma s A).

Lemma T_Var' {m n} (Delta : ctx m) (Gamma : dctx n m) x :
  forall A, A = Gamma x -> TY Delta;Gamma |- var_tm x : A.
Proof. intros A ->. now econstructor. Qed.

Reserved Notation "'EV' s => t"
  (at level 68, s at level 80, no associativity, format "'EV'  s  =>  t").

Inductive eval {m n} : tm m n -> tm m n -> Prop :=
| E_appabs A s t : EV app (abs A s) t => s[ids; t..]
| E_Tapptabs A s B : EV tapp (tabs A s) B => s[B..; ids]
| E_RecProj  xs j s : In (j, s) xs -> EV (proj (rectm  xs) j) => s
| letpat_eval p (pt : pat m) (s : tm m n) (t : tm m (p + n)) (sigma: fin p -> tm m n) :  pat_eval _ _ p pt s sigma -> eval (letpat  p pt s t) (subst_tm (@var_ty m) (scons_p _ sigma (@var_tm _ _)) t)
| E_appFun s s' t :
     EV s => s' ->
     EV app s t => app s' t
| E_appArg s s' v:
     EV s => s' -> value v ->
     EV app v s => app v s'
| E_TyFun s s' A :
     EV s => s' ->
     EV tapp s A => tapp s' A
| E_Proj s s' j : EV s => s' -> EV (proj s j) => (proj s' j)
| E_Rec l ts t t' : EV t => t' -> In (l,t) ts -> EV (rectm ts) => rectm (update ts l t')                  | E_LetL p pt s s' t : EV s => s' -> EV (letpat p pt s t) => (letpat p pt s'  t)
where "'EV' s => t" := (eval s t).

(** Assumptions of progress and typing on patterns. *)
Variable pat_progress : forall p pt s A Gamma, TY empty; empty |- s : A -> pat_ty _ p pt A Gamma -> exists sigma, pat_eval _ _ p pt s sigma.

(** Progress *)

Lemma can_form_arr {s: tm 0 0} {A B}:
  TY empty;empty |- s : arr A B -> value s -> exists C t, s = abs C t.
Proof.
  intros H.
  depind H; intros; eauto.
  all: try now (try destruct x0;  try inversion H1).
 + inversion H0; subst; eauto. inversion x.
Qed.

Lemma can_form_all {s A B}:
  TY empty;empty |- s : all A B -> value s -> exists C t, s = tabs C t.
Proof.
  intros H.
  depind H; intros; eauto.
  all: try now (try destruct x0; try inversion H1).
  + inv H0; subst.  inversion x.  eauto.
Qed.

Lemma can_form_rectm {s A}:
  TY empty;empty |- s : recty A -> value s -> exists xs, s = rectm xs /\ forall l A', In (l, A') A -> exists s', In (l, s') xs.
Proof.
  intros H.
  depind H; intros; eauto.
   all: try now (try destruct x0; try inversion H1).
  + eexists. split; eauto.
    intros. apply H1; eauto.
  +  inv H0; subst; eauto.
     * inversion x.
     * edestruct IHhas_ty as (?&?&?); eauto.
       subst. exists x; split; eauto. intros.
       edestruct (H3 _ _ H0).
       eapply H2. apply H5.
Qed.

Theorem ev_progress s A:
  TY empty;empty |- s : A -> value s \/ exists t,  EV s => t.
Proof.
  intros. depind H; eauto; try now (left; constructor).
   - inversion x.
   - right. edestruct IHhas_ty1 as [? | [? ?]]; try reflexivity; eauto.
    + edestruct (can_form_arr H H1) as [? [? ?]]; subst.
      eexists. econstructor.
    + eexists. econstructor. eauto.
  - right. edestruct IHhas_ty as [? | [? ?]]; try reflexivity; eauto.
    + edestruct (can_form_all H H1) as [? [? ?]]; subst. eexists. econstructor.
    + eexists. econstructor. eauto.
  - assert ((forall p, In p xs -> value (snd p)) \/ (exists p, In p xs /\ exists s', EV (snd p) => s')) as [|].
    { apply list_dec. intros (?&?) ?. cbn.
      assert (exists A, In (n, A) As) as (A&?). apply H1; eauto.
      eauto. }
    + left. constructor. intros. specialize (H4 (i, s)). eauto.
    + destruct H4 as ((l&s)&?&(s'&?)).
      right. exists (rectm (update xs l s')). econstructor; eauto.

  - right. edestruct IHhas_ty as [? | [? ?]]; eauto.
    + edestruct (can_form_rectm H H1) as [? [? ?]]; try reflexivity. subst.
      rename x into xs.
      enough (exists x, In (j, x) xs) as (?&?).
      * eexists. constructor. eauto.
      * inversion H; eauto.
    + eexists. constructor. eassumption.
  - edestruct (IHhas_ty1 pat_ty_subst pat_progress s0 A0) as [|[? ?]]; eauto.
    + right. edestruct (pat_progress _ _ _ _ _ H H0). eexists. econstructor. eauto.
    + right. eexists. apply E_LetL; eauto.
Qed.

(** Preservation *)

Lemma context_renaming_lemma m m' n n' (Delta: ctx m') (Gamma: dctx n' m')                                                   (s: tm m n) A (xi : fin m -> fin m') (zeta: fin n -> fin n') Delta' (Gamma' : dctx n m):
  (forall x, (Delta' x)⟨xi⟩ = Delta (xi x)) ->
  (forall (x: fin n) , (Gamma' x)⟨xi⟩ =  (Gamma (zeta x))) ->
  TY Delta'; Gamma' |- s : A -> TY Delta; Gamma |- s⟨xi;zeta⟩ : A⟨xi⟩.
Proof.
  intros H H' ty. autorevert ty.
  depind ty; intros; asimpl in *; subst; try now (econstructor; eauto).
  - rewrite H'. constructor.
  - constructor. eapply IHty; eauto.
    auto_case; asimpl.
  - cbn. econstructor. apply IHty; eauto.
    + auto_case; try now asimpl. rewrite <- H. now asimpl.
    + intros. asimpl. rewrite <- H'. now asimpl.
  - cbn. eapply T_Tapp with (A0 := A⟨xi⟩) .
    asimpl in IHty. eapply IHty; eauto.
    eapply sub_weak; eauto. now asimpl.
  - econstructor; eauto.
    + intros.
      eapply in_map_iff in H5. destruct H5 as ([]&?&?). inv H5.
      eapply in_map_iff in H6. destruct H6 as ([j A']&?&?). inv H5.
      eapply H3; eassumption.
  - cbn. econstructor; eauto. now apply in_map.
  - cbn. asimpl. apply letpat_ty  with (A0 := A⟨xi⟩) (Gamma'0 := Gamma' >> ⟨xi⟩); eauto.
    + substify. eauto.
    + asimpl. eapply IHty2; eauto; asimpl.
      * intros z.
        (* adrian: had to add the following line to make it compile.*)
        unfold dctx in Gamma, Gamma0. unfold upRen_p.
        asimpl. f_equal. fext. eauto.
  - econstructor. eauto. eapply sub_weak; eauto.
Qed.

Lemma context_renaming_lemma' m m' n n' (Delta: ctx m') (Gamma: dctx n' m')                                                   (s: tm m n) A (xi : fin m -> fin m') (zeta: fin n -> fin n') Delta' (Gamma' : dctx n m):
  (forall x, (Delta' x)⟨xi⟩ = Delta (xi x)) ->
  (forall (x: fin n) , (Gamma' x)⟨xi⟩ =  (Gamma (zeta x))) ->
  TY Delta'; Gamma' |- s : A -> forall s' A', s' = s⟨xi;zeta⟩ -> A' = A⟨xi⟩ -> TY Delta; Gamma |- s' : A'.
Proof. intros. subst. now eapply context_renaming_lemma. Qed.

Lemma context_morphism_lemma m m' n n' (Delta: ctx m) (Delta': ctx m') (Gamma: dctx n m) (s: tm m n) A (sigma : fin m -> ty m') (tau: fin n -> tm m' n') (Gamma' : dctx n' m'):
  (forall x, SUB Delta' |- sigma x <: (Delta x)[sigma]) ->
  (forall (x: fin n) ,  TY Delta'; Gamma' |- tau x : subst_ty sigma (Gamma x)) ->
  TY Delta; Gamma |- s : A -> TY Delta'; Gamma' |- s[sigma;tau] : A[sigma].
Proof.
   intros eq1 eq2 ty. autorevert ty.
   depind ty; intros; subst; asimpl; try now (econstructor; eauto).
  - constructor. eapply IHty; eauto.
    auto_case; asimpl.
    +  assert (subst_ty sigma (Gamma f)  = ((Gamma f)[sigma]⟨id⟩)) as -> by (now asimpl) .
       eapply context_renaming_lemma; eauto; now asimpl.
    + econstructor.
  - constructor. eapply IHty; eauto.
    + auto_case.
      * asimpl.
        specialize (eq1 f).
        eapply sub_weak1 with (C := A[sigma]) in eq1; eauto.  asimpl in eq1. eapply eq1.
    + intros x. asimpl.
      assert ((Gamma x) [sigma >> ⟨↑⟩] = (Gamma x)[sigma]⟨↑⟩) by (now asimpl).
      auto_unfold in *. rewrite H.
      eapply context_renaming_lemma; try eapply eq2.
      * intros. now asimpl.
      * intros. now asimpl.
  - eapply T_Tapp with (A0 := subst_ty sigma A) .
    asimpl in IHty. eapply IHty; eauto.
    eapply sub_substitution; eauto.
    now asimpl.
  - econstructor; eauto.
    + intros.
      eapply in_map_iff in H5. destruct H5 as ([]&?&?). inv H5.
      eapply in_map_iff in H4. destruct H4 as ([j A']&?&?). inv H4.
      eapply H3; eauto.
  - econstructor; eauto. now apply in_map.
  - econstructor; eauto.
     { eapply IHty2.
      * eauto.
      * intros x.
        destruct (destruct_fin x) as [[x' ->] |[x' ->]]; asimpl; eauto.
        -- eapply T_Var'. now asimpl.
        -- eapply context_renaming_lemma'; try eapply eq2; try now asimpl.
           intros z. now asimpl.  }
  - econstructor.
    + eapply IHty; eauto.
    + eapply sub_substitution; eauto.
Qed.

Lemma ty_inv_abs m n Delta Gamma A A' B C (s: tm m (S n)):
  TY Delta;Gamma |- abs A s : C   ->   SUB Delta |- C <: arr A' B   ->
  (SUB Delta |- A' <: A /\
    exists B', TY Delta; A .: Gamma |- s : B' /\ SUB Delta |- B' <: B).
Proof.
  intros H. depind H; intros.
   - inv H0. split; eauto.
   - edestruct (IHhas_ty pat_ty_subst pat_progress  _ _ _ _ (eq_refl _) (sub_trans _ _ _ _ _ H0 H1)) as (?&?&?&?).
     split.
     + assumption.
     + eauto.
Qed.

Lemma ty_inv_rec {m n} {Delta Gamma A As'} xs  :
  TY Delta;Gamma |- rectm xs: A  ->  SUB Delta |- A <: recty As' ->
   (  (forall (i : nat) (s : tm m n) B',
          In (i, s) xs -> In (i, B') As' ->  exists (B : ty m),  TY Delta;Gamma |- s : B /\ SUB Delta |- B <: B')).
Proof.
  intros H. depind H; intros.
  - inv H4. eauto.
    assert (exists A, In (i, A) As) as [A ?].
    + apply H1. eauto.
    + specialize (H2 _ _ _ H5 H4).
      destruct (H9 _ _ H6) as (?&?&?).
      assert (x = A) as -> by eauto using unique_spec.
      eauto.
  - eauto using sub_trans.
Qed.

Lemma ty_subst m n (Gamma: dctx m n) (Delta: ctx n) Delta' s A:
    (forall x, SUB Delta' |- Delta' x <: Delta x) ->
  TY Delta; Gamma |- s : A -> TY Delta'; Gamma |- s : A.
Proof.
  intros eq H. autorevert H. depind H; eauto; intros; try now (econstructor; eauto).
  - econstructor; eauto. asimpl. eapply IHhas_ty. auto_case; eauto using sub_refl.
    eapply sub_weak; try reflexivity. apply eq. intros x. now asimpl.
  - econstructor; eauto.
    replace A with (A[ids]) by (now asimpl). replace A' with (A'[ids]) by (now asimpl).
    eapply sub_substitution; eauto. intros x.
    asimpl. econstructor. eauto.
 - econstructor; eauto. eapply sub_substitution with (sigma := ids) in H0; eauto.
    asimpl in H0. eapply H0. intros x. econstructor. asimpl. eapply eq.
Qed.

Lemma ty_inv_tabs {m n} {Delta Gamma A A' B C} (s : tm (S m) n):
  TY Delta;Gamma |- tabs A s : C -> SUB Delta |- C <: all A' B   ->
  (SUB Delta |- A' <: A /\ exists B',
   TY (A'.:Delta) >> ren_ty ↑; Gamma >> ren_ty ↑ |- s : B' /\ SUB (A' .: Delta) >> ren_ty ↑ |- B' <: B).
Proof.
  intros H. depind H; intros.
  - inv H0. split; eauto.
    eexists. split; eauto.
    eapply ty_subst; try eapply H.
    auto_case. eapply sub_weak; try reflexivity; eauto.
  - eauto using sub_trans.
Qed.

Variable pat_ty_eval : forall m n p pt s A (Gamma: fin n -> ty m) Gamma' Delta sigma, pat_ty m p pt A Gamma' -> TY Delta; Gamma |- s : A -> pat_eval m n p pt s sigma -> forall (x: fin p), TY Delta; Gamma |- sigma x : Gamma' x.

Theorem preservation m n Delta Gamma (s: tm m n) t A :
  TY Delta;Gamma |- s : A -> EV s => t ->
  TY Delta;Gamma |- t : A.
Proof.
  intros H_ty H_ev. autorevert H_ev.
  induction H_ev; intros; eauto using ty.
  all: try now (depind H_ty; [econstructor; eauto|eapply T_Sub; eauto]).
  - depind H_ty; [|eauto].
    + inv H_ty1; subst.
      * replace B with (B[ids]) by (now asimpl).
        eapply context_morphism_lemma; eauto.
        -- intros. asimpl. repeat constructor. now apply sub_refl.
        -- intros [|]; intros; cbn; asimpl;  eauto. econstructor; eauto.
      * pose proof (ty_inv_abs _ _ _ _ _ _ _ _ _ H H0) as (?&?&?&?).
        eapply T_Sub; eauto.
        replace x with (x[var_ty]) by (now asimpl).
        eapply context_morphism_lemma; eauto.
        -- intros. asimpl. repeat constructor. apply sub_refl.
        -- intros [|]; intros; cbn; asimpl; eauto; econstructor; eauto.
     + asimpl. econstructor; eauto.
  - depind H_ty; eauto.
    + depind H_ty.
      * asimpl in H_ty.
        eapply context_morphism_lemma; try eapply H_ty; eauto.
        -- auto_case; asimpl; eauto using sub_refl.
        -- intros x. asimpl. constructor.
      * pose proof (ty_inv_tabs _ H_ty H) as (?&?&?&?).
        eapply T_Sub.  asimpl in *.
        eapply context_morphism_lemma; eauto.
        -- auto_case; asimpl; eauto.
        -- intros z. asimpl. constructor.
        -- eapply sub_substitution; eauto.
           auto_case; asimpl.
    + econstructor; eauto.
  -  depind H_ty; eauto.
    + depind H_ty.
      * eapply H2; eauto.
      * pose proof (ty_inv_rec _ H_ty H  _ _ _ H1 H0) as(?&?&?).
        subst. eapply T_Sub; eauto.
    + econstructor; eauto.
  - depind H_ty.
    + replace B with (B[ids]) by now asimpl.
      eapply context_morphism_lemma; try now apply H_ty2.
      * intros. asimpl. constructor. now apply sub_refl.
      * intros. destruct (destruct_fin x) as [[]|[]]; subst.
        -- asimpl. eapply pat_ty_eval; eauto.
        -- asimpl. constructor.
    + eapply T_Sub; eauto.
  - depind H_ty; [|eapply T_Sub; eauto].
    econstructor; eauto.
    + intros.
      apply update_char in H5 as [|(->&->)]; eauto.
Qed.

End Pattern.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Export Coq.MSets.MSetInterface.
Require Import Coq.MSets.MSetFacts.
Require Import Coq.MSets.MSetProperties.
Require Import Fiat.Common.Wf.
Require Import Fiat.Common.LogicFacts.
Require Import Fiat.Common.Instances.
Require Import Fiat.Common.NatFacts.
Require Import Fiat.Common.MSetExtensions.
Require Import Fiat.Common.

Module MSetBoundedLatticeOn (E: OrderedType) (Import M: SetsOn E).
  Module Import BasicFacts := WFactsOn E M.
  Module Import BasicProperties := WPropertiesOn E M.
  Module Import BasicExtensions := MSetExtensionsOn E M.

  Definition lift_ltb (x y : t) : bool
    := ((subset x y) && negb (equal x y)).

  Global Instance eq_flip_impl_flip_impl_impl_Prper
    : Proper (Logic.eq ==> flip impl ==> flip impl) impl.
  Proof. compute; intros; subst; tauto. Qed.

  Global Instance lift_ltb_Transitive : Transitive lift_ltb.
  Proof.
    unfold lift_ltb.
    intros x y z.
    setoid_rewrite andb_true_iff.
    destruct (equal x z) eqn:H;
      revert H;
      setoid_rewrite negb_true_iff;
      setoid_rewrite <- not_true_iff_false;
      to_caps;
      setoid_subst_rel Equal;
      intros; destruct_head and;
        simplify_sets;
        unfold not in *;
        specialize_by reflexivity;
        try tauto.
    split; try congruence.
    etransitivity; eassumption.
  Qed.

  Lemma not_equal_ex
        x y (H : ~Equal x y)
    : exists a, (In a x \/ In a y) /\ (In a x -> In a y -> False).
  Proof.
    revert dependent y.
    induction x as [|xs xs' IHxs v] using set_induction.
    { intro y.
      unfold Empty, Equal in *.
      setoid_rewrite (False_iff (H _)).
      destruct (choose y) as [v|] eqn:Hch.
      { setoid_rewrite_logic.
        apply choose_spec1 in Hch.
        eauto. }
      { apply choose_spec2 in Hch.
        unfold Equal, Empty in *.
        setoid_rewrite (False_iff (Hch _)).
        setoid_rewrite_logic.
        tauto. } }
    { intro y.
      let H := match goal with H : Add _ _ _ |- _ => H end in
      apply Add_Equal in H.
      setoid_subst xs'.
      setoid_rewrite add_spec.
      destruct (In_dec v y) as [pf|pf]; [ | exists v ].
      { intro Hneq.
        specialize (IHxs (remove v y)).
        setoid_rewrite remove_spec in IHxs.
        destruct IHxs as [a IHxs]; [ | exists a ].
        { intro Heq'; apply Hneq; clear Hneq.
          setoid_subst xs.
          rewrite add_remove by assumption.
          reflexivity. }
        { lazymatch type of IHxs with
          | context[E.eq ?x ?y]
            => assert (~E.eq x y) by (intro; rename x into x'; setoid_subst x'; firstorder auto with crelations)
          end.
          destruct_head and.
          destruct_head or; [ solve [ split; eauto ] | ].
          destruct_head and.
          let H := match goal with H : _ -> _ /\ _ -> _ |- _ => H end in
          specialize (fun a b c => H c (conj a b)).
          specialize_by assumption.
          split; eauto; [].
          firstorder. } }
      { assert (E.eq v v) by reflexivity.
        eauto. } }
  Qed.

  Definition well_founded_lift_ltb : well_founded lift_ltb.
  Proof.
    eapply well_founded_subrelation;
      [ | eexact (Wf_nat.well_founded_ltof _ cardinal) ].
    unfold Wf_nat.ltof, lift_ltb.
    intros x y H.
    apply andb_true_iff in H.
    destruct H as [H0 H1].
    apply subset_spec in H0.
    apply negb_true_iff, not_true_iff_false in H1.
    setoid_rewrite equal_spec in H1.
    destruct (not_equal_ex H1) as [a [[H2|H2] H3]];
      eapply subset_cardinal_lt; [ assumption | solve [ eauto ].. ].
  Qed.

  Section rel.
    Context (max : t).

    Definition lift_ltb_with_max (x y : t) : bool
      := ((subset x y)
            && (subset y max)
            && negb (equal x y)).

    Global Instance subrelation_lift_gtb
      : subrelation (fun x y : t => lift_ltb_with_max y x)
                    (fun a b : t => cardinal max - cardinal a < cardinal max - cardinal b).
    Proof.
      intros x y H.
      repeat setoid_rewrite andb_true_iff in H.
      destruct H as [[H0 H1] H2].
      apply subset_spec in H0.
      apply subset_spec in H1.
      apply negb_true_iff, not_true_iff_false in H2.
      setoid_rewrite equal_spec in H2.
      pose proof (subset_cardinal H0) as H0'.
      pose proof (subset_cardinal H1) as H1'.
      destruct (not_equal_ex H2) as [a [H3 H4]].
      pose proof (subset_cardinal_lt (x := a) H0).
      destruct H3 as [H3|H3].
      { intuition. }
      { intuition omega. }
    Qed.

    Definition well_founded_lift_gtb_with_max : well_founded (Basics.flip lift_ltb_with_max).
    Proof.
      eapply well_founded_subrelation;
        [ | eexact (Wf_nat.well_founded_ltof _ (fun x => cardinal max - cardinal x)) ].
      apply subrelation_lift_gtb.
    Defined.
  End rel.
End MSetBoundedLatticeOn.

Module MSetBoundedLattice (M: S) := MSetBoundedLatticeOn M.E M.


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

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

Print Assumptions freeze.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Cat.Cat Cat.Terminal.
From Categories Require Import Limits.Limit.
From Categories Require Import KanExt.LocalFacts.From_Iso_Cat.
From Categories Require Import Cat.Cat_Iso.

(** Given I : C ≃ D for C and D categories we have limit of (F ∘ I)
    if we have limit of F. *)
Section Limit_From_Isomorphic_Cat.
Context {C D : Category}
        (I : (C ≃≃ D ::> Cat)%isomorphism)
        {E : Category}
        {F : (D --> E)%functor}
        (L : Limit F).

Definition Limit_From_Isomorphic_Cat : Limit (F ∘ (iso_morphism I)) :=
  Local_Right_KanExt_Iso_along
    (
      Functor_To_1_Cat_Iso
        (Functor_To_1_Cat C)
        (Functor_To_1_Cat D ∘ (iso_morphism I))
    )
    (KanExt_From_Isomorphic_Cat I (Functor_To_1_Cat D) F L).

End Limit_From_Isomorphic_Cat.

(** Given I : C ≃ D for C and D categories we have colimit of (F ∘ I)
    if we have colimit of F. *)
Section CoLimit_From_Isomorphic_Cat.
Context {C D : Category}
        (I : (C ≃≃ D ::> Cat)%isomorphism)
        {E : Category}
        {F : (D --> E)%functor}
        (L : CoLimit F).

Definition CoLimit_From_Isomorphic_Cat : CoLimit (F ∘ (iso_morphism I)) :=
  Limit_From_Isomorphic_Cat (Opposite_Cat_Iso I) L.

End CoLimit_From_Isomorphic_Cat.


Require Export P06.

Lemma is_redblack_toblack:
  forall s n, is_redblack s Red n -> is_redblack s Black n.
Proof. exact FILL_IN_HERE. Qed.