From Hammer Require Import Hammer.

Require Import Bool.
Require Import Sumbool.
Require Import NArith.
Require Import Ndigits.
Require Import Ndec.
From IntMap Require Import Map.

Section Dom.

Variables A B : Type.

Fixpoint MapDomRestrTo (m:Map A) : Map B -> Map A :=
match m with
| M0 => fun _:Map B => M0 A
| M1 a y =>
fun m':Map B => match MapGet B m' a with
| None => M0 A
| _ => m
end
| M2 m1 m2 =>
fun m':Map B =>
match m' with
| M0 => M0 A
| M1 a' y' =>
match MapGet A m a' with
| None => M0 A
| Some y => M1 A a' y
end
| M2 m'1 m'2 =>
makeM2 A (MapDomRestrTo m1 m'1) (MapDomRestrTo m2 m'2)
end
end.

Lemma MapDomRestrTo_semantics :
forall (m:Map A) (m':Map B),
eqm A (MapGet A (MapDomRestrTo m m'))
(fun a0:ad =>
match MapGet B m' a0 with
| None => None
| _ => MapGet A m a0
end).
Proof. hammer_hook "Fset" "Fset.MapDomRestrTo_semantics".
unfold eqm in |- *. simple induction m. simpl in |- *. intros. case (MapGet B m' a); trivial.
intros. simpl in |- *. elim (sumbool_of_bool (N.eqb a a1)). intro H. rewrite H.
rewrite <- (Neqb_complete _ _ H). case (MapGet B m' a); try reflexivity.
intro. apply M1_semantics_1.
intro H. rewrite H. case (MapGet B m' a).
case (MapGet B m' a1); intros; exact (M1_semantics_2 A a a1 a0 H).
case (MapGet B m' a1); reflexivity.
simple induction m'. trivial.
unfold MapDomRestrTo in |- *. intros. elim (sumbool_of_bool (N.eqb a a1)).
intro H1.
rewrite (Neqb_complete _ _ H1). rewrite (M1_semantics_1 B a1 a0).
case (MapGet A (M2 A m0 m1) a1); try reflexivity.
intro. apply M1_semantics_1.
intro H1. rewrite (M1_semantics_2 B a a1 a0 H1). case (MapGet A (M2 A m0 m1) a); try reflexivity.
intro. exact (M1_semantics_2 A a a1 a2 H1).
intros. change
(MapGet A (makeM2 A (MapDomRestrTo m0 m2) (MapDomRestrTo m1 m3)) a =
match MapGet B (M2 B m2 m3) a with
| None => None
| Some _ => MapGet A (M2 A m0 m1) a
end) in |- *.
rewrite (makeM2_M2 A (MapDomRestrTo m0 m2) (MapDomRestrTo m1 m3) a).
rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (N.div2 a)). rewrite (H m2 (N.div2 a)).
rewrite (MapGet_M2_bit_0_if B m2 m3 a). rewrite (MapGet_M2_bit_0_if A m0 m1 a).
case (Nbit0 a); reflexivity.
Qed.

Fixpoint MapDomRestrBy (m:Map A) : Map B -> Map A :=
match m with
| M0 => fun _:Map B => M0 A
| M1 a y =>
fun m':Map B => match MapGet B m' a with
| None => m
| _ => M0 A
end
| M2 m1 m2 =>
fun m':Map B =>
match m' with
| M0 => m
| M1 a' y' => MapRemove A m a'
| M2 m'1 m'2 =>
makeM2 A (MapDomRestrBy m1 m'1) (MapDomRestrBy m2 m'2)
end
end.

Lemma MapDomRestrBy_semantics :
forall (m:Map A) (m':Map B),
eqm A (MapGet A (MapDomRestrBy m m'))
(fun a0:ad =>
match MapGet B m' a0 with
| None => MapGet A m a0
| _ => None
end).
Proof. hammer_hook "Fset" "Fset.MapDomRestrBy_semantics".
unfold eqm in |- *. simple induction m. simpl in |- *. intros. case (MapGet B m' a); trivial.
intros. simpl in |- *. elim (sumbool_of_bool (N.eqb a a1)). intro H. rewrite H.
rewrite (Neqb_complete _ _ H). case (MapGet B m' a1). trivial.
apply M1_semantics_1.
intro H. rewrite H. case (MapGet B m' a).
case (MapGet B m' a1); trivial.
rewrite (M1_semantics_2 A a a1 a0 H).
case (MapGet B m' a1); trivial.
simple induction m'. trivial.
unfold MapDomRestrBy in |- *. intros. rewrite (MapRemove_semantics A (M2 A m0 m1) a a1).
elim (sumbool_of_bool (N.eqb a a1)). intro H1. rewrite H1. rewrite (Neqb_complete _ _ H1).
rewrite (M1_semantics_1 B a1 a0). reflexivity.
intro H1. rewrite H1. rewrite (M1_semantics_2 B a a1 a0 H1). reflexivity.
intros. change
(MapGet A (makeM2 A (MapDomRestrBy m0 m2) (MapDomRestrBy m1 m3)) a =
match MapGet B (M2 B m2 m3) a with
| None => MapGet A (M2 A m0 m1) a
| Some _ => None
end) in |- *.
rewrite (makeM2_M2 A (MapDomRestrBy m0 m2) (MapDomRestrBy m1 m3) a).
rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (N.div2 a)). rewrite (H m2 (N.div2 a)).
rewrite (MapGet_M2_bit_0_if B m2 m3 a). rewrite (MapGet_M2_bit_0_if A m0 m1 a).
case (Nbit0 a); reflexivity.
Qed.

Definition in_dom (a:ad) (m:Map A) :=
match MapGet A m a with
| None => false
| _ => true
end.

Lemma in_dom_M0 : forall a:ad, in_dom a (M0 A) = false.
Proof. hammer_hook "Fset" "Fset.in_dom_M0".
trivial.
Qed.

Lemma in_dom_M1 : forall (a a0:ad) (y:A), in_dom a0 (M1 A a y) = N.eqb a a0.
Proof. hammer_hook "Fset" "Fset.in_dom_M1".
unfold in_dom in |- *. intros. simpl in |- *. case (N.eqb a a0); reflexivity.
Qed.

Lemma in_dom_M1_1 : forall (a:ad) (y:A), in_dom a (M1 A a y) = true.
Proof. hammer_hook "Fset" "Fset.in_dom_M1_1".
intros. rewrite in_dom_M1. apply Neqb_correct.
Qed.

Lemma in_dom_M1_2 :
forall (a a0:ad) (y:A), in_dom a0 (M1 A a y) = true -> a = a0.
Proof. hammer_hook "Fset" "Fset.in_dom_M1_2".
intros. apply (Neqb_complete a a0). rewrite (in_dom_M1 a a0 y) in H. assumption.
Qed.

Lemma in_dom_some :
forall (m:Map A) (a:ad),
in_dom a m = true -> {y : A | MapGet A m a = Some y}.
Proof. hammer_hook "Fset" "Fset.in_dom_some".
unfold in_dom in |- *. intros. elim (option_sum _ (MapGet A m a)). trivial.
intro H0. rewrite H0 in H. discriminate H.
Qed.

Lemma in_dom_none :
forall (m:Map A) (a:ad), in_dom a m = false -> MapGet A m a = None.
Proof. hammer_hook "Fset" "Fset.in_dom_none".
unfold in_dom in |- *. intros. elim (option_sum _ (MapGet A m a)). intro H0. elim H0.
intros y H1. rewrite H1 in H. discriminate H.
trivial.
Qed.

Lemma in_dom_put :
forall (m:Map A) (a0:ad) (y0:A) (a:ad),
in_dom a (MapPut A m a0 y0) = orb (N.eqb a a0) (in_dom a m).
Proof. hammer_hook "Fset" "Fset.in_dom_put".
unfold in_dom in |- *. intros. rewrite (MapPut_semantics A m a0 y0 a).
elim (sumbool_of_bool (N.eqb a a0)). intro H. rewrite H. rewrite (Neqb_comm a a0) in H.
rewrite H. rewrite orb_true_b. reflexivity.
intro H. rewrite H. rewrite (Neqb_comm a a0) in H. rewrite H. rewrite orb_false_b.
reflexivity.
Qed.

Lemma in_dom_put_behind :
forall (m:Map A) (a0:ad) (y0:A) (a:ad),
in_dom a (MapPut_behind A m a0 y0) = orb (N.eqb a a0) (in_dom a m).
Proof. hammer_hook "Fset" "Fset.in_dom_put_behind".
unfold in_dom in |- *. intros. rewrite (MapPut_behind_semantics A m a0 y0 a).
elim (sumbool_of_bool (N.eqb a a0)). intro H. rewrite H. rewrite (Neqb_comm a a0) in H.
rewrite H. case (MapGet A m a); reflexivity.
intro H. rewrite H. rewrite (Neqb_comm a a0) in H. rewrite H. case (MapGet A m a); trivial.
Qed.

Lemma in_dom_remove :
forall (m:Map A) (a0 a:ad),
in_dom a (MapRemove A m a0) = andb (negb (N.eqb a a0)) (in_dom a m).
Proof. hammer_hook "Fset" "Fset.in_dom_remove".
unfold in_dom in |- *. intros. rewrite (MapRemove_semantics A m a0 a).
elim (sumbool_of_bool (N.eqb a a0)). intro H. rewrite H. rewrite (Neqb_comm a a0) in H.
rewrite H. reflexivity.
intro H. rewrite H. rewrite (Neqb_comm a a0) in H. rewrite H.
case (MapGet A m a); reflexivity.
Qed.

Lemma in_dom_merge :
forall (m m':Map A) (a:ad),
in_dom a (MapMerge A m m') = orb (in_dom a m) (in_dom a m').
Proof. hammer_hook "Fset" "Fset.in_dom_merge".
unfold in_dom in |- *. intros. rewrite (MapMerge_semantics A m m' a).
elim (option_sum A (MapGet A m' a)). intro H. elim H. intros y H0. rewrite H0.
case (MapGet A m a); reflexivity.
intro H. rewrite H. rewrite orb_b_false. reflexivity.
Qed.

Lemma in_dom_delta :
forall (m m':Map A) (a:ad),
in_dom a (MapDelta A m m') = xorb (in_dom a m) (in_dom a m').
Proof. hammer_hook "Fset" "Fset.in_dom_delta".
unfold in_dom in |- *. intros. rewrite (MapDelta_semantics A m m' a).
elim (option_sum A (MapGet A m' a)). intro H. elim H. intros y H0. rewrite H0.
case (MapGet A m a); reflexivity.
intro H. rewrite H. case (MapGet A m a); reflexivity.
Qed.

End Dom.

Section InDom.

Variables A B : Type.

Lemma in_dom_restrto :
forall (m:Map A) (m':Map B) (a:ad),
in_dom A a (MapDomRestrTo A B m m') =
andb (in_dom A a m) (in_dom B a m').
Proof. hammer_hook "Fset" "Fset.in_dom_restrto".
unfold in_dom in |- *. intros. rewrite (MapDomRestrTo_semantics A B m m' a).
elim (option_sum B (MapGet B m' a)). intro H. elim H. intros y H0. rewrite H0.
rewrite andb_b_true. reflexivity.
intro H. rewrite H. rewrite andb_b_false. reflexivity.
Qed.

Lemma in_dom_restrby :
forall (m:Map A) (m':Map B) (a:ad),
in_dom A a (MapDomRestrBy A B m m') =
andb (in_dom A a m) (negb (in_dom B a m')).
Proof. hammer_hook "Fset" "Fset.in_dom_restrby".
unfold in_dom in |- *. intros. rewrite (MapDomRestrBy_semantics A B m m' a).
elim (option_sum B (MapGet B m' a)). intro H. elim H. intros y H0. rewrite H0.
unfold negb in |- *. rewrite andb_b_false. reflexivity.
intro H. rewrite H. unfold negb in |- *. rewrite andb_b_true. reflexivity.
Qed.

End InDom.

Definition FSet := Map unit.

Section FSetDefs.

Variable A : Type.

Definition in_FSet : ad -> FSet -> bool := in_dom unit.

Fixpoint MapDom (m:Map A) : FSet :=
match m with
| M0 => M0 unit
| M1 a _ => M1 unit a tt
| M2 m m' => M2 unit (MapDom m) (MapDom m')
end.

Lemma MapDom_semantics_1 :
forall (m:Map A) (a:ad) (y:A),
MapGet A m a = Some y -> in_FSet a (MapDom m) = true.
Proof. hammer_hook "Fset" "Fset.MapDom_semantics_1".
simple induction m. intros. discriminate H.
unfold MapDom in |- *. unfold in_FSet in |- *. unfold in_dom in |- *. unfold MapGet in |- *. intros a y a0 y0.
case (N.eqb a a0). trivial.
intro. discriminate H.
intros m0 H m1 H0 a y. rewrite (MapGet_M2_bit_0_if A m0 m1 a). simpl in |- *. unfold in_FSet in |- *.
unfold in_dom in |- *. rewrite (MapGet_M2_bit_0_if unit (MapDom m0) (MapDom m1) a).
case (Nbit0 a). unfold in_FSet, in_dom in H0. intro. apply H0 with (y := y). assumption.
unfold in_FSet, in_dom in H. intro. apply H with (y := y). assumption.
Qed.

Lemma MapDom_semantics_2 :
forall (m:Map A) (a:ad),
in_FSet a (MapDom m) = true -> {y : A | MapGet A m a = Some y}.
Proof. hammer_hook "Fset" "Fset.MapDom_semantics_2".
simple induction m. intros. discriminate H.
unfold MapDom in |- *. unfold in_FSet in |- *. unfold in_dom in |- *. unfold MapGet in |- *. intros a y a0. case (N.eqb a a0).
intro. split with y. reflexivity.
intro. discriminate H.
intros m0 H m1 H0 a. rewrite (MapGet_M2_bit_0_if A m0 m1 a). simpl in |- *. unfold in_FSet in |- *.
unfold in_dom in |- *. rewrite (MapGet_M2_bit_0_if unit (MapDom m0) (MapDom m1) a).
case (Nbit0 a). unfold in_FSet, in_dom in H0. intro. apply H0. assumption.
unfold in_FSet, in_dom in H. intro. apply H. assumption.
Qed.

Lemma MapDom_semantics_3 :
forall (m:Map A) (a:ad),
MapGet A m a = None -> in_FSet a (MapDom m) = false.
Proof. hammer_hook "Fset" "Fset.MapDom_semantics_3".
intros. elim (sumbool_of_bool (in_FSet a (MapDom m))). intro H0.
elim (MapDom_semantics_2 m a H0). intros y H1. rewrite H in H1. discriminate H1.
trivial.
Qed.

Lemma MapDom_semantics_4 :
forall (m:Map A) (a:ad),
in_FSet a (MapDom m) = false -> MapGet A m a = None.
Proof. hammer_hook "Fset" "Fset.MapDom_semantics_4".
intros. elim (option_sum A (MapGet A m a)). intro H0. elim H0. intros y H1.
rewrite (MapDom_semantics_1 m a y H1) in H. discriminate H.
trivial.
Qed.

Lemma MapDom_Dom :
forall (m:Map A) (a:ad), in_dom A a m = in_FSet a (MapDom m).
Proof. hammer_hook "Fset" "Fset.MapDom_Dom".
intros. elim (sumbool_of_bool (in_FSet a (MapDom m))). intro H.
elim (MapDom_semantics_2 m a H). intros y H0. rewrite H. unfold in_dom in |- *. rewrite H0.
reflexivity.
intro H. rewrite H. unfold in_dom in |- *. rewrite (MapDom_semantics_4 m a H). reflexivity.
Qed.

Definition FSetUnion (s s':FSet) : FSet := MapMerge unit s s'.

Lemma in_FSet_union :
forall (s s':FSet) (a:ad),
in_FSet a (FSetUnion s s') = orb (in_FSet a s) (in_FSet a s').
Proof. hammer_hook "Fset" "Fset.in_FSet_union".
exact (in_dom_merge unit).
Qed.

Definition FSetInter (s s':FSet) : FSet := MapDomRestrTo unit unit s s'.

Lemma in_FSet_inter :
forall (s s':FSet) (a:ad),
in_FSet a (FSetInter s s') = andb (in_FSet a s) (in_FSet a s').
Proof. hammer_hook "Fset" "Fset.in_FSet_inter".
exact (in_dom_restrto unit unit).
Qed.

Definition FSetDiff (s s':FSet) : FSet := MapDomRestrBy unit unit s s'.

Lemma in_FSet_diff :
forall (s s':FSet) (a:ad),
in_FSet a (FSetDiff s s') = andb (in_FSet a s) (negb (in_FSet a s')).
Proof. hammer_hook "Fset" "Fset.in_FSet_diff".
exact (in_dom_restrby unit unit).
Qed.

Definition FSetDelta (s s':FSet) : FSet := MapDelta unit s s'.

Lemma in_FSet_delta :
forall (s s':FSet) (a:ad),
in_FSet a (FSetDelta s s') = xorb (in_FSet a s) (in_FSet a s').
Proof. hammer_hook "Fset" "Fset.in_FSet_delta".
exact (in_dom_delta unit).
Qed.

End FSetDefs.

Lemma FSet_Dom : forall s:FSet, MapDom unit s = s.
Proof. hammer_hook "Fset" "Fset.FSet_Dom".
simple induction s. trivial.
simpl in |- *. intros a t. elim t. reflexivity.
intros. simpl in |- *. rewrite H. rewrite H0. reflexivity.
Qed.


Module FeatureModel.

Require Export form name.

Import Name Form.
Require Export Coq.Lists.ListSet.

Definition features : Type := set Name.
Definition formulae : Type := set Formula.

Definition FM : Type := features * formulae.

Definition names_ (fm : FM) : features := fst fm.
Definition formulas (fm : FM) : formulae := snd fm.

Definition  wfTree (fm: FM): Prop := True.

End FeatureModel.


Set Implicit Arguments.

Require Import
        Ascii
        String
        List.

Definition name : Set := string.

Definition eq_name_dec := string_dec.

Class Nameable (A : Type) : Type
  :={
      name_of : A -> name
    }.

Definition names {A : Type}`{Nameable A} (v : list A) : list name :=
  map name_of v.


(*|
#######################################################
Display the original name of the imported module in Coq
#######################################################

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

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

How to choose the textual representation of variables which belongs to
some module? (Please see commentaries inside the code below. It's like
Notation for modules.) I want to use it because it's preferable to see
the original meaning of the terms. (and separate different types with
the same realization: ``SetVars.t``, ``FuncSymb.t``, ``PredSymb.t``,
etc)
|*)

Require Import Coq.Structures.Equalities.
Require Import Arith.PeanoNat.

Module mod1 (SetVars : UsualDecidableTypeFull).
  Definition h : SetVars.t -> SetVars.t := fun x => x. (*example*)
End mod1.

Module mod2.
  Module SetVars := PeanoNat.Nat.
  Module X := mod1 SetVars.
  Import X.

  Theorem q : SetVars.t -> SetVars.t.
  Proof. exact h. Defined. (* Here everything is OK *)

  Check h. (*"h : nat -> nat"*)
  (*But I want to see "h : SetVars.t -> SetVars.t" *)
End mod2.

(*|
Answer
******

Replace

.. code-block:: coq

    Module SetVars := PeanoNat.Nat.

with

.. code-block:: coq

    Module SetVars : UsualDecidableTypeFull := PeanoNat.Nat.

This makes the module ``SetVars`` opaque, exposing exactly the
signature ``UsualDecidableTypeFull``, so that the type ``SetVars.t ->
SetVars.t`` can no longer be reduced.
|*)


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

(*  Pierre Casteran
    LaBRI, Université Bordeaux 1, and Inria Futurs (Logical)
*)

Set Asymmetric Patterns.
Unset Standard Proposition Elimination Names.

Require Import Arith.
Require Import Omega.
Require Import Relations.

Record item :Set := quad {
                    base: nat ;
                    coeff2 :nat ; (* coefficient of b² *)
                    coeff1 :nat ; (* coefficient of b *)
                    coeff0 :nat    (* coefficient of b° *) }.

(* relation between two consecutive items of the sequence *)

Inductive Rg: item -> item ->Prop :=
 Rg0 : forall b i j k, Rg (quad b i j (S k)) (quad  (S b) i j k)
|Rg1 : forall b i j , Rg (quad b i (S j) 0) (quad (S b) i j b)
|Rg2 : forall b i  , Rg (quad b (S i) 0 0)  (quad (S b) i b b).

Hint Constructors Rg.

Definition Rgstar := clos_refl_trans _ Rg.

Definition reachable (q:item) := Rgstar (quad 3 2 2 2) q.

(* We want to prove the following result :

Theorem G4_length : reachable
                    (quad
                      (3 * 2 ^ (3 * 2 ^ (3 ^3) + 3 ^3) - 1)
                      0
                      0
                      0).

*)

(* Let us introduce some concepts *)

Hint Unfold reachable.

Hint Constructors clos_refl_trans.

Lemma reachable_Rgstar : forall q q', reachable q ->
                                      Rgstar q q' ->
                                      reachable q'.
Proof.
 intros q q' H H0.
 unfold reachable; constructor 3 with q;auto.
Qed.

Inductive final : item -> Prop :=
 final_intro :forall b , final (quad b 0 0 0).

Hint Constructors final.

Lemma final_no_future : forall q, final q -> forall q', ~ Rg q q'.
Proof.
 red;intros q Hq ; elim Hq.
 inversion 1.
Qed.

(* First, we want to explore interactively the reachable items *)

Definition next (q:item) : {q' : item | Rg q q'} + {final q}.
 case q ; intros b x y z.
 case z.
  case y.
   case x;auto.
   intro x';left;exists (quad (S b) x' b b);auto.
   intros y';left;exists (quad (S b) x y' b);auto.
   intros z'; left; exists (quad (S b) x y z');auto.
Defined.

Fixpoint nexts (n:nat)(q:item){struct n} : option item :=
  match n with 0 => Some q
             | S p => (match (next q)
                       with  | inleft (exist q' _) =>  nexts p q'
                             | inright  _ => None

                                         end)
  end.

Lemma next_unicity : forall q q' q'',
      Rg q q' -> Rg q q'' -> q' = q''.
Proof.
 destruct 1; inversion_clear 1;auto.
Qed.

Lemma nexts_plus : forall n p q , nexts (n+p) q = match (nexts n q)
                                                 with Some q' => nexts p q' |
                                                      None => None end.
 induction n;simpl.
 auto.
 intros; case (next q).
 intro s; case s;auto.
 auto.
Qed.

Lemma nexts_ok : forall n q q', nexts n q  = Some q' ->
                                Rgstar q q'.
Proof.
 induction n; simpl; auto.
 injection 1; destruct 1;constructor 2.
 intros q q'; case (next  q).
 destruct s.
 intro.
 constructor 3 with x;auto.
 apply IHn;auto.
 discriminate 2.
Qed.

Lemma nexts_ok_R : forall q q', Rgstar q q' ->
                              exists n, nexts n q  = Some q'.
Proof.
 intros.
 elim H.
 exists 1.
 simpl.
 case (next x).
 intro s.
 case s.
 intros x0 H1.  rewrite (next_unicity _ _ _ H1 H0).
 trivial.
 intros.
 case (final_no_future _ f _ H0).
 exists 0.
 simpl;trivial.
 intros.
 case H1;case H3;intros.
 exists (x1 + x0).
 rewrite nexts_plus;auto.

 rewrite H5.
 auto.
Qed.

Definition nth_item n := nexts n (quad 3 2 2 2).

(* let us look for regularities *)

Eval compute in nth_item 0.
(*  = Some (quad 3 2 2 2)
     : option item
*)

Eval compute in nth_item 2.

(*
    = Some (quad 5 2 2 0)
     : option item
*)

Eval compute in nth_item 3.

(*
    = Some (quad 6 2 1 5)
     : option item
*)

Eval compute in nth_item 8.
(*     = Some (quad 11 2 1 0)
     : option item
*)

Eval compute in nth_item 20.
(*
     = Some (quad 23 2 0 0)
     : option item
*)

Eval compute in nth_item 21.

(*
 = Some (quad 24 1 23 23)
     : option item
*)
Eval compute in nth_item 44.
(*
  = Some (quad 47 1 23 0)
     : option item
*)
Eval compute in nth_item 92.

(*
= Some (quad 95 1 22 0)
     : option item
*)

Eval compute in nth_item 188.

(*
    = Some (quad 191 1 21 0)
     : option item
*)

(* Eureka : 11 = 3 * 2 ^ 2 - 1
            23 = 3 * 2 ^ 3 - 1
            47 = 3 * 2 ^ 4 - 1
            95 = 3 * 2 ^ 5 - 1
           191 = 3 * 2 ^ 6 - 1
*)

(* let us define the function f n = 3 * 2 ^ n - 1 *)

Fixpoint power (b:nat)(n:nat){struct n}:nat :=
 match n with 0 => 1
            | S p => b * b ^ p
 end
where  "n ^ p" := (power n p):nat_scope.

Definition f n := pred (3 * 2^n).

Lemma f_Sn : forall n,  f (S n) = S (2*(f n)).
 induction n;simpl.
 compute.
 auto.
 unfold f;simpl.
 unfold f at 1 in IHn.
 simpl in IHn.

 omega.
Qed.

(* we start a sequence of reachability lemmas, until we reach
  a final item of the sequence *)

(* A first generalization of the previous examples *)

Lemma L1 :  forall k i j b,
      Rgstar (quad b i j (S k)) (quad (S k + b) i j 0).
Proof.
 induction k.
 simpl.
 constructor 1;auto.
 simpl.
 econstructor 3.
 econstructor 1; eauto.
 simpl in IHk.
 replace (S (S (k+b))) with (S (k + (S b))).
 apply IHk.
 auto with arith.
Qed.

Lemma L2 :  forall k i j b,
      Rgstar (quad b i j k) (quad (k + b) i j 0).
 intro k; case k;intros.
 simpl;constructor 2.
 apply L1.
Qed.

(* hmmm, let us look at items of the form (base,i,j,0)  *)

Lemma L3 : forall b i j,
    Rgstar (quad b i (S j) 0) (quad (S (2 * b)) i j 0).
Proof.
 intros.
 case b.
 simpl.
 econstructor 1.
 constructor.
 econstructor 3.
 econstructor 1; econstructor.
 replace (S (2* S n)) with ( S n  + S (S n)).
 apply L1.
 omega.
Qed.

Lemma L4 :  forall b i j,
                   reachable (quad (f b) i (S j) 0) ->
                   reachable (quad (f (S b)) i j 0).
Proof.
 intros.
 econstructor 3.
 unfold reachable in H.
 eexact H.
 rewrite f_Sn.
 apply L3.
Qed.

Lemma L5 :  forall k b i j,
          reachable (quad (f b) i (k+j) 0) ->
          reachable (quad (f (k+b)) i j 0).
Proof.
 induction k.
 simpl.
 auto.
 intros; econstructor 3.
 unfold reachable in IHk; eapply IHk.
 replace (S k + j) with (k + (S j)) in H.
 unfold reachable in H;eauto.
 omega.
 simpl;rewrite f_Sn.
 apply L3.
Qed.

Lemma F1 : reachable (quad (f 1) 2 2 0).
Proof.
 compute.
 replace 5 with (2+3).
 apply L1.
 simpl;trivial.
Qed.

Lemma F2 : reachable (quad (f 2) 2 1 0).
Proof.
 apply L4.
 apply F1.
Qed.

Lemma F3 : reachable (quad (f 3) 2 0 0).
Proof.
 compute.
 apply nexts_ok with 20.
 trivial.
Qed.

(* Ah, ah : the second component of the current tuple becomes 1 *)

Lemma SF3 : reachable (quad (S (f 3)) 1 (f 3) (f 3)).
Proof.
 eapply reachable_Rgstar.
 eexact F3.
 constructor 1.
 constructor.
Qed.

Lemma F4 : reachable (quad (f 4) 1 (f 3) 0).
Proof.
 rewrite (f_Sn 3).
 eapply reachable_Rgstar.
 eexact SF3.
 replace (S (2 * (f 3))) with (f 3 + (S ( f 3))).
 apply L2.
 compute.
 trivial.
Qed.

Lemma F27 :  reachable (quad (f 27) 1 0 0).
Proof.
 replace 27 with (f 3 + 4).
 apply L5.
 rewrite <- plus_n_O ; apply F4.
 trivial.
Qed.

(* Ok, the second component becomes 0 *)

Lemma SF27 : reachable (quad (S (f 27)) 0 (f 27) (f 27)).
Proof.
 eapply reachable_Rgstar.
 eexact F27.
 constructor 1.
 constructor.
Qed.

Lemma F28 : reachable (quad (f 28) 0 (f 27) 0).
Proof.
 rewrite f_Sn.
 replace (S (2 * f 27)) with (f 27 + (S (f 27))).
 2:omega.
 eapply reachable_Rgstar.
 eexact SF27.
 apply L2.
Qed.

(* yep! we are finished ! *)

Lemma Final : reachable (quad (f (f 27 + 28)) 0 0 0).
Proof.
 apply L5.
 rewrite <- plus_n_O.
 apply F28.
Qed.

(* f (f 27 + 28) = f (402653211) =  3 * 2 ^ 402653211 - 1  =

               3
             (3  )       3
       (3 x 2        + 3   )
  3 x 2                       -1
*)

Lemma big_number_eq : f (f 27 + 28) =
          3 * 2 ^ (3 * 2 ^ (3 ^3) + 3 ^3) - 1.
Proof.
 unfold f.
 rewrite <- pred_of_minus.
 replace 27 with (3^3).
 generalize (3^3).
 intro n; assert (0 < 2 ^ n).
 induction n.
 simpl;auto with arith.
 simpl.
 auto with arith.
 generalize H ; generalize (2 ^n).
 intros.
 replace (pred (3*n0) + S n) with (3*n0 + n).
 auto.
 omega.
 simpl;trivial.
Qed.

Theorem G4_length : reachable
                    (quad
                      (3 * 2 ^ (3 * 2 ^ (3 ^3) + 3 ^3) - 1)
                      0
                      0
                      0).
Proof.
(* Opaque power.
 rewrite big_number_eq. *)
 generalize big_number_eq.
 generalize (3 * 2 ^ (3 * 2 ^ 3 ^ 3 + 3 ^ 3) - 1).
 generalize Final.
 generalize (f (f 27 + 28)).
 induction 2.
 auto.
Qed.

Require Import ZArith.

Open Scope Z_scope.
Definition f_Z n := 3*(Zpower 2 n)-1.

Eval compute in  (f_Z 27 + 28).

(*
   = 402653211
     : Z
*)


(***************************************************************************
* Generic Environments                                                     *
*                                                                          *
* Emmanuel Polonowski, April 2011, Coq v8.3                                *
*                                                                          *
* (Inspired by the work of A. Chargueraud :                                *
*  http://www.chargueraud.org/softs/ln/index.php)                          *
***************************************************************************)

Require Import Utf8.
Set Implicit Arguments.

(* ********************************************************************** *)
(** * Module of the extension of an implementation of environments        *)

Require Import Equalities.
Require Import CoreGenericEnv.
Require List.
Require Sets.Image.

Module GenericEnvironmentType (VarType : UsualDecidableType)
  (CoreGE : CoreGenericEnvironmentType (VarType)).

Import List.

Import VarType CoreGE.
Definition eq_var_dec := VarType.eq_dec.

Local Open Scope gen_env_scope.

Section ExtendedDefinitions.

Variable A : Type.

(** Asserts the binding of a variable in an environment. *)
Definition binds (x : TVar) (v : A) (E : gen_env A) := get x E = Some v.

(** Asserts the inclusion of an environment in another. *)
Definition all_binds (E F : gen_env A) :=
  forall x v, binds x v E -> binds x v F.

(** Equivalence between environments *)
Definition eq (E F : gen_env A) := all_binds E F ∧ all_binds F E.

End ExtendedDefinitions.

(** [x '∹' v '⋲' E] to be read x is bound to v in E. *)

Notation "x '∹' v '⋲' E" := (binds x v E)
  (at level 65) : gen_env_scope.

(** [E '⊏' F] to be read F all_binds E, i.e. E is included in F. *)

Notation "E '⊏' F" := (all_binds E F)
  (at level 65) : gen_env_scope.

(** [E '≍' F] to be read F is equivalent to E, i.e. E binds as F. *)

Notation "E '≍' F" := (eq E F)
  (at level 68) : gen_env_scope.

Bind Scope gen_env_scope with gen_env.
Delimit Scope gen_env_scope with gen_env.
Local Open Scope gen_env_scope.

(* ---------------------------------------------------------------------- *)
(** ** Properties *)

Section Properties.
Implicit Types x y : TVar.
Implicit Types xs ys : list TVar.

(* ---------------------------------------------------------------------- *)
(** **** Abstract properties of ok *)

(** Ok and dom *)
Theorem ok_dom : forall A (E : gen_env A),
  List.NoDup (dom E) -> ok E.
Proof.
  induction E using env_ind; intro H_NoDup.
  apply ok_empty.
  rewrite dom_concat in H_NoDup. rewrite dom_single in H_NoDup.
  simpl in H_NoDup. inversion H_NoDup.
  apply ok_cons; split; auto. apply notin_dom_inv; auto.
Qed.

Theorem ok_dom_inv : forall A (E : gen_env A),
  ok E -> List.NoDup (dom E).
Proof.
  induction E using env_ind; intro Hok.
  rewrite dom_empty. apply List.NoDup_nil.
  apply ok_concat_inv in Hok.
  destruct Hok as [ HokE Hok ] ; destruct Hok as [ Hokx Hdoms ].
  destruct Hdoms as [ Hdom1 Hdom2 ].
  rewrite dom_concat. rewrite dom_single in *. simpl.
  apply List.NoDup_cons; auto.
  apply all_notin_notin in Hdom2. destruct Hdom2. apply notin_dom; auto.
Qed.

(** Ok is equivalent to the non-duplication of the domain. *)
Theorem ok_NoDup_dom_eq : forall A (E : gen_env A),
  ok E <-> List.NoDup (dom E).
Proof.
  intro E; split; [ apply ok_dom_inv | apply ok_dom ]; auto.
Qed.

(* ---------------------------------------------------------------------- *)
(** **** Properties of binds *)

(** Binds and empty. *)
Theorem binds_empty : forall A x (v : A),
  x ∹ v ⋲ (@empty A) ->
  False.
Proof.
  intros A x v Hbind. inversion Hbind as [ Hget ].
  rewrite get_empty in Hget. inversion Hget.
Qed.

(** Binds on singular(s). *)
Theorem binds_single : forall A x y (v w : A),
  x = y -> v = w ->
  x ∹ v ⋲ (y ∶ w).
Proof.
  intros A x y v w Heq1 Heq2. rewrite Heq1, Heq2.
  unfold binds. rewrite get_single_eq; auto.
Qed.

Theorem binds_single_inv : forall A x y (v w: A),
  x ∹ v ⋲ (y ∶ w) ->
  x = y ∧ v = w.
Proof.
  intros A x y v w Hbind. inversion Hbind as [ Hget ].
  destruct (eq_var_dec x y) as [ Heq | Hneq ].
  rewrite Heq in *; clear x Heq.
  rewrite get_single_eq in Hget; auto. inversion Hget; auto.
  apply get_single_eq_inv in Hget. destruct Hget; contradiction.
Qed.

Theorem binds_singles : forall A x y (v w : A) ys (ws : list A),
  x = y -> v = w ->
  x ∹ v ⋲ (y :: ys ∷ w :: ws).
Proof.
  intros A x y v w ys ws Heq1 Heq2. rewrite Heq1, Heq2.
  unfold binds. rewrite singles_cons. apply get_concat_r; auto.
Qed.

Theorem binds_singles_inv : forall A x y (v w : A) ys (ws : list A),
  x ∹ v ⋲ (y :: ys ∷ w :: ws) ->
  (x = y ∧ v = w) ∨ (x ∹ v ⋲ (ys ∷ ws)).
Proof.
  intros A x y v w ys ws Hbind. inversion Hbind as [ Hget ].
  rewrite singles_cons in Hget.
  apply get_concat_inv in Hget. destruct Hget as [ Heq | Hneq ].
  left. destruct Heq; split; auto.
  right. destruct Hneq. auto.
Qed.

(** Binds is functional. *)
Theorem binds_eq_inv : forall A x (v w : A) (E : gen_env A),
  x ∹ v ⋲ E -> x ∹ w ⋲ E ->
  v = w.
Proof.
  intros A x v w E Hbind1 Hbind2.
  inversion Hbind1 as [ Hget1 ]. inversion Hbind2 as [ Hget2 ].
  rewrite Hget1 in Hget2. inversion Hget2; auto.
Qed.

(** Binds and concatenation. *)
Theorem binds_concat_r : forall A x (v : A) (F G : gen_env A),
  x ∹ v ⋲ G ->
  x ∹ v ⋲ (F & G).
Proof.
  intros A x v F G Hbind. induction G as [ | G y w IHG ] using env_ind.
  apply binds_empty in Hbind. inversion Hbind.
  destruct (eq_keys_dec x y) as [ Heq | Hneq ].
  rewrite <- Heq in *; clear y Heq.
  unfold binds in *. apply get_concat_inv in Hbind.
  destruct Hbind as [ [ _ Heq ] | [ Hneq Hbind ] ].
  rewrite Heq in *. rewrite concat_assoc. apply get_concat_r; auto.
  elim Hneq; auto.
  unfold binds in *. rewrite concat_assoc.
  apply get_concat_inv in Hbind.
  destruct Hbind as [ [ Heq _ ] | [ _ Hget ] ]. contradiction.
  apply IHG in Hget.
  assert (get x (F & G & y ∶ w) = get x (F & G)) as Heq.
  apply get_concat_l; auto. rewrite Heq; auto.
Qed.

Theorem binds_concat_l : forall A x (v : A) (F G : gen_env A),
  x ∹ v ⋲ F ->
  x ∉ G ->
  x ∹ v ⋲ (F & G).
Proof.
  intros A x v F G Hbind Hnotin.
  induction G as [ | G y w IHG ] using env_ind.
  rewrite concat_empty_r; auto.
  apply notin_concat_inv in Hnotin. destruct Hnotin as [ HnotinG Hnotin_y ].
  apply IHG in HnotinG. apply notin_single_inv in Hnotin_y.
  unfold binds in *. rewrite concat_assoc.
  assert (get x (F & G & y ∶ w) = get x (F & G)) as Heq.
  apply get_concat_l; auto. rewrite Heq; auto.
Qed.

Theorem binds_concat_inv : forall A x (v : A) (F G : gen_env A),
  x ∹ v ⋲ (F & G) ->
  x ∹ v ⋲ G ∨ (x ∉ G ∧ x ∹ v ⋲ F).
Proof.
  induction G as [ | G y w IHG ] using env_ind; intro Hbind.
  rewrite concat_empty_r in *.
  right; split; [ apply notin_empty | ]; auto.

  unfold binds in *. rewrite concat_assoc in *.
  apply get_concat_inv in Hbind.
  destruct Hbind as [ [ Heq_xy Heq_wv ] | [ Hneq_xy Hget ] ].

  subst. left. apply get_concat_r; auto.

  apply IHG in Hget. destruct Hget as [ Hget | [ Hnotin Hget ] ].
  left.
  assert (get x (G & y ∶ w) = get x G) as Heq.
  apply get_concat_l; auto. rewrite Heq; auto.

  right. split; auto. apply notin_concat; auto. apply notin_single; auto.
Qed.

(** Binds and belongs. *)
Theorem binds_belongs : forall A x (v : A) (F : gen_env A),
  x ∹ v ⋲ F ->
  x ∈ F.
Proof.
  induction F using env_ind; intro Hbind.
  apply binds_empty in Hbind; inversion Hbind.
  apply binds_concat_inv in Hbind.
  destruct Hbind as [ Hbind | [ Hnotin Hbind ] ].

  apply belongs_concat_r. unfold binds in Hbind.
  apply get_single_eq_inv in Hbind. destruct Hbind.
  apply belongs_single; auto.

  apply IHF in Hbind. apply belongs_concat_l; auto.
Qed.

Theorem belongs_binds : forall A x (F : gen_env A),
  x ∈ F ->
  exists v, x ∹ v ⋲ F.
Proof.
  induction F as [ | F y w IHF ] using env_ind; intro Hbelong.
  apply belongs_empty in Hbelong. inversion Hbelong.

  destruct (eq_keys_dec x y) as [ Heq | Hneq ]. subst.
  exists w. apply binds_concat_r. apply binds_single; auto.

  apply belongs_concat_inv in Hbelong. destruct Hbelong as [ HinF | Hiny ].
  apply IHF in HinF. destruct HinF as [ w' Hbind ]. exists w'.
  apply binds_concat_l; auto. apply notin_single; auto.
  apply belongs_single_inv in Hiny. contradiction.
Qed.

(** Binds and map. *)
Theorem binds_map : forall A B x (v : A) (E : gen_env A) (f : A -> B),
  x ∹ v ⋲ E ->
  x ∹ (f v) ⋲ (map f E).
Proof.
  intros A B x v E f Hbind. induction E as [ | E y w IHE ] using env_ind.
  apply binds_empty in Hbind; inversion Hbind.

  rewrite map_concat, map_single.
  apply binds_concat_inv in Hbind.
  destruct Hbind as [ Hbind | [ Hnotin Hbind ] ].
  apply binds_single_inv in Hbind. destruct Hbind; subst.
  apply binds_concat_r. apply binds_single; auto.

  apply binds_concat_l; auto. apply notin_single.
  apply notin_single_inv in Hnotin; auto.
Qed.

Theorem binds_map_inv : forall A B x (w : B) (E : gen_env A) (f : A -> B),
  x ∹ w ⋲ (map f E) ->
  exists v, x ∹ v ⋲ E /\ w = f v.
Proof.
  intros A B x w E f Hbind. induction E as [ | E y u IHE ] using env_ind.
  rewrite map_empty in Hbind. apply binds_empty in Hbind. inversion Hbind.

  rewrite map_concat, map_single in Hbind. apply binds_concat_inv in Hbind.
  destruct Hbind as [ Hbind | [ Hnotin Hbind ] ].
  apply binds_single_inv in Hbind. destruct Hbind; subst.
  exists u. split; auto. apply binds_concat_r. apply binds_single; auto.

  apply IHE in Hbind. destruct Hbind as [ w' [ Hbind Heq ] ].
  exists w'. split; auto. apply binds_concat_l; auto.
  apply notin_single_inv in Hnotin. apply notin_single; auto.
Qed.

(** Binds and update_one. *)
Theorem binds_update_one_neq : forall A x y (v w : A) (F : gen_env A),
  x ∹ v ⋲ F ->
  x <> y ->
  x ∹ v ⋲ (F [y <- w]).
Proof.
  intros A x y v w F Hbind Hneq.
  induction F as [ | F z u ] using env_ind.
  apply binds_empty in Hbind. inversion Hbind.

  apply binds_concat_inv in Hbind. destruct Hbind as [ Hbind_r | Hbind_l ].
  apply binds_single_inv in Hbind_r. destruct Hbind_r as [ Heq1 Heq2 ].
  rewrite <- Heq1, <- Heq2 in *; clear z u Heq1 Heq2.
  rewrite update_one_concat_l.
  apply binds_concat_r. apply binds_single; auto.
  apply notin_single; auto.

  destruct Hbind_l as [ Hnotin Hbind ].
  destruct (eq_var_dec y z) as [ Heqz | Hneqz ].
  rewrite <- Heqz in *; clear z Heqz.
  rewrite update_one_concat_r. rewrite update_one_single; auto.
  apply binds_concat_l; auto. apply notin_single; auto.
  apply belongs_single; auto.

  rewrite update_one_concat_l; [ | apply notin_single; auto ].
  apply binds_concat_l; auto.
Qed.

Theorem binds_update_one_eq : forall A x y (v w : A) (F : gen_env A),
  x ∈ F ->
  x = y -> v = w ->
  x ∹ v ⋲ (F [y <- w]).
Proof.
  intros A x y v w F Hbelongs Heq_xy Heq_vw.
  rewrite <- Heq_xy, <- Heq_vw in *; clear y w Heq_xy Heq_vw.
  induction F as [ | F z u ] using env_ind.
  apply belongs_empty in Hbelongs. inversion Hbelongs.

  destruct (eq_var_dec x z) as [ Heq | Hneq ].
  rewrite <- Heq in *; clear z Heq.
  rewrite update_one_concat_r; [ | apply belongs_single; auto ].
  rewrite update_one_single; auto.
  apply binds_concat_r. apply binds_single; auto.

  apply belongs_concat_inv in Hbelongs. destruct Hbelongs as [ HinF | Hinz].
  rewrite update_one_concat_l; [ | apply notin_single; auto ].
  apply binds_concat_l; [ | apply notin_single; auto ]; auto.

  apply belongs_single_inv in Hinz. contradiction.
Qed.

Theorem binds_update_one_inv : forall A x y (v w : A) (F : gen_env A),
  x ∹ v ⋲ (F [y <- w]) ->
  (x <> y ∧ x ∹ v ⋲ F) ∨ (x ∈ F ∧ x = y ∧ v = w).
Proof.
  intros A x y v w F Hbind.
  induction F as [ | F z u IHF ] using env_ind.

  rewrite update_one_empty in Hbind. apply binds_empty in Hbind.
  inversion Hbind.

  destruct (eq_var_dec y z) as [ Heqz | Hneqz ];
    destruct (eq_var_dec x y) as [ Heqy | Hneqy ]; subst.

  Focus.
  rewrite update_one_concat_r in Hbind; [ | apply belongs_single; auto ].
  rewrite update_one_single in Hbind; auto.
  apply binds_concat_inv in Hbind.
  destruct Hbind as [ Hin | Hnotin ].
  apply binds_single_inv in Hin. destruct Hin; subst.
  right. split; auto. apply belongs_concat_r. apply belongs_single; auto.
  destruct Hnotin as [ Hnotin _ ]. apply notin_single_inv in Hnotin.
  elim Hnotin; auto.

  Focus.
  rewrite update_one_concat_r in Hbind; [ | apply belongs_single; auto ].
  rewrite update_one_single in Hbind; auto.
  apply binds_concat_inv in Hbind.
  destruct Hbind as [ Hin | Hnotin ].
  apply binds_single_inv in Hin. destruct Hin; contradiction.
  left. split; auto.
  apply binds_concat_l. destruct Hnotin; auto.
  apply notin_single; auto.

  Focus.
  rewrite update_one_concat_l in Hbind; [ | apply notin_single; auto ].
  apply binds_concat_inv in Hbind.
  destruct Hbind as [ Hin | Hnotin ].
  apply binds_single_inv in Hin. destruct Hin; contradiction.
  destruct Hnotin as [ Hnotin Hbind ]. apply IHF in Hbind.
  destruct Hbind as [ Hneq | Heq ]. destruct Hneq as [ Hneq _ ].
  elim Hneq; auto. destruct Heq as [ HinF Heqs ]. destruct Heqs.
  right. split; auto. apply belongs_concat_l; auto.

  destruct (eq_var_dec x z) as [ Heq | Hneq ]; subst.
  rewrite update_one_concat_l in Hbind; [ | apply notin_single; auto ].
  apply binds_concat_inv in Hbind.
  destruct Hbind as [ Hin | Hnotin ].
  apply binds_single_inv in Hin. destruct Hin; subst.
  left. split; auto. apply binds_concat_r.
  apply binds_single; auto. destruct Hnotin as [ Hnotin _ ].
  apply notin_single_inv in Hnotin. elim Hnotin; auto.
  rewrite update_one_concat_l in Hbind; [ | apply notin_single; auto ].
  apply binds_concat_inv in Hbind.
  destruct Hbind as [ Hin | Hnotin ].
  apply binds_single_inv in Hin. destruct Hin; contradiction.
  destruct Hnotin as [ Hnotin Hbind ]. apply IHF in Hbind.
  destruct Hbind as [ Hneq2 | Heq ];
    [ | destruct Heq as [ _ Heq ]; destruct Heq; contradiction ].
  destruct Hneq2. left. split; auto.
  apply binds_concat_l; [ | apply notin_single; auto ]; auto.
Qed.

(** Binds and update. *)
Theorem binds_update_notin : forall A x (v : A) (F G : gen_env A),
  x ∹ v ⋲ F ->
  x ∉ G ->
  x ∹ v ⋲ (F ::= G).
Proof.
  intros A x v F G Hbind Hnotin.
  induction G as [ | G y w ] using env_ind.

  rewrite update_empty_r; auto.

  rewrite update_concat_r. rewrite update_update_one.
  apply notin_concat_inv in Hnotin. destruct Hnotin as [ HnotinG Hneq ].
  apply notin_single_inv in Hneq. apply binds_update_one_neq; auto.
Qed.

Theorem binds_update_in : forall A x (v : A) (F G : gen_env A),
  x ∈ F ->
  x ∹ v ⋲ G ->
  x ∹ v ⋲ (F ::= G).
Proof.
  intros A x v F G Hin Hbind.
  induction G as [ | G y w ] using env_ind.
  apply binds_empty in Hbind. inversion Hbind.
  apply binds_concat_inv in Hbind. destruct Hbind as [ Hbind | Hnotin ].
  apply binds_single_inv in Hbind. destruct Hbind; subst.
  apply (belongs_update G) in Hin.
  rewrite update_concat_r. rewrite update_update_one.
  apply binds_update_one_eq; auto.

  destruct Hnotin as [ Hnotin Hbind ]. apply notin_single_inv in Hnotin.
  rewrite update_concat_r. rewrite update_update_one.
  apply binds_update_one_neq; auto.
Qed.

Theorem binds_update_self : forall A x (v : A) (F : gen_env A),
  x ∈ F ->
  x ∹ v ⋲ (F ::= (x ∶ v)).
Proof.
  intros A x v F Hin.
  rewrite update_update_one. apply binds_update_one_eq; auto.
Qed.

Theorem binds_update_inv : forall A x (v : A) (F G : gen_env A),
  x ∹ v ⋲ (F ::= G) ->
  (x ∉ G ∧ x ∹ v ⋲ F) ∨ (x ∈ F ∧ x ∹ v ⋲ G).
Proof.
  intros A x v F G Hbind.
  induction G as [ | G y w IHG ] using env_ind.

  rewrite update_empty_r in Hbind. left; split; auto.
  apply notin_empty.

  rewrite update_concat_r in Hbind. rewrite update_update_one in Hbind.
  apply binds_update_one_inv in Hbind.
  destruct Hbind as [ Hneq | Heq ].

  destruct Hneq as [ Hneq Hbind].
  apply IHG in Hbind.
  destruct Hbind as [ HbindF | HbindG ].
  destruct HbindF as [ Hnotin Hbind ].
  left; split; auto. apply notin_concat; auto. apply notin_single; auto.

  destruct HbindG as [ HinF Hbind ].
  right; split; auto. apply binds_concat_l; auto. apply notin_single; auto.

  destruct Heq as [ Hin [ Heq1 Heq2 ] ]; subst.
  right. split. apply belongs_update_inv with G; auto.
  apply binds_concat_r. apply binds_single; auto.
Qed.

(** Binds and remove. *)
Theorem binds_remove : forall A x y (v : A) (E : gen_env A),
  x <> y -> x ∹ v ⋲ E ->
  x ∹ v ⋲ (E ∖ {y}).
Proof.
  intros A x y v E Hneq Hbind.
  induction E as [ | E z w IHE ] using env_ind.
  apply binds_empty in Hbind. inversion Hbind.

  apply binds_concat_inv in Hbind.
  destruct Hbind as [ Hbind | [ Hnotin Hbind ] ].

  destruct (eq_keys_dec y z) as [ Heq | Hneq_yz ]. subst.
  apply binds_single_inv in Hbind. destruct Hbind. contradiction.

  rewrite remove_belongs_concat_l.
  apply binds_concat_r; auto. apply notin_single; auto.

  apply notin_single_inv in Hnotin.
  destruct (eq_keys_dec y z); subst.
  rewrite remove_belongs_concat_r. rewrite remove_single_eq; auto.
  rewrite concat_empty_r; auto. apply belongs_single; auto.

  rewrite remove_belongs_concat_l.
  apply binds_concat_l; auto. apply notin_single; auto.
  apply notin_single; auto.
Qed.

Theorem binds_remove_inv : forall A x y (v : A) (E : gen_env A),
  x <> y -> x ∹ v ⋲ (E ∖ {y}) ->
  x ∹ v ⋲ E.
Proof.
  intros A x y v E Hneq Hbind.
  induction E as [ | E z w IHE ] using env_ind.
  rewrite remove_empty in Hbind.
  apply binds_empty in Hbind. inversion Hbind.

  destruct (eq_keys_dec y z); subst.
  rewrite remove_belongs_concat_r in Hbind.
  rewrite remove_single_eq in Hbind; auto. rewrite concat_empty_r in Hbind.
  apply binds_concat_l; auto. apply notin_single; auto.
  apply belongs_single; auto.

  destruct (eq_keys_dec x z); subst.
  rewrite remove_belongs_concat_l in Hbind.
  apply binds_concat_inv in Hbind.
  destruct Hbind as [ Hbind | [ Hnotin Hbind ] ].
  apply binds_concat_r; auto.

  apply notin_single_inv in Hnotin. elim Hnotin; auto.
  apply notin_single; auto.

  rewrite remove_belongs_concat_l in Hbind.
  apply binds_concat_inv in Hbind.
  destruct Hbind as [ Hbind | [ Hnotin Hbind ] ].
  apply binds_single_inv in Hbind. destruct Hbind; contradiction.
  apply binds_concat_l; auto. apply notin_single; auto.
Qed.

Theorem binds_all_remove : forall A x ys (v : A) (E : gen_env A),
  ¬ List.In x ys -> x ∹ v ⋲ E ->
  x ∹ v ⋲ (E ∖ ys).
Proof.
  induction ys as [ | y ys IHys ]; intros; simpl in *; auto.
  rewrite all_remove_nil; auto.
  rewrite all_remove_remove.
  assert (y <> x ∧ ¬ List.In x ys) as Hnot. split; auto. destruct Hnot.
  apply IHys; auto. apply binds_remove; auto.
Qed.

Theorem binds_all_remove_inv : forall A x ys (v : A) (E : gen_env A),
  ¬ List.In x ys -> x ∹ v ⋲ (E ∖ ys) ->
  x ∹ v ⋲ E.
Proof.
  induction ys as [ | y ys ]; intros v E Hnotin Hbind; simpl in *; auto.
  rewrite all_remove_nil in Hbind; auto.
  rewrite all_remove_remove in Hbind.
  assert (y <> x ∧ ¬ List.In x ys) as Hneq. split; auto. destruct Hneq.
  apply binds_remove_inv with y; auto.
Qed.

(** Binds and ok. *)
Theorem binds_concat_ok_comm : forall A x (v : A) (F G : gen_env A),
  binds x v (F & G) ->
  ok (F & G) ->
  binds x v (G & F).
Proof.
  intros A x v F G Hbind Hok. apply binds_concat_inv in Hbind.
  destruct Hbind as [ Hbind | [ Hnotin Hbind ] ].
  assert (x ∈ G) by (apply binds_belongs with v; auto).
  assert (x ∉ F) by (apply belongs_ok_concat_inv_r with G; auto).
  apply binds_concat_l; auto.
  apply binds_concat_r; auto.
Qed.

(** Decidability of binds. *)
Theorem binds_dec_exists : forall A x (E : gen_env A),
  { v | x ∹ v ⋲ E } + { forall v, ¬ x ∹ v ⋲ E }.
Proof.
  intros A x E. unfold binds.
  elim get_dec with A x E; intro Hget; [ left | right ]; auto.
  intro v. rewrite Hget. intro Heq. inversion Heq.
Qed.

Theorem binds_dec : forall A x (v : A) (E : gen_env A),
  (forall w w' : A, { w = w' } + { ¬ w = w' }) ->
  { x ∹ v ⋲ E } + { ¬ x ∹ v ⋲ E }.
Proof.
  intros A x v E Hdec. elim binds_dec_exists with A x E; intro Hdec2.
  destruct Hdec2 as [ w Hbind ]. elim (Hdec v w); intro Hneq; subst.
  left; auto.
  right. intro. assert (v = w) by (apply binds_eq_inv with x E; auto).
  auto.
  right; auto.
Qed.

(* ---------------------------------------------------------------------- *)
(** **** Properties of all_binds *)

(** All_Binds and binds. *)
Theorem all_binds_binds : forall A x (v : A) (E : gen_env A),
  (x ∶ v) ⊏ E ->
  x ∹ v ⋲ E.
Proof.
  unfold all_binds. intros A x v E Habind.
  apply (Habind x v). apply binds_single; auto.
Qed.

Theorem binds_all_binds : forall A x (v : A) (E : gen_env A),
  x ∹ v ⋲ E ->
  (x ∶ v) ⊏ E.
Proof.
  unfold all_binds. intros A x v E Hbind y w Hbind2.
  apply binds_single_inv in Hbind2. destruct Hbind2; subst; auto.
Qed.

(** All_Binds and empty. *)
Theorem all_binds_empty_l : forall A (E : gen_env A),
  (@empty A) ⊏ E.
Proof.
  unfold all_binds. intros A E x v Hbind.
  apply binds_empty in Hbind. inversion Hbind.
Qed.

Theorem all_binds_empty_r : forall A (E : gen_env A),
  E ⊏ (@empty A) ->
  E = (@empty A).
Proof.
  induction E as [ | E x v IHE ] using env_ind; intro Habind; auto.
  unfold all_binds in Habind.
  assert (x ∹ v ⋲ (@empty A)) as Hempty by
    (apply Habind; assert (x ∹ v ⋲ (E & (x ∶ v))) by
      (apply binds_concat_r; apply binds_single; auto); auto).
  apply binds_empty in Hempty. inversion Hempty.
Qed.

(** All_Binds on singular. *)
Theorem all_binds_single_empty : forall A x (v : A),
  (x ∶ v) ⊏ (@empty A) ->
  False.
Proof.
  intros A x v Habind. apply all_binds_binds in Habind.
  apply binds_empty in Habind; auto.
Qed.

Theorem all_binds_single_single : forall A x y (v w : A),
  x = y -> v = w ->
  (x ∶ v) ⊏ (y ∶ w).
Proof.
  intros; subst. apply binds_all_binds. apply binds_single; auto.
Qed.

Theorem all_binds_single_single_inv : forall A x y (v w : A),
  (x ∶ v) ⊏ (y ∶ w) ->
  x = y ∧ v = w.
Proof.
  intros A x y v w Habind. apply all_binds_binds in Habind.
  apply binds_single_inv; auto.
Qed.

Theorem all_binds_single_push_inv : forall A x y (v w : A) (E : gen_env A),
  (x ∶ v) ⊏ (E & (y ∶ w)) ->
  (x = y ∧ v = w) ∨ (x <> y ∧ (x ∶ v) ⊏ E).
Proof.
  intros A x y v w E Habind. apply all_binds_binds in Habind.
  apply binds_concat_inv in Habind.
  destruct Habind as [ Hbind | [ Hnotin Hbind ] ].
  apply binds_single_inv in Hbind. left; auto.
  apply notin_single_inv in Hnotin.
  apply binds_all_binds in Hbind. right; auto.
Qed.

Theorem all_binds_single_singles : forall A x y (v w : A) ys (ws : list A),
  x = y -> v = w ->
  (x ∶ v) ⊏ (y :: ys ∷ w :: ws).
Proof.
  intros. apply binds_all_binds. apply binds_singles; auto.
Qed.

Theorem all_binds_single_singles_inv :
  forall A x y (v w : A) ys (ws : list A),
    (x ∶ v) ⊏ (y :: ys ∷ w :: ws) ->
    (x = y ∧ v = w) ∨ ((x ∶ v) ⊏ (ys ∷ ws)).
Proof.
  intros A x y v w ys ws Habind.
  apply all_binds_binds in Habind. apply binds_singles_inv in Habind.
  destruct Habind; [ left | right ]; auto. apply binds_all_binds; auto.
Qed.

Theorem all_binds_single_eq_inv : forall A x (v w : A) (E : gen_env A),
  (x ∶ v) ⊏ E -> (x ∶ w) ⊏ E ->
  v = w.
Proof.
  intros A x v w E Habind1 Habind2.
  apply all_binds_binds in Habind1. apply all_binds_binds in Habind2.
  apply binds_eq_inv with x E; auto.
Qed.

(** All_Binds on singulars. *)
Theorem all_binds_singles_singles : forall A xs ys (vs ws : list A),
  xs = ys -> vs = ws ->
  (xs ∷ vs) ⊏ (ys ∷ ws).
Proof.
  intros; subst. unfold all_binds. intros; auto.
Qed.

(** All_Binds and concatenation. *)
Theorem all_binds_concat_r : forall A (E F G : gen_env A),
  E ⊏ G ->
  E ⊏ (F & G).
Proof.
  intros; unfold all_binds in *; intros. apply binds_concat_r; auto.
Qed.

Theorem all_binds_concat_l : forall A (E F G : gen_env A),
  E ⊏ F ->
  (dom E) ⊄ G ->
  E ⊏ (F & G).
Proof.
  intros A E F G Habind Hdom; unfold all_binds in *; intros x v Hbind.
  apply binds_concat_l; auto.
  apply binds_belongs in Hbind. auto.
  apply all_notin_def_inv with (dom E); auto.
  apply belongs_dom; auto.
Qed.

Theorem all_binds_l_concat : forall A (E F G : gen_env A),
  E ⊏ G -> F ⊏ G ->
  (E & F) ⊏ G.
Proof.
  intros. unfold all_binds in *. intros x v Hbind.
  apply binds_concat_inv in Hbind.
  destruct Hbind as [ Hbind | [ Hnotin Hbind] ]; auto.
Qed.

Theorem all_binds_l_concat_inv : forall A (E F G : gen_env A),
  ok (E & F) ->
  (E & F) ⊏ G ->
  E ⊏ G ∧ F ⊏ G.
Proof.
  intros A E F G Hok Habind. unfold all_binds in *.
  split; intros x v Hbind.
  apply Habind. apply binds_concat_l; auto.
  apply belongs_ok_concat_inv_l with E; auto.
  apply binds_belongs with v; auto.
  apply Habind. apply binds_concat_r; auto.
Qed.

Theorem all_binds_concat_compat : forall A (E F G : gen_env A),
  E ⊏ F ->
  (E & G) ⊏ (F & G).
Proof.
  intros A E F G Habind. induction G using env_ind.
  rewrite ?concat_empty_r; auto.
  unfold all_binds. intros y w Hbind.
  rewrite concat_assoc in *.
  apply binds_concat_inv in Hbind.
  destruct Hbind as [ Hbind | [ Hnotin Hbind ] ].
  apply binds_concat_r; auto.
  apply binds_concat_l; auto.
Qed.

(** All_Binds on singulars when ok. *)
Theorem all_binds_singles_eq_inv :
  forall A xs (vs vs' : list A) (F : gen_env A),
    List.NoDup xs ->
    length xs = length vs ->
    length xs = length vs' ->
    xs ∷ vs ⊏ F -> xs ∷ vs' ⊏ F ->
    vs = vs'.
Proof.
  induction xs as [ | x xs IHxs ]; induction vs as [ | v vs IHvs ];
    induction vs' as [ | v' vs' IHvs' ];
      intros F Hnodup Hleq1 Hleq2 Habind1 Habind2;
        simpl in *; try congruence.

  inversion Hnodup.
  assert (((xs ∷ vs) & (x ∶ v)) ⊏ F) as Habind_1
    by (rewrite <- singles_cons; auto); clear Habind1.
  assert (((xs ∷ vs') & (x ∶ v')) ⊏ F) as Habind_2
    by (rewrite <- singles_cons; auto); clear Habind2.
  apply all_binds_l_concat_inv in Habind_1.
  apply all_binds_l_concat_inv in Habind_2.
  destruct Habind_1; destruct Habind_2.
  assert (vs = vs') as Heq1 by (apply IHxs with F; auto).
  assert (v = v') as Heq2
    by (apply all_binds_single_eq_inv with x F; auto).
  rewrite Heq1, Heq2; auto.
  apply ok_concat. apply ok_singles; auto.
  apply ok_single. rewrite dom_singles.
  apply all_notin_single; auto. auto.
  rewrite dom_single. apply notin_all_notin.
  split. apply notin_singles; auto. apply all_notin_empty_l.
  apply ok_concat. apply ok_singles; auto.
  apply ok_single. rewrite dom_singles.
  apply all_notin_single; auto. auto.
  rewrite dom_single. apply notin_all_notin.
  split. apply notin_singles; auto. apply all_notin_empty_l.
Qed.

(** All_Binds and belongs. *)
Theorem all_binds_belongs : forall A (E F : gen_env A),
  E ⊏ F ->
  (dom E) ⊂ F.
Proof.
  unfold all_binds. intros A E F Hyp. apply all_belongs_def. intros x Hin.
  apply belongs_dom_inv in Hin.
  apply belongs_binds in Hin. destruct Hin as [ v Hbind ].
  apply Hyp in Hbind. apply binds_belongs with v; auto.
Qed.

Theorem belongs_all_binds : forall A x (F : gen_env A),
  x ∈ F ->
  exists v, (x ∶ v) ⊏ F.
Proof.
  intros A x F Hin. unfold all_binds. apply belongs_binds in Hin.
  destruct Hin as [ v Hbind ].
  exists v. intros y w Hbind2. apply binds_single_inv in Hbind2.
  destruct Hbind2; subst; auto.
Qed.

Theorem all_belongs_all_binds : forall A xs (F : gen_env A),
  xs ⊂ F ->
  exists vs, (xs ∷ vs) ⊏ F.
Proof.
  induction xs as [ | x xs IHxs ]; intros F Hin.
  exists nil; rewrite singles_empty; apply all_binds_empty_l; auto.
  apply all_belongs_belongs in Hin. destruct Hin as [ Hxin Hxsin ].
  apply IHxs in Hxsin. destruct Hxsin as [ vs Habind ].
  apply belongs_binds in Hxin. destruct Hxin as [ v Hbind ].
  exists (v :: vs). rewrite singles_cons. unfold all_binds.
  intros y w Hbind2.
  apply binds_concat_inv in Hbind2.
  destruct Hbind2 as [ Hbind2 | [ Hnotin Hbind2 ] ].
  apply binds_single_inv in Hbind2. destruct Hbind2; subst; auto.
  unfold all_binds in Habind; auto.
Qed.

(** All_Binds and map. *)
Theorem all_binds_map : forall A B (f : A -> B) (E F : gen_env A),
  E ⊏ F ->
  map f E ⊏ map f F.
Proof.
  intros A B f E F Habind. unfold all_binds in *. intros x v Hbind.
  apply binds_map_inv in Hbind. destruct Hbind as [ w [ Hbind Heq ] ].
  apply Habind in Hbind. subst. apply binds_map. auto.
Qed.

Theorem all_binds_map_inv : forall A B (f : A -> B) (E F : gen_env A),
  Image.injective A B f ->
  map f E ⊏ map f F ->
  E ⊏ F.
Proof.
  intros A B f E F Hinj Habind. unfold all_binds in *. intros x v Hbind.
  assert (x ∹ (f v) ⋲ map f E) as Hbind2 by (apply binds_map; auto).
  apply Habind in Hbind2. apply binds_map_inv in Hbind2.
  destruct Hbind2 as [ w [ Hbind2 Heq ] ].
  unfold Image.injective in *. apply Hinj in Heq. rewrite Heq; auto.
Qed.

(** All_Binds and update. *)
Theorem all_binds_update_self : forall A (E F : gen_env A),
  (dom E) ⊂ F ->
  E ⊏ (F ::= E).
Proof.
  intros A E F Hdom. unfold all_binds. intros x v Hbind.
  induction E as [ | E y w IHE ] using env_ind.
  apply binds_empty in Hbind. inversion Hbind.

  rewrite dom_concat in Hdom. rewrite dom_single in Hdom. simpl in Hdom.
  apply all_belongs_belongs in Hdom. destruct Hdom as [ Hin Hdom ].

  apply binds_concat_inv in Hbind. rewrite update_concat_r.
  destruct Hbind as [ Hbind | [ Hnotin Hbind ] ].
  apply binds_single_inv in Hbind. destruct Hbind; subst.
  apply binds_update_self. apply belongs_update; auto.

  apply notin_single_inv in Hnotin. rewrite update_update_one.
  apply binds_update_one_neq; auto.
Qed.

Theorem all_binds_update : forall A (E F G : gen_env A),
  E ⊏ F ->
  (E ::= G) ⊏ (F ::= G).
Proof.
  intros A E F G Habind. unfold all_binds in *. intros x v Hbind.
  apply binds_update_inv in Hbind.
  destruct Hbind as [ [ Hnotin Hbind ] | [ Hin Hbind ] ].
  apply binds_update_notin; auto.
  apply belongs_binds in Hin. destruct Hin as [ w Hbind2 ].
  apply Habind in Hbind2. apply binds_belongs in Hbind2.
  apply binds_update_in; auto.
Qed.

(** All_Binds and remove. *)
Theorem all_binds_remove : forall A y (E F : gen_env A),
  y ∉ E -> E ⊏ F ->
  E ⊏ (F ∖ {y}).
Proof.
  intros A y E F Hnotin Habind. unfold all_binds in *. intros x v Hbind.
  apply binds_remove; auto.
  apply binds_belongs in Hbind. apply notin_belongs_neq with A E; auto.
Qed.

Theorem all_binds_remove_inv : forall A y (E F : gen_env A),
  y ∉ E -> E ⊏ (F ∖ {y}) ->
  E ⊏ F.
Proof.
  intros A y E F Hnotin Habind. unfold all_binds in *. intros x v Hbind.
  apply binds_remove_inv with y; auto.
  apply binds_belongs in Hbind. apply notin_belongs_neq with A E; auto.
Qed.

Theorem all_binds_all_remove : forall A ys (E F : gen_env A),
  ys ⊄ E -> E ⊏ F ->
  E ⊏ (F ∖ ys).
Proof.
  intros A ys E F Hnotin Habind. unfold all_binds in *. intros x v Hbind.
  apply binds_all_remove; auto.
  apply binds_belongs in Hbind. apply all_notin_belongs_neq with A E; auto.
Qed.

Theorem all_binds_all_remove_inv : forall A ys (E F : gen_env A),
  ys ⊄ E -> E ⊏ (F ∖ ys) ->
  E ⊏ F.
Proof.
  intros A ys E F Hnotin Habind. unfold all_binds in *. intros x v Hbind.
  apply binds_all_remove_inv with ys; auto.
  apply binds_belongs in Hbind. apply all_notin_belongs_neq with A E; auto.
Qed.

Theorem all_binds_remove_compat : forall A x (E F : gen_env A),
  ok E -> ok F ->
  E ⊏ F ->
  E ∖ {x} ⊏ F ∖ {x}.
Proof.
  intros A x E F Hok1 Hok2 Habind. unfold all_binds in *. intros y v Hbind.
  assert (y <> x) by
    (apply belongs_remove_inv with A E; auto;
      apply binds_belongs with v; auto).
  apply binds_remove; auto. apply Habind.
  apply binds_remove_inv with x; auto.
Qed.

Theorem all_binds_all_remove_compat : forall A xs (E F : gen_env A),
  ok E -> ok F ->
  E ⊏ F ->
  E ∖ xs ⊏ F ∖ xs.
Proof.
  induction xs as [ | x xs IHxs ]; intros E F Hok1 Hok2 Habind;
    simpl in *; auto.
  rewrite ?all_remove_nil; auto.
  assert (E ∖ {x} ⊏ F ∖ {x}) by (apply all_binds_remove_compat; auto).
  rewrite ?all_remove_remove.
  apply IHxs; auto; apply ok_remove; auto.
Qed.

(** All_Binds and ok *)
Theorem all_binds_ok_concat_inv : forall A (E F G : gen_env A),
  ok (E & F) ->
  (E & F) ⊏ G ->
  E ⊏ G ∧ F ⊏ G.
Proof.
  intros A E F G Hok Habind; unfold all_binds in *.
  split; intros x v Hbind; apply Habind.
  apply binds_concat_l; auto. apply binds_belongs in Hbind.
  apply belongs_ok_concat_inv_l with E; auto.
  apply binds_concat_r; auto.
Qed.

Theorem all_binds_concat_ok_comm : forall A (E F G : gen_env A),
  E ⊏ (F & G) ->
  ok (F & G) ->
  E ⊏ (G & F).
Proof.
  intros. unfold all_binds in *. intros.
  apply binds_concat_ok_comm; auto.
Qed.

(** All_Binds is reflexive, anti-symmetric and transitive *)
Theorem all_binds_refl : forall A (E F : gen_env A),
  E = F ->
  E ⊏ F.
Proof. intros; subst; unfold all_binds; auto. Qed.

Theorem all_binds_anti_sym : forall A (E F : gen_env A),
  E ⊏ F -> F ⊏ E ->
  E ≍ F.
Proof. unfold eq; auto. Qed.

Theorem all_binds_trans : forall A (E F G : gen_env A),
  E ⊏ F -> F ⊏ G ->
  E ⊏ G.
Proof. unfold all_binds; intros; auto. Qed.

(** Decidability of all_binds. *)

(**************************************************************************)
(* This lemma should appear in a List module...                           *)
Lemma list_length_S : forall A (l : list A) n,
  length l = S n -> exists x:A, exists l', l = x :: l'.
Proof.
  induction l as [ | a ]; intros n Hlen; simpl in *; inversion Hlen;
    exists a; exists l; auto.
Qed.
(**************************************************************************)

Theorem all_binds_dec_exists : forall A xs (F : gen_env A),
  List.NoDup xs ->
  { vs : list A | length xs = length vs ∧ (xs ∷ vs) ⊏ F }
  + { forall vs : list A, length xs = length vs -> ¬ (xs ∷ vs) ⊏ F }.
Proof.
  intros A xs F Hnodup. unfold all_binds. induction xs as [ | x xs IHxs ].

  (* case nil *)
  Focus.
  left. exists nil. split; auto. rewrite singles_empty. intros x v Hbind.
  apply binds_empty in Hbind. inversion Hbind.

  (* case cons *)
  assert (~ List.In x xs ∧ List.NoDup xs) as Hnodup2 by
    (inversion Hnodup; auto). clear Hnodup.
  destruct Hnodup2 as [ Hnotin Hnodup2 ].
  destruct IHxs as [ IH | IH ]; auto.

  (* case exists *)
  Focus.
  destruct IH as [ vs [ Hlen Hbind ] ].
  elim binds_dec_exists with A x F; intro Hex. destruct Hex as [ v Hbind2 ].
  left. exists (v :: vs). split; simpl; auto. intros y w Hbind3.
  assert (y ∹ w ⋲ ((xs ∷ vs) & (x ∶ v))) as Hbind4
    by (rewrite <- singles_cons; auto). clear Hbind3.
  apply binds_concat_inv in Hbind4.
  destruct Hbind4 as [ Hbind4 | [ Hnotin2 Hbind4 ] ]; auto.
  apply binds_single_inv in Hbind4. destruct Hbind4; subst; auto.

  right. intros ws Hlen2. inversion Hlen2 as [ Hlen3 ].
  apply eq_sym in Hlen3. apply list_length_S in Hlen3.
  destruct Hlen3 as [ w [ ws' Heq ] ]; subst; simpl in *.
  intro Hyp. apply (Hex w). apply (Hyp x w).
  assert (x ∹ w ⋲ ((xs ∷ ws') & (x ∶ w))). apply binds_concat_r.
  apply binds_single; auto. rewrite singles_cons; auto.

  (* case not exists *)
  Focus.
  right. intros vs Hlen. inversion Hlen as [ Hlen2 ].
  apply eq_sym in Hlen2. apply list_length_S in Hlen2.
  destruct Hlen2 as [ v [ vs' Heq ] ]. subst; simpl in *.
  intro Hyp. apply (IH vs'); auto. intros y w Hbind. apply Hyp.
  assert (y ∹ w ⋲ ((xs ∷ vs') & (x ∶ v))); auto.
  apply binds_concat_l; auto.
  apply binds_belongs in Hbind. inversion Hlen.
  apply belongs_singles_inv in Hbind; auto.
  apply notin_single. intro Heq; subst; auto.
  rewrite singles_cons; auto.
Qed.

Theorem all_binds_dec : forall A (E F : gen_env A),
  ok E ->
  (forall w w' : A, { w = w' } + { ¬ w = w' }) ->
  {E ⊏ F} + {¬ E ⊏ F}.
Proof.
  assert (forall A, (forall w w' : A, { w = w' } + { ¬ w = w' }) ->
    forall ws ws' : list A, { ws = ws' } + { ¬ ws = ws' }) as Hdec.
  intros A Hyp.
  induction ws as [ | w ws IHws ]; induction ws' as [ | w' ws' IHws' ];
    simpl in *; auto.
  right; intro Heq; inversion Heq.
  right; intro Heq; inversion Heq. destruct (Hyp w w'); destruct (IHws ws').
  left; subst; auto.
  right; intro Heq; inversion Heq; auto.
  right; intro Heq; inversion Heq; auto.
  right; intro Heq; inversion Heq; auto.

  intros A E F Hok Hdec2.
  assert (forall ws ws' : list A, { ws = ws' } + { ¬ ws = ws' })
    as Hdec3 by auto.

  assert (List.NoDup (dom E)) as Hdom by (apply ok_dom_inv; auto).
  elim all_binds_dec_exists with A (dom E) F; auto; intro Hyp.
  destruct Hyp as [ vs [ Hlen Habind ] ].
  elim (Hdec3 vs (img E)); intro Hyp; subst.
  left. rewrite dom_img_id in *; auto.
  right. intro Habind2. rewrite <- (dom_img_id E) in Habind2.
  assert (vs = img E).
  apply all_binds_singles_eq_inv with (dom E) F; auto.
  apply length_dom_img_eq. auto.
  right. intro Habind. apply (Hyp (img E)).
  apply length_dom_img_eq. rewrite dom_img_id; auto.
Qed.

(* ---------------------------------------------------------------------- *)
(** **** Properties of eq *)

(** Eq is reflexive, symmetric and transitive *)
Theorem eq_refl : forall A (E F : gen_env A),
  E = F ->
  E ≍ F.
Proof. unfold eq. intro. split; apply all_binds_refl; auto. Qed.

Theorem eq_sym : forall A (E F : gen_env A),
  E ≍ F ->
  F ≍ E.
Proof. unfold eq; intros A E F Heq; destruct Heq; split; auto. Qed.

Theorem eq_trans : forall A (E F G : gen_env A),
  E ≍ F -> F ≍ G ->
  E ≍ G.
Proof.
  unfold eq; intros A E F G Heq1 Heq2. destruct Heq1, Heq2.
  split; apply all_binds_trans with F; auto.
Qed.

(** Eq implements equivalence over bindings. *)
Theorem eq_binds : forall A x (v : A) (E F : gen_env A),
  E ≍ F ->
  binds x v E ->
  binds x v F.
Proof. intros A x v E F Heq Hbind. unfold eq in *. destruct Heq. auto. Qed.

(** Concat to the right. *)
Theorem eq_concat : forall A (E F G : gen_env A),
  E ≍ F ->
  (E & G) ≍ (F & G).
Proof.
  unfold eq; intros A E F G Heq. destruct Heq.
  split; apply all_binds_concat_compat; auto.
Qed.

(** Concat is commutative with eq when ok. *)
Theorem eq_concat_comm : forall A (E F : gen_env A),
  ok (E & F) ->
  (E & F) ≍ (F & E).
Proof.
  intros. unfold eq.
  split; apply all_binds_concat_ok_comm; auto.
  auto; apply all_binds_refl; auto.
  apply all_binds_refl; auto. apply ok_concat_comm; auto.
Qed.

(** Eq commutes with other operations on environments. *)
Theorem eq_get : forall A (E F : gen_env A),
  E ≍ F ->
  forall x, get x E = get x F.
Proof.
  intros A E F Heq x. unfold eq in Heq. destruct Heq as [ Habind1 Habind2 ].
  unfold all_binds in *. unfold binds in *.
  elim get_dec with A x E; elim get_dec with A x F; intros Hyp1 Hyp2.
  destruct Hyp1 as [ v Hget1 ]; destruct Hyp2 as [ w Hget2 ].
  rewrite Hget1, Hget2. apply Habind1 in Hget2.
  rewrite Hget1 in Hget2; auto.
  destruct Hyp2 as [ v Hget2 ]. apply Habind1 in Hget2.
  rewrite Hyp1 in Hget2. inversion Hget2.
  destruct Hyp1 as [ v Hget1 ]. apply Habind2 in Hget1.
  rewrite Hyp2 in Hget1. inversion Hget1.
  rewrite Hyp1, Hyp2; auto.
Qed.

Theorem eq_get_inv : forall A (E F : gen_env A),
  (forall x, get x E = get x F) ->
  E ≍ F.
Proof.
  intros A E F Hyp. unfold eq, all_binds, binds.
  split; intros x v Hbind. rewrite <- Hbind; auto. rewrite Hyp; auto.
Qed.

Theorem eq_map : forall A B (f : A -> B) (E F : gen_env A),
  E ≍ F ->
  map f E ≍ map f F.
Proof.
  intros A B f E F Heq. unfold eq in *. destruct Heq.
  split; apply all_binds_map; auto.
Qed.

Theorem eq_map_inv : forall A B (f : A -> B) (E F : gen_env A),
  Image.injective A B f ->
  map f E ≍ map f F ->
  E ≍ F.
Proof.
  intros A B f E F Hinj Heq. unfold eq in *. destruct Heq.
  split; apply (all_binds_map_inv Hinj); auto.
Qed.

Theorem eq_remove : forall A x (E F : gen_env A),
  ok E -> ok F ->
  E ≍ F ->
  E ∖ {x} ≍ F ∖ {x}.
Proof.
  intros A x E F Hok1 Hok2 Heq. unfold eq in *. destruct Heq.
  split; apply all_binds_remove_compat; auto.
Qed.

Theorem eq_all_remove : forall A xs (E F : gen_env A),
  ok E -> ok F ->
  E ≍ F ->
  E ∖ xs ≍ F ∖ xs.
Proof.
  intros A xs E F Hok1 Hok2 Heq. unfold eq in *. destruct Heq.
  split; apply all_binds_all_remove_compat; auto.
Qed.

Theorem eq_update : forall A (E F G : gen_env A),
  E ≍ F ->
  (E ::= G) ≍ (F ::= G).
Proof.
  intros A E F G Heq. unfold eq in *. destruct Heq.
  split; apply all_binds_update; auto.
Qed.

Theorem eq_belongs : forall A x (E F : gen_env A),
  E ≍ F ->
  x ∈ E ->
  x ∈ F.
Proof.
  intros A x E F Heq Hin. unfold eq in *.
  destruct Heq as [ Habind1 Habind2 ]. unfold all_binds in *.
  apply belongs_binds in Hin. destruct Hin as [ v Hbind ].
  apply Habind1 in Hbind. apply binds_belongs with v; auto.
Qed.

Theorem eq_all_belongs : forall A xs (E F : gen_env A),
  E ≍ F ->
  xs ⊂ E ->
  xs ⊂ F.
Proof.
  intros A xs E F Heq Hin. unfold eq in *.
  destruct Heq as [ Habind1 Habind2 ].
  apply all_binds_belongs in Habind1.
  apply all_belongs_def. intros.
  apply all_belongs_def_inv with (dom E); auto.
  apply belongs_dom.
  apply all_belongs_def_inv with xs; auto.
Qed.

Theorem eq_notin : forall A x (E F : gen_env A),
  E ≍ F ->
  x ∉ E ->
  x ∉ F.
Proof.
  intros A x E F Heq Hnotin. unfold eq in *.
  destruct Heq as [ Habind1 Habind2 ]. unfold all_binds in *.
  apply not_belongs_notin. intro Hin.
  apply belongs_binds in Hin. destruct Hin as [ v Hbind ].
  apply Habind2 in Hbind. apply binds_belongs in Hbind.
  apply notin_belongs in Hnotin. contradiction.
Qed.

Theorem eq_all_notin : forall A xs (E F : gen_env A),
  E ≍ F ->
  xs ⊄ E ->
  xs ⊄ F.
Proof.
  intros A xs E F Heq Hnotin. apply all_notin_def. intros.
  apply eq_notin with E; auto.
  apply all_notin_def_inv with xs; auto.
Qed.

(** Decidability of eq. *)
Theorem eq_dec : forall A (E F : gen_env A),
  (forall w w' : A, { w = w' } + { ¬ w = w' }) ->
  ok E -> ok F ->
  { E ≍ F } + { ¬ E ≍ F }.
Proof.
  intros A E F Hdec Hok1 Hok2; unfold eq.
  elim all_binds_dec with A E F; elim all_binds_dec with A F E; intros;
    auto; right; intro Heq; destruct Heq; contradiction.
Qed.

(* ---------------------------------------------------------------------- *)
(** **** Additional principal properties *)

Theorem update_is_remove_concat : forall A x (v : A) (E : gen_env A),
  x ∈ E ->
  E ::= (x ∶ v) ≍ (E ∖ {x}) & (x ∶ v).
Proof.
  intros A x v E Hin. unfold eq. split; unfold all_binds; intros y w Hbind.
  apply binds_update_inv in Hbind.
  destruct Hbind as [ [ Hnotin Hbind ] | [ Hin2 Hbind ] ].
  apply binds_concat_l; auto. apply notin_single_inv in Hnotin.
  apply binds_remove; auto.
  apply binds_concat_r; auto.
  apply binds_concat_inv in Hbind.
  destruct Hbind as [ Hbind | [ Hnotin Hbind ] ].
  apply binds_single_inv in Hbind. destruct Hbind; subst.
  apply binds_update_self; auto.
  apply binds_update_notin; auto.
  apply binds_remove_inv with x; auto.
  apply notin_single_inv with A v; auto.
Qed.

End Properties.

End GenericEnvironmentType.


(* Distributed under the terms of the MIT license. *)

(* Eta expanded constructors only, see EEtaExpandedFix for the more involved definition where fixpoints are also eta-expanded. *)

From Coq Require Import Utf8 Program.
From MetaCoq.Utils Require Import utils.
From MetaCoq.Common Require Import config Kernames EnvMap BasicAst.
From MetaCoq.Erasure Require Import EAst EAstUtils EInduction EGlobalEnv EWellformed ELiftSubst ESpineView ECSubst EWcbvEval EWcbvEvalInd EProgram.

Local Open Scope string_scope.
Set Asymmetric Patterns.
Import MCMonadNotation.

From Equations Require Import Equations.
Set Equations Transparent.
Local Set Keyed Unification.
From Coq Require Import ssreflect ssrbool.

(** We assume [Prop </= Type] and universes are checked correctly in the following. *)
Local Existing Instance extraction_checker_flags.

Ltac introdep := let H := fresh in intros H; depelim H.

#[global]
Hint Constructors eval : core.

Import MCList (map_InP, map_InP_elim, map_InP_spec).

Equations discr_construct (t : term) : Prop :=
discr_construct (tConstruct ind n block_args) := False ;
discr_construct _ := True.

Inductive construct_view : term -> Type :=
| view_construct : forall ind n block_args, construct_view (tConstruct ind n block_args)
| view_other : forall t, discr_construct t -> construct_view t.

Equations construct_viewc t : construct_view t :=
construct_viewc (tConstruct ind n block_args) := view_construct ind n block_args ;
construct_viewc t := view_other t I.

Ltac toAll :=
    repeat match goal with
      | [ H : forall x, In x ?l -> _ |- _ ] => eapply In_All in H
    end.

Import ECSubst.

Section isEtaExp.
  Context (Σ : global_declarations).

  Definition isEtaExp_app ind c k :=
    match EGlobalEnv.lookup_constructor_pars_args Σ ind c with
    | Some (npars, nargs) => leb (npars + nargs) k
    | None => false
    end.

  Import TermSpineView.

  Definition is_nil {A} (l : list A) := match l with [] => true | _ => false end.

  Equations? isEtaExp (e : EAst.term) : bool
    by wf e (fun x y : EAst.term => size x < size y) :=
  | e with TermSpineView.view e := {
    | tRel i => true
    | tEvar ev args => forallb_InP args (fun x H => isEtaExp x)
    | tLambda na M => isEtaExp M
    | tApp u v napp nnil with construct_viewc u :=
      { | view_construct ind i block_args => isEtaExp_app ind i (List.length v) && forallb_InP v (fun x H => isEtaExp x) && is_nil block_args
        | view_other _ _ => isEtaExp u && forallb_InP v (fun x H => isEtaExp x) }
    | tLetIn na b b' => isEtaExp b && isEtaExp b'
    | tCase ind c brs => isEtaExp c && forallb_InP brs (fun x H => isEtaExp x.2)
    | tProj p c => isEtaExp c
    | tFix mfix idx => forallb_InP mfix (fun x H => isLambda x.(dbody) && isEtaExp x.(dbody))
    | tCoFix mfix idx => forallb_InP mfix (fun x H => isEtaExp x.(dbody))
    | tBox => true
    | tVar _ => true
    | tConst _ => true
    | tPrim _ => true
    | tConstruct ind i block_args => isEtaExp_app ind i 0 && is_nil block_args }.
  Proof.
    all:try lia.
    all:try apply (In_size); tea.
    all:try lia.
    - now apply (In_size id size).
    - rewrite size_mkApps.
      eapply (In_size id size) in H.
      change (fun x => size (id x)) with size in H. unfold id in *; cbn.
      lia.
    - now eapply size_mkApps_f.
    - change (fun x => size (id x)) with size in H.
      eapply (In_size id size) in H. unfold id in H.
      change (fun x => size x) with size in H.
      pose proof (size_mkApps_l napp nnil). lia.
    - eapply (In_size snd size) in H. cbn in H; lia.
  Qed.

End isEtaExp.

Global Hint Rewrite @forallb_InP_spec : isEtaExp.
Tactic Notation "simp_eta" "in" hyp(H) := simp isEtaExp in H; rewrite -?isEtaExp_equation_1 in H.
Ltac simp_eta := simp isEtaExp; rewrite -?isEtaExp_equation_1.

Section isEtaExp.
  Context (Σ : global_context).
  Notation isEtaExp := (isEtaExp Σ).

  Lemma isEtaExp_mkApps_nonnil f v :
    ~~ isApp f -> v <> [] ->
    isEtaExp (mkApps f v) = match construct_viewc f with
      | view_construct ind i block_args => isEtaExp_app Σ ind i #|v| && forallb isEtaExp v && is_nil block_args
      | view_other t discr => isEtaExp f && forallb isEtaExp v
    end.
  Proof using Type.
    rewrite isEtaExp_equation_1.
    intros napp hv.
    destruct (TermSpineView.view_mkApps (TermSpineView.view (mkApps f v)) napp hv) as [hna [hv' ->]].
    cbn. destruct (construct_viewc f); cbn; simp isEtaExp => //.
  Qed.

  Lemma isEtaExp_mkApps_napp f v : ~~ isApp f ->
    isEtaExp (mkApps f v) = match construct_viewc f with
      | view_construct ind i block_args => isEtaExp_app Σ ind i #|v| && forallb isEtaExp v && is_nil block_args
      | view_other t discr => isEtaExp f && forallb isEtaExp v
    end.
  Proof using Type.
    intros napp.
    destruct v using rev_case; simp_eta.
    - destruct construct_viewc; rewrite andb_true_r //.
    - rewrite isEtaExp_mkApps_nonnil //.
  Qed.

  Lemma isEtaExp_Constructor ind i v block_args :
    isEtaExp (mkApps (EAst.tConstruct ind i block_args) v) = isEtaExp_app Σ ind i #|v| && forallb isEtaExp v && is_nil block_args.
  Proof using Type.
    rewrite isEtaExp_mkApps_napp //.
  Qed.

  Lemma isEtaExp_mkApps f u : isEtaExp (mkApps f u) ->
    let (hd, args) := decompose_app (mkApps f u) in
    match construct_viewc hd with
    | view_construct kn c block_args => isEtaExp_app Σ kn c #|args| && forallb isEtaExp args && is_nil block_args
    | view_other u discr => isEtaExp hd && forallb isEtaExp args
    end.
  Proof using Type.
    destruct decompose_app eqn:da.
    rewrite (decompose_app_inv da).
    pose proof (decompose_app_notApp _ _ _ da).
    destruct l. cbn -[isEtaExp].
    intros eq; rewrite eq.
    destruct (construct_viewc t) => //. simp isEtaExp in eq. rtoProp. solve_all.
    assert (t0 :: l <> []) by congruence.
    revert da H0. generalize (t0 :: l). clear t0 l; intros l.
    intros da nnil.
    rewrite isEtaExp_mkApps_napp //.
  Qed.

  Arguments EEtaExpanded.isEtaExp : simpl never.

  Lemma isEtaExp_mkApps_intro_notConstruct t l : ~~ isConstruct (head t) ->
     isEtaExp t -> All isEtaExp l -> isEtaExp (mkApps t l).
  Proof using Type.
    revert t; induction l using rev_ind; auto.
    intros t isc et a; eapply All_app in a as [].
    depelim a0. clear a0.
    destruct (decompose_app t) eqn:da.
    rewrite (decompose_app_inv da) in et isc *.
    pose proof (decompose_app_notApp _ _ _ da).
    destruct l0. simp_eta.
    - rewrite isEtaExp_mkApps_napp //.
      destruct construct_viewc eqn:vc => //. cbn.
      rtoProp; repeat solve_all.
      eapply All_app_inv; eauto.
    - rewrite isEtaExp_mkApps_napp in et => //.
      destruct construct_viewc.
      rewrite head_mkApps in isc => //.
      rewrite -mkApps_app. rewrite isEtaExp_mkApps_napp //.
      destruct (construct_viewc t0) => //.
      move/andP: et => [] -> /=. rtoProp; solve_all.
      rewrite forallb_app. rtoProp; repeat solve_all.
      eapply All_app_inv; eauto.
  Qed.

  Lemma isEtaExp_tApp {f u} : isEtaExp (EAst.tApp f u) ->
    let (hd, args) := decompose_app (EAst.tApp f u) in
    match construct_viewc hd with
    | view_construct kn c block_args =>
      args <> [] /\ f = mkApps hd (remove_last args) /\ u = last args u /\
      isEtaExp_app Σ kn c #|args| && forallb isEtaExp args && is_nil block_args
    | view_other _ discr =>
      [&& isEtaExp hd, forallb isEtaExp args, isEtaExp f & isEtaExp u]
    end.
  Proof using Type.
    move/(isEtaExp_mkApps f [u]).
    cbn -[decompose_app]. destruct decompose_app eqn:da.
    destruct construct_viewc eqn:cv => //.
    intros ->.
    pose proof (decompose_app_inv da).
    pose proof (decompose_app_notApp _ _ _ da).
    destruct l using rev_case. cbn. intuition auto. solve_discr. noconf H.
    rewrite mkApps_app in H. noconf H.
    rewrite remove_last_app last_last. intuition auto.
    destruct l; cbn in *; congruence.
    pose proof (decompose_app_inv da).
    pose proof (decompose_app_notApp _ _ _ da).
    destruct l using rev_case. cbn. intuition auto. destruct t => //.
    rewrite mkApps_app in H. noconf H.
    move=> /andP[] etat. rewrite forallb_app => /andP[] etal /=.
    rewrite andb_true_r => etaa. rewrite etaa andb_true_r.
    rewrite etat etal. cbn. rewrite andb_true_r.
    eapply isEtaExp_mkApps_intro_notConstruct; auto; solve_all.
    destruct t => //.
  Qed.

End isEtaExp.

Section WeakEtaExp.
  Context (Σ : global_context).
  Notation isEtaExp := (isEtaExp Σ).

  Lemma isEtaExp_app_mon ind c i i' : i <= i' -> isEtaExp_app Σ ind c i -> isEtaExp_app Σ ind c i'.
  Proof using Type.
    intros le.
    unfold isEtaExp_app.
    destruct lookup_constructor_pars_args as [[pars args]|]=> //.
    cbn.
    do 2 elim: Nat.leb_spec => //. lia.
  Qed.

  Lemma isEtaExp_mkApps_intro t l : isEtaExp t -> All isEtaExp l -> isEtaExp (mkApps t l).
  Proof using Type.
    revert t; induction l using rev_ind; auto.
    intros t et a; eapply All_app in a as [].
    depelim a0. clear a0.
    destruct (decompose_app t) eqn:da.
    rewrite (decompose_app_inv da) in et *.
    pose proof (decompose_app_notApp _ _ _ da).
    destruct l0. simp_eta.
    - rewrite isEtaExp_mkApps_napp //.
      destruct construct_viewc.  cbn. len.
      rtoProp; repeat solve_all. cbn in et. rtoProp. rename H0 into et. simp isEtaExp in et.
      eapply isEtaExp_app_mon; tea; lia.
      eapply All_app_inv; eauto.
      cbn in et. rtoProp. rename H0 into et. simp isEtaExp in et.
      rewrite et forallb_app /=.
      rtoProp; repeat solve_all.
    - rewrite isEtaExp_mkApps_napp in et => //.
      destruct construct_viewc.
      rewrite -mkApps_app. rewrite isEtaExp_Constructor.
      rtoProp; solve_all.
      eapply isEtaExp_app_mon; tea. cbn. len. solve_all. depelim H2.
      solve_all. eapply All_app_inv => //. econstructor; eauto.
      eapply All_app_inv => //. eauto.
      rewrite -mkApps_app. rewrite isEtaExp_mkApps_napp //.
      destruct (construct_viewc t0) => //.
      move/andP: et => [] -> /=. rtoProp; solve_all.
      rewrite forallb_app. rtoProp; repeat solve_all.
      eapply All_app_inv; eauto.
  Qed.

  Lemma etaExp_csubst a k b :
    isEtaExp a -> isEtaExp b -> isEtaExp (ECSubst.csubst a k b).
  Proof using Type.
    intros etaa. move b at bottom.
    funelim (isEtaExp b); cbn -[isEtaExp]; try simp_eta; eauto;
      try toAll; repeat solve_all.
    - intros. simp isEtaExp ; cbn. destruct Nat.compare => //. simp_eta in etaa.
    - move/andP: H1 => [] etab etab'.
      apply/andP. split; eauto.
    - rtoProp. intuition eauto. now destruct block_args.
    - rtoProp. intuition eauto.
      solve_all.
    - move/andP: b => [] etaexp h.
      apply/andP; split.
      now eapply isLambda_csubst.
      eapply a0 => //.
    - move/andP: H0 => [] etaexp h.
      rewrite csubst_mkApps /=.
      rewrite isEtaExp_Constructor. solve_all.
      rewrite map_length. rtoProp; solve_all. solve_all.
      now destruct block_args.
    - rewrite csubst_mkApps /=.
      move/andP: H1 => [] eu ev.
      specialize (H _ k etaa eu).
      eapply isEtaExp_mkApps_intro => //. solve_all.
  Qed.

  Lemma isEtaExp_substl s t :
    forallb isEtaExp s -> isEtaExp t ->
    isEtaExp (substl s t).
  Proof using Type.
    induction s in t |- *; simpl; auto. rtoProp; intuition eauto using etaExp_csubst.
  Qed.

  Lemma isEtaExp_iota_red pars args br :
    forallb isEtaExp args ->
    isEtaExp br.2 ->
    isEtaExp (EGlobalEnv.iota_red pars args br).
  Proof using Type.
    intros etaargs etabr.
    unfold EGlobalEnv.iota_red.
    rewrite isEtaExp_substl // forallb_rev forallb_skipn //.
  Qed.

  Lemma isEtaExp_fix_subst mfix :
    forallb (fun d => isLambda (dbody d) && isEtaExp (dbody d)) mfix ->
    forallb isEtaExp (EGlobalEnv.fix_subst mfix).
  Proof using Type.
    unfold EGlobalEnv.fix_subst. generalize #|mfix|.
    solve_all. solve_all. revert n.
    induction n; intros; simp_eta; constructor; auto.
    simp isEtaExp. solve_all.
  Qed.

  Lemma isEtaExp_cofix_subst mfix :
    forallb (isEtaExp ∘ dbody) mfix ->
    forallb isEtaExp (EGlobalEnv.cofix_subst mfix).
  Proof using Type.
    unfold EGlobalEnv.cofix_subst. generalize #|mfix|.
    solve_all. solve_all. revert n.
    induction n; intros; simp_eta; constructor; auto.
    simp isEtaExp. solve_all.
  Qed.

  Lemma isEtaExp_cunfold_fix mfix idx n f :
    forallb (fun d => isLambda (dbody d) && isEtaExp (dbody d)) mfix ->
    EGlobalEnv.cunfold_fix mfix idx = Some (n, f) ->
    isEtaExp f.
  Proof using Type.
    intros heta.
    unfold EGlobalEnv.cunfold_fix.
    destruct nth_error eqn:heq => //.
    intros [= <- <-] => /=.
    apply isEtaExp_substl.
    now apply isEtaExp_fix_subst.
    eapply forallb_nth_error in heta; tea.
    erewrite heq in heta. now move/andP: heta.
  Qed.

  Lemma isEtaExp_cunfold_cofix mfix idx n f :
    forallb (isEtaExp ∘ dbody) mfix ->
    EGlobalEnv.cunfold_cofix mfix idx = Some (n, f) ->
    isEtaExp f.
  Proof using Type.
    intros heta.
    unfold EGlobalEnv.cunfold_cofix.
    destruct nth_error eqn:heq => //.
    intros [= <- <-] => /=.
    apply isEtaExp_substl.
    now apply isEtaExp_cofix_subst.
    eapply forallb_nth_error in heta; tea.
    now erewrite heq in heta.
  Qed.

End WeakEtaExp.

Definition isEtaExp_constant_decl Σ cb :=
  option_default (isEtaExp Σ) cb.(cst_body) true.

Definition isEtaExp_decl Σ d :=
  match d with
  | ConstantDecl cb => isEtaExp_constant_decl Σ cb
  | InductiveDecl idecl => true
  end.

Fixpoint isEtaExp_env (Σ : global_declarations) :=
  match Σ with
  | [] => true
  | decl :: Σ => isEtaExp_decl Σ decl.2 && isEtaExp_env Σ
  end.

Lemma isEtaExp_lookup_ext {Σ} {kn d}:
  isEtaExp_env Σ ->
  lookup_env Σ kn = Some d ->
  ∑ Σ', extends Σ' Σ × isEtaExp_decl Σ' d.
Proof.
  induction Σ; cbn.
  - move=> _; rewrite /declared_constant /lookup_env /= //.
  - move=> /andP[] etaa etaΣ.
    destruct a as [kn' d']; cbn in *.
    rewrite /declared_constant /=.
    case:eqb_specT => //.
    * intros e; subst kn'. move=> [=]. intros ->.
      exists Σ. split => //. now exists [(kn, d)].
    * intros ne. move=> Hl. destruct (IHΣ etaΣ Hl) as [Σ' [ext eta]].
      exists Σ'; split => //.
      destruct ext as [Σ'' ->].
      now exists ((kn', d')::Σ'').
Qed.

Lemma isEtaExp_app_extends {efl : EEnvFlags} Σ Σ' ind k n :
  extends Σ Σ' ->
  wf_glob Σ' ->
  isEtaExp_app Σ ind k n ->
  isEtaExp_app Σ' ind k n.
Proof.
  rewrite /isEtaExp_app.
  rewrite /lookup_constructor_pars_args /lookup_constructor /lookup_inductive /lookup_minductive.
  move=> ext wf.
  destruct (lookup_env Σ _) eqn:hl => //.
  rewrite (extends_lookup wf ext hl) /= //.
Qed.

From MetaCoq.Erasure Require Import ELiftSubst.

Lemma isEtaExp_extends {efl : EEnvFlags} Σ Σ' t :
  extends Σ Σ' ->
  wf_glob Σ' ->
  isEtaExp Σ t ->
  isEtaExp Σ' t.
Proof.
  intros ext wf.
  funelim (isEtaExp Σ t); simp_eta => //; rtoProp; intuition eauto; rtoProp; intuition auto.
  - eapply In_All in H; solve_all.
  - eapply isEtaExp_app_extends; tea.
  - eapply In_All in H0. solve_all.
  - eapply In_All in H; solve_all.
    move/andP: b => [] -> /=. eauto.
  - eapply In_All in H; solve_all.
  - eapply In_All in H; solve_all.
    rewrite isEtaExp_Constructor //. rtoProp; intuition auto.
    eapply isEtaExp_app_extends; tea.
    solve_all.
  - eapply In_All in H0. apply isEtaExp_mkApps_intro; eauto. solve_all.
Qed.

Lemma isEtaExp_extends_decl {efl : EEnvFlags} {Σ Σ' t} :
  extends Σ Σ' ->
  wf_glob Σ' ->
  isEtaExp_decl Σ t ->
  isEtaExp_decl Σ' t.
Proof.
  intros ext wf; destruct t; cbn => //.
  rewrite /isEtaExp_constant_decl; destruct (cst_body c) => /= //.
  now eapply isEtaExp_extends.
Qed.

Lemma isEtaExp_lookup {efl : EEnvFlags} {Σ kn d}:
  isEtaExp_env Σ -> wf_glob Σ ->
  lookup_env Σ kn = Some d ->
  isEtaExp_decl Σ d.
Proof.
  move=> etaΣ wfΣ.
  move/(isEtaExp_lookup_ext etaΣ) => [Σ' []] ext hd.
  now eapply isEtaExp_extends_decl.
Qed.

Section expanded.

Variable Σ : global_declarations.

Local Unset Elimination Schemes.

Inductive expanded : term -> Prop :=
| expanded_tRel (n : nat) : expanded (tRel n)
| expanded_tVar (id : ident) : expanded (tVar id)
| expanded_tEvar (ev : nat) (args : list term) : Forall expanded args -> expanded (tEvar ev args)
| expanded_tLambda (na : name) (body : term) : expanded body -> expanded (tLambda na body)
| expanded_tLetIn (na : name) (def : term)(body : term) : expanded def -> expanded body -> expanded (tLetIn na def body)
| expanded_mkApps (f : term) (args : list term) : ~ isConstruct f -> args <> [] -> expanded f -> Forall expanded args -> expanded (mkApps f args)
| expanded_tConst (c : kername) : expanded (tConst c)
| expanded_tCase (ind : inductive) (pars : nat) (discr : term) (branches : list (list name × term)) :
    expanded discr -> Forall (fun br => expanded br.2) branches -> expanded (tCase (ind, pars) discr branches)
| expanded_tProj (proj : projection) (t : term) : expanded t -> expanded (tProj proj t)
| expanded_tFix (mfix : mfixpoint term) (idx : nat) :
  Forall (fun d => isLambda d.(dbody) /\ expanded d.(dbody)) mfix -> expanded (tFix mfix idx)
| expanded_tCoFix (mfix : mfixpoint term) (idx : nat) : Forall (fun d => expanded d.(dbody)) mfix -> expanded (tCoFix mfix idx)
| expanded_tConstruct_app ind idx mind idecl cdecl args :
    declared_constructor Σ (ind, idx) mind idecl cdecl ->
    #|args| >= cstr_arity mind cdecl ->
    Forall expanded args ->
    expanded (mkApps (tConstruct ind idx []) args)
| expanded_tPrim p : expanded (tPrim p)
| expanded_tBox : expanded tBox.

End expanded.
Derive Signature for expanded.

Lemma expanded_ind :
forall (Σ : global_declarations) (P : term -> Prop),
(forall n : nat, P (tRel n)) ->
(forall id : ident, P (tVar id)) ->
(forall (ev : nat) (args : list term), Forall (expanded Σ) args -> Forall P args -> P (tEvar ev args)) ->
(forall (na : name) (body : term),
 expanded Σ body -> P body -> P (tLambda na body)) ->
(forall (na : name) (def body : term),
 expanded Σ def ->
 P def -> expanded Σ body -> P body -> P (tLetIn na def body)) ->
(forall (f4 : term) (args : list term),
 ~ isConstruct f4 ->
 expanded Σ f4 -> P f4 -> args <> [] -> Forall (expanded Σ) args -> Forall P args -> P (mkApps f4 args)) ->
(forall c : kername, P (tConst c)) ->
(forall (ind : inductive) (pars : nat) (discr : term)
   (branches : list (list name × term)),
 expanded Σ discr ->
 P discr ->
 Forall (fun br : list name × term => expanded Σ br.2) branches ->
 Forall (fun br : list name × term => P br.2) branches ->
 P (tCase (ind, pars) discr branches)) ->
(forall (proj : projection) (t : term),
 expanded Σ t -> P t -> P (tProj proj t)) ->
(forall (mfix : mfixpoint term) (idx : nat),
 Forall (fun d : def term => isLambda (dbody d) /\ expanded Σ (dbody d)) mfix ->  Forall (fun d : def term => P (dbody d)) mfix  -> P (tFix mfix idx)) ->
(forall (mfix : mfixpoint term) (idx : nat),
 Forall (fun d : def term => expanded Σ (dbody d)) mfix ->  Forall (fun d : def term => P (dbody d)) mfix ->
 P (tCoFix mfix idx)) ->
(forall (ind : inductive) (idx : nat) (mind : mutual_inductive_body)
   (idecl : one_inductive_body) cdecl
   (args : list term),
 declared_constructor Σ (ind, idx) mind idecl cdecl ->
 #|args| >= cstr_arity mind cdecl -> Forall (expanded Σ) args -> Forall P args -> P (mkApps (tConstruct ind idx []) args)) ->
(forall p, P (tPrim p)) ->
(P tBox) ->
forall t : term, expanded Σ t -> P t.
Proof.
  intros. revert t H13.
  fix f 2.
  intros t Hexp. destruct Hexp; eauto.
  - eapply H1; eauto. induction H13; econstructor; cbn in *; eauto.
  - eapply H4; eauto. clear H14. induction H15; econstructor; cbn in *; eauto.
  - eapply H6; eauto. induction H13; econstructor; cbn in *; eauto.
  - eapply H8; eauto. induction H13; econstructor; cbn in *; intuition eauto.
  - eapply H9; eauto. induction H13; econstructor; cbn in *; eauto.
  - eapply H10; eauto. clear - H15 f. induction H15; econstructor; cbn in *; eauto.
Qed.

Local Hint Constructors expanded : core.

Definition expanded_constant_decl Σ (cb : constant_body) : Prop :=
  on_Some_or_None (expanded Σ) cb.(cst_body).

Definition expanded_decl Σ d :=
  match d with
  | ConstantDecl cb => expanded_constant_decl Σ cb
  | InductiveDecl idecl => True
  end.

Inductive expanded_global_declarations : forall (Σ : global_declarations), Prop :=
| expanded_global_nil : expanded_global_declarations []
| expanded_global_cons decl Σ : expanded_global_declarations Σ ->
  expanded_decl Σ decl.2 -> expanded_global_declarations (decl :: Σ).

Definition expanded_global_env := expanded_global_declarations.

Definition expanded_eprogram_cstrs (p : eprogram) :=
  EEtaExpanded.isEtaExp_env p.1 && EEtaExpanded.isEtaExp p.1 p.2.

Definition expanded_eprogram_env_cstrs (p : eprogram_env) :=
  let decls := p.1.(EEnvMap.GlobalContextMap.global_decls) in
  EEtaExpanded.isEtaExp_env decls && EEtaExpanded.isEtaExp decls p.2.

Lemma isEtaExp_app_expanded Σ ind idx n :
   isEtaExp_app Σ ind idx n = true <->
   exists mind idecl cdecl,
   declared_constructor Σ (ind, idx) mind idecl cdecl /\ n ≥ cstr_arity mind cdecl.
Proof.
  unfold isEtaExp_app, lookup_constructor_pars_args, lookup_constructor, lookup_inductive, lookup_minductive.
  split.
  - intros H.
    destruct lookup_env as [[| mind] | ] eqn:E; cbn in H; try congruence.
    destruct nth_error as [ idecl | ] eqn:E2; cbn in H; try congruence.
    destruct (nth_error (ind_ctors idecl) idx) as [ [cname ?] | ] eqn:E3; cbn in H; try congruence.
    repeat esplit.
    red. all: eauto. unfold cstr_arity; cbn. eapply leb_iff in H. lia.
  - intros (? & ? & ? & [[]] & Hle).
    rewrite H. cbn. rewrite H0. cbn. rewrite H1. cbn.
    eapply leb_iff. eauto.
Qed.

Lemma expanded_isEtaExp_app_ Σ ind idx n mind idecl cdecl :
   declared_constructor Σ (ind, idx) mind idecl cdecl -> n ≥ cstr_arity mind cdecl ->
   isEtaExp_app Σ ind idx n = true.
Proof.
  intros. eapply isEtaExp_app_expanded. eauto 8.
Qed.

Lemma isEtaExp_expanded Σ t :
  isEtaExp Σ t -> expanded Σ t.
Proof.
  funelim (isEtaExp Σ t); intros; solve_all; eauto.
  - rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0. eapply In_All in H.
    econstructor. solve_all.
  - eapply andb_true_iff in H1 as []; eauto.
  - rtoProp. eapply isEtaExp_app_expanded in H as (? & ? & ? & ? & ?).
    destruct block_args; inv H0.
    eapply expanded_tConstruct_app with (args := []); eauto.
  - eapply andb_true_iff in H1 as []. destruct ind. econstructor; eauto.
    rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2.
    eapply In_All in H0. solve_all.
  - econstructor. rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0.
    eapply In_All in H. rtoProp; intuition auto; solve_all.
    all: move/andP: b. 2:{ now intros []. }
    intuition auto.
  - econstructor. rewrite forallb_InP_spec in H0. eapply forallb_Forall in H0.
    eapply In_All in H. solve_all.
  - rtoProp. eapply In_All in H.
    rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2.
    eapply isEtaExp_app_expanded in H0 as (? & ? & ? & ? & ?).
    destruct block_args; inv H1.
    eapply expanded_tConstruct_app; eauto. solve_all.
  - eapply andb_true_iff in H1 as []. rewrite forallb_InP_spec in H2. eapply forallb_Forall in H2.
    econstructor.
    + destruct u; inv Heq; eauto.
    + eauto.
    + eauto.
    + eapply In_All in H0. solve_all.
Qed.

Lemma expanded_isEtaExp Σ t :
  expanded Σ t -> isEtaExp Σ t.
Proof.
  induction 1; simp_eta; eauto.
  all: try now (
    (try (eapply andb_true_iff; split; eauto));
    (try eapply forallb_Forall);
    eauto).
  - eapply isEtaExp_mkApps_intro; eauto. solve_all.
  - solve_all.
  - rewrite isEtaExp_Constructor. rtoProp; repeat split.
    2: eapply forallb_Forall.
    2: solve_all. eapply expanded_isEtaExp_app_; eauto.
Qed.

Lemma expanded_global_env_isEtaExp_env {Σ} : expanded_global_env Σ -> isEtaExp_env Σ.
Proof.
  intros e; induction e; cbn => //.
  rewrite IHe andb_true_r.
  red in H; red. destruct decl as [kn []] => /= //.
  cbn in H. red in H. unfold isEtaExp_constant_decl.
  destruct (cst_body c); cbn in * => //.
  now eapply expanded_isEtaExp.
Qed.

Lemma isEtaExp_env_expanded_global_env {Σ} : isEtaExp_env Σ -> expanded_global_env Σ.
Proof.
  induction Σ; cbn => /= //.
  - constructor.
  - move/andP=> [] etad etae; constructor; eauto. now apply IHΣ.
    move: etad. destruct a.2; cbn in * => //. unfold isEtaExp_constant_decl, expanded_constant_decl.
    destruct (cst_body c) => /= //. apply isEtaExp_expanded.
Qed.

Lemma solve_discr_args {t f args} : ~~ isApp t -> t = mkApps f args -> args = [] /\ f = t.
Proof.
  intros napp ->.
  induction args using rev_ind; cbn in *; auto.
  rewrite mkApps_app in napp. now cbn in napp.
Qed.

Ltac solve_discr_args :=
  match goal with [ H : ?t = mkApps ?f ?args |- _ ] =>
    destruct (@solve_discr_args t f args eq_refl H) as [-> ->] ||
    destruct (@solve_discr_args t f args eq_refl H) as [-> ?]
  end.

Lemma expanded_mkApps_expanded {Σ f args} :
  expanded Σ f -> All (expanded Σ) args ->
  expanded Σ (mkApps f args).
Proof.
  intros.
  destruct (isConstruct f) eqn:eqc.
  destruct f => //.
  - depelim H; try solve_discr_args => //.
    noconf H3.
    eapply expanded_tConstruct_app; tea. cbn in H0. lia. solve_all.
  - destruct args using rev_ind; cbn => //.
    eapply expanded_mkApps => //. now rewrite eqc. solve_all.
Qed.

From MetaCoq.Erasure Require Import EEtaExpandedFix.

Local Ltac simp_eta ::= simp isEtaExp; rewrite -?isEtaExp_equation_1 -?EEtaExpanded.isEtaExp_equation_1.

Lemma isEtaExpFix_isEtaExp Σ Γ t : EEtaExpandedFix.isEtaExp Σ Γ t -> EEtaExpanded.isEtaExp Σ t.
Proof.
  funelim (isEtaExp Σ Γ t); try solve [simp_eta => //].
  - simp_eta.
    intros Ha. eapply In_All in H. solve_all.
  - simp_eta. rtoProp; intuition auto.
  - simp_eta. rtoProp; intuition auto.
    eapply In_All in H0; solve_all.
  - eapply In_All in H. simp_eta; rtoProp; intuition auto. solve_all.
  - eapply In_All in H. simp_eta; rtoProp; intuition auto.
    rewrite EEtaExpanded.isEtaExp_Constructor. rtoProp; repeat split. eauto.
    solve_all. destruct block_args; cbn in *; eauto.
  - eapply In_All in H, H0. simp_eta.
    move => /andP[] /andP[] etafix etamfix etav.
    eapply EEtaExpanded.isEtaExp_mkApps_intro. simp_eta.
    clear -H etamfix. solve_all. rtoProp; intuition eauto.
    solve_all.
  - eapply In_All in H. simp_eta.
    move=> /andP[] etarel etav.
    eapply EEtaExpanded.isEtaExp_mkApps_intro. simp_eta. solve_all.
  - eapply In_All in H0. simp_eta.
    move=> /andP[] etau etav.
    eapply EEtaExpanded.isEtaExp_mkApps_intro; auto. solve_all.
Qed.

Lemma isEtaExpFix_env_isEtaExp_env Σ : isEtaExp_env Σ -> EEtaExpanded.isEtaExp_env Σ.
Proof.
  induction Σ; cbn; auto.
  move/andP => [] etaa etaΣ.
  rewrite IHΣ // andb_true_r.
  move: etaa. rewrite /isEtaExp_decl /EEtaExpanded.isEtaExp_decl.
  destruct a.2 => //.
  rewrite /isEtaExp_constant_decl /EEtaExpanded.isEtaExp_constant_decl.
  destruct (cst_body c) => // /=.
  eapply isEtaExpFix_isEtaExp.
Qed.