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

(************************************************************************)
(** * Some properties of the operators on relations                     *)
(************************************************************************)
(** * Initial version by Bruno Barras                                   *)
(************************************************************************)

Require Import Relation_Definitions.
Require Import Relation_Operators.

Section Properties.

  Implicit Arguments clos_refl_trans [A].
  Implicit Arguments clos_refl_trans_1n [A].
  Implicit Arguments clos_refl_trans_n1 [A].
  Implicit Arguments clos_refl_sym_trans [A].
  Implicit Arguments clos_refl_sym_trans_1n [A].
  Implicit Arguments clos_refl_sym_trans_n1 [A].
  Implicit Arguments clos_trans [A].
  Implicit Arguments clos_trans_1n [A].
  Implicit Arguments clos_trans_n1 [A].
  Implicit Arguments inclusion [A].
  Implicit Arguments preorder [A].

  Variable A : Type.
  Variable R : relation A.

  Section Clos_Refl_Trans.

    Local Notation "R *" := (clos_refl_trans R) (at level 8, left associativity).

    (** Correctness of the reflexive-transitive closure operator *)

    Lemma clos_rt_is_preorder : preorder R*.
    Proof.
      apply Build_preorder.
      exact (rt_refl A R).

      exact (rt_trans A R).
    Qed.

    (** Idempotency of the reflexive-transitive closure operator *)

    Lemma clos_rt_idempotent : inclusion (R*)* R*.
    Proof.
      red in |- *.
      induction 1; auto with sets.
      intros.
      apply rt_trans with y; auto with sets.
    Qed.

  End Clos_Refl_Trans.

  Section Clos_Refl_Sym_Trans.

    (** Reflexive-transitive closure is included in the
        reflexive-symmetric-transitive closure *)

    Lemma clos_rt_clos_rst :
      inclusion (clos_refl_trans R) (clos_refl_sym_trans R).
    Proof.
      red in |- *.
      induction 1; auto with sets.
      apply rst_trans with y; auto with sets.
    Qed.

    (** Correctness of the reflexive-symmetric-transitive closure *)

    Lemma clos_rst_is_equiv : equivalence A (clos_refl_sym_trans R).
    Proof.
      apply Build_equivalence.
      exact (rst_refl A R).
      exact (rst_trans A R).
      exact (rst_sym A R).
    Qed.

    (** Idempotency of the reflexive-symmetric-transitive closure operator *)

    Lemma clos_rst_idempotent :
      inclusion (clos_refl_sym_trans (clos_refl_sym_trans R))
      (clos_refl_sym_trans R).
    Proof.
      red in |- *.
      induction 1; auto with sets.
      apply rst_trans with y; auto with sets.
    Qed.

  End Clos_Refl_Sym_Trans.

  Section Equivalences.

  (** *** Equivalences between the different definition of the reflexive,
      symmetric, transitive closures *)

  (** *** Contributed by P. Castéran *)

    (** Direct transitive closure vs left-step extension *)

    Lemma clos_t1n_trans : forall x y, clos_trans_1n R x y -> clos_trans R x y.
    Proof.
     induction 1.
     left; assumption.
     right with y; auto.
     left; auto.
    Qed.

    Lemma clos_trans_t1n : forall x y, clos_trans R x y -> clos_trans_1n R x y.
    Proof.
      induction 1.
      left; assumption.
      generalize IHclos_trans2; clear IHclos_trans2; induction IHclos_trans1.
      right with y; auto.
      right with y; auto.
      eapply IHIHclos_trans1; auto.
      apply clos_t1n_trans; auto.
    Qed.

    Lemma clos_trans_t1n_iff : forall x y,
        clos_trans R x y <-> clos_trans_1n R x y.
    Proof.
      split.
      apply clos_trans_t1n.
      apply clos_t1n_trans.
    Qed.

    (** Direct transitive closure vs right-step extension *)

    Lemma clos_tn1_trans : forall x y, clos_trans_n1 R x y -> clos_trans R x y.
    Proof.
      induction 1.
      left; assumption.
      right with y; auto.
      left; assumption.
    Qed.

    Lemma clos_trans_tn1 :  forall x y, clos_trans R x y -> clos_trans_n1 R x y.
    Proof.
      induction 1.
      left; assumption.
      elim IHclos_trans2.
      intro y0; right with y.
      auto.
      auto.
      intros.
      right with y0; auto.
    Qed.

    Lemma clos_trans_tn1_iff : forall x y,
        clos_trans R x y <-> clos_trans_n1 R x y.
    Proof.
      split.
      apply clos_trans_tn1.
      apply clos_tn1_trans.
    Qed.

    (** Direct reflexive-transitive closure is equivalent to
        transitivity by left-step extension *)

    Lemma clos_rt1n_step : forall x y, R x y -> clos_refl_trans_1n R x y.
    Proof.
      intros x y H.
      right with y;[assumption|left].
    Qed.

    Lemma clos_rtn1_step : forall x y, R x y -> clos_refl_trans_n1 R x y.
    Proof.
      intros x y H.
      right with x;[assumption|left].
    Qed.

    Lemma clos_rt1n_rt : forall x y,
        clos_refl_trans_1n R x y -> clos_refl_trans R x y.
    Proof.
      induction 1.
      constructor 2.
      constructor 3 with y; auto.
      constructor 1; auto.
    Qed.

    Lemma clos_rt_rt1n : forall x y,
        clos_refl_trans R x y -> clos_refl_trans_1n R x y.
    Proof.
      induction 1.
      apply clos_rt1n_step; assumption.
      left.
      generalize IHclos_refl_trans2; clear IHclos_refl_trans2;
        induction IHclos_refl_trans1; auto.

      right with y; auto.
      eapply IHIHclos_refl_trans1; auto.
      apply clos_rt1n_rt; auto.
    Qed.

    Lemma clos_rt_rt1n_iff : forall x y,
      clos_refl_trans R x y <-> clos_refl_trans_1n R x y.
    Proof.
      split.
      apply clos_rt_rt1n.
      apply clos_rt1n_rt.
    Qed.

    (** Direct reflexive-transitive closure is equivalent to
        transitivity by right-step extension *)

    Lemma clos_rtn1_rt : forall x y,
        clos_refl_trans_n1 R x y -> clos_refl_trans R x y.
    Proof.
      induction 1.
      constructor 2.
      constructor 3 with y; auto.
      constructor 1; assumption.
    Qed.

    Lemma clos_rt_rtn1 :  forall x y,
        clos_refl_trans R x y -> clos_refl_trans_n1 R x y.
    Proof.
      induction 1.
      apply clos_rtn1_step; auto.
      left.
      elim IHclos_refl_trans2; auto.
      intros.
      right with y0; auto.
    Qed.

    Lemma clos_rt_rtn1_iff : forall x y,
        clos_refl_trans R x y <-> clos_refl_trans_n1 R x y.
    Proof.
      split.
      apply clos_rt_rtn1.
      apply clos_rtn1_rt.
    Qed.

    (** Induction on the left transitive step *)

    Lemma clos_refl_trans_ind_left :
      forall (x:A) (P:A -> Prop), P x ->
	(forall y z:A, clos_refl_trans R x y -> P y -> R y z -> P z) ->
	forall z:A, clos_refl_trans R x z -> P z.
    Proof.
      intros.
      revert H H0.
      induction H1; intros; auto with sets.
      apply H1 with x; auto with sets.

      apply IHclos_refl_trans2.
      apply IHclos_refl_trans1; auto with sets.

      intros.
      apply H0 with y0; auto with sets.
      apply rt_trans with y; auto with sets.
    Qed.

    (** Induction on the right transitive step *)

    Lemma rt1n_ind_right : forall (P : A -> Prop) (z:A),
      P z ->
      (forall x y, R x y -> clos_refl_trans_1n R y z -> P y -> P x) ->
      forall x, clos_refl_trans_1n R x z -> P x.
      induction 3; auto.
      apply H0 with y; auto.
    Qed.

    Lemma clos_refl_trans_ind_right : forall (P : A -> Prop) (z:A),
      P z ->
      (forall x y, R x y -> P y -> clos_refl_trans R y z -> P x) ->
      forall x, clos_refl_trans R x z -> P x.
      intros P z Hz IH x Hxz.
      apply clos_rt_rt1n_iff in Hxz.
      elim Hxz using rt1n_ind_right; auto.
      clear x Hxz.
      intros x y Hxy Hyz Hy.
      apply clos_rt_rt1n_iff in Hyz.
      eauto.
    Qed.

    (** Direct reflexive-symmetric-transitive closure is equivalent to
        transitivity by symmetric left-step extension *)

    Lemma clos_rst1n_rst  : forall x y,
      clos_refl_sym_trans_1n R x y -> clos_refl_sym_trans R x y.
    Proof.
      induction 1.
      constructor 2.
      constructor 4 with y; auto.
      case H;[constructor 1|constructor 3; constructor 1]; auto.
    Qed.

    Lemma clos_rst1n_trans : forall x y z, clos_refl_sym_trans_1n R x y ->
        clos_refl_sym_trans_1n R y z -> clos_refl_sym_trans_1n R x z.
      induction 1.
      auto.
      intros; right with y; eauto.
    Qed.

    Lemma clos_rst1n_sym : forall x y, clos_refl_sym_trans_1n R x y ->
      clos_refl_sym_trans_1n R y x.
    Proof.
      intros x y H; elim H.
      constructor 1.
      intros x0 y0 z D H0 H1; apply clos_rst1n_trans with y0; auto.
      right with x0.
      tauto.
      left.
    Qed.

    Lemma clos_rst_rst1n  : forall x y,
      clos_refl_sym_trans R x y -> clos_refl_sym_trans_1n R x y.
      induction 1.
      constructor 2 with y; auto.
      constructor 1.
      constructor 1.
      apply clos_rst1n_sym; auto.
      eapply clos_rst1n_trans; eauto.
    Qed.

    Lemma clos_rst_rst1n_iff : forall x y,
      clos_refl_sym_trans R x y <-> clos_refl_sym_trans_1n R x y.
    Proof.
      split.
      apply clos_rst_rst1n.
      apply clos_rst1n_rst.
    Qed.

    (** Direct reflexive-symmetric-transitive closure is equivalent to
        transitivity by symmetric right-step extension *)

    Lemma clos_rstn1_rst : forall x y,
      clos_refl_sym_trans_n1 R x y -> clos_refl_sym_trans R x y.
    Proof.
      induction 1.
      constructor 2.
      constructor 4 with y; auto.
      case H;[constructor 1|constructor 3; constructor 1]; auto.
    Qed.

    Lemma clos_rstn1_trans : forall x y z, clos_refl_sym_trans_n1 R x y ->
      clos_refl_sym_trans_n1 R y z -> clos_refl_sym_trans_n1 R x z.
    Proof.
      intros x y z H1 H2.
      induction H2.
      auto.
      intros.
      right with y0; eauto.
    Qed.

    Lemma clos_rstn1_sym : forall x y, clos_refl_sym_trans_n1 R x y ->
      clos_refl_sym_trans_n1 R y x.
    Proof.
      intros x y H; elim H.
      constructor 1.
      intros y0 z D H0 H1. apply clos_rstn1_trans with y0; auto.
      right with z.
      tauto.
      left.
    Qed.

    Lemma clos_rst_rstn1 : forall x y,
      clos_refl_sym_trans R x y -> clos_refl_sym_trans_n1 R x y.
    Proof.
      induction 1.
      constructor 2 with x; auto.
      constructor 1.
      constructor 1.
      apply clos_rstn1_sym; auto.
      eapply clos_rstn1_trans; eauto.
    Qed.

    Lemma clos_rst_rstn1_iff : forall x y,
      clos_refl_sym_trans R x y <-> clos_refl_sym_trans_n1 R x y.
    Proof.
      split.
      apply clos_rst_rstn1.
      apply clos_rstn1_rst.
    Qed.

  End Equivalences.

End Properties.

(* begin hide *)
(* Compatibility *)
Notation trans_tn1 := clos_trans_tn1 (only parsing).
Notation tn1_trans := clos_tn1_trans (only parsing).
Notation tn1_trans_equiv := clos_trans_tn1_iff (only parsing).

Notation trans_t1n := clos_trans_t1n (only parsing).
Notation t1n_trans := clos_t1n_trans (only parsing).
Notation t1n_trans_equiv := clos_trans_t1n_iff (only parsing).

Notation R_rtn1 := clos_rtn1_step (only parsing).
Notation trans_rt1n := clos_rt_rt1n (only parsing).
Notation rt1n_trans := clos_rt1n_rt (only parsing).
Notation rt1n_trans_equiv := clos_rt_rt1n_iff (only parsing).

Notation R_rt1n := clos_rt1n_step (only parsing).
Notation trans_rtn1 := clos_rt_rtn1 (only parsing).
Notation rtn1_trans := clos_rtn1_rt (only parsing).
Notation rtn1_trans_equiv := clos_rt_rtn1_iff (only parsing).

Notation rts1n_rts := clos_rst1n_rst (only parsing).
Notation rts_1n_trans := clos_rst1n_trans (only parsing).
Notation rts1n_sym := clos_rst1n_sym (only parsing).
Notation rts_rts1n := clos_rst_rst1n (only parsing).
Notation rts_rts1n_equiv := clos_rst_rst1n_iff (only parsing).

Notation rtsn1_rts := clos_rstn1_rst (only parsing).
Notation rtsn1_trans := clos_rstn1_trans (only parsing).
Notation rtsn1_sym := clos_rstn1_sym (only parsing).
Notation rts_rtsn1 := clos_rst_rstn1 (only parsing).
Notation rts_rtsn1_equiv := clos_rst_rstn1_iff (only parsing).
(* end hide *)


(**
Contents
- Binding signatures with associated sytnax
- Derivation of assignments
- Models of a signature and their morphisms
- Syntax as a model
- Initiality
*)

Require Import Arith.
Require Import Basics.
Require Import micromega.Lia.

Open Scope program_scope.
Open Scope list_scope.

Require Import Lib.

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

(* substitution in a model *)
Reserved Notation "x [ s ]" (at level 30).
(* substitution in the syntax *)
Reserved Notation "x [ s ]ₛ" (at level 30).

(* Derivation of substitution *)
Reserved Notation "f ^ ( n )" (at level 30).

(** * Binding signatures with associated syntax
 *)

Record signature :=
  { O  : Type;
    ar : O -> list nat}.

Inductive Z (S : signature) : Type :=
  Var : nat -> Z S
| Op : forall (o : O S), vec (Z S) (ar o) (* this is Z^(length ar) *) -> Z S.

Arguments Op [S] o .
(** Example: the lambda-calculus *)
Inductive LC_O := App | Abs.

Definition LC_sig : signature :=
  {| O := LC_O;
     ar := fun o => match o with
                   App => 0 :: 0 :: nil
                 | Abs => 1 :: nil
                 end
  |}.

Definition LC := Z LC_sig.

Definition LC_app (a : LC)(b : LC) : LC :=
  Op (S := LC_sig) App (a :: b :: NilV)%v.
Definition LC_abs (a : LC) : LC :=
  Op (S := LC_sig) Abs (a :: NilV)%v.

(** * Definition of derivation

 *)

Definition subst_prime {X : Type}(z : X)(lift : X -> X) (f : nat -> X) : nat -> X :=
  fun n => match n with
          0 => z
        | S n => lift (f n)
        end.
(* derivation on substitution using renamings *)
Definition derivₙₛ {X : Type}(var : nat -> X)(ren : (nat -> nat) -> (X -> X))(n : nat) (f : nat -> X)  : nat -> X :=
  Nat.iter n (subst_prime (var 0) (ren S)) f .

(** Alternative definition (not used) *)
Fixpoint derivₙₛ_eq {X : Type}(var : nat -> X)(ren : (nat -> nat) -> (X -> X))
      (ren_ext : forall f g, (forall x, f x = g x ) -> forall x, ren f x = ren g x)
      (ren_id :  forall x, ren id x = x)
      (ren_var : forall f n,  ren f (var n) = var (f n))
      (ren_ren : forall f g n,  ren f (ren g n) = ren (f ∘ g) n)
      (n : nat) (f : nat -> X) p :
      derivₙₛ var ren n f p =
if p <? n then var p else ren (fun x => x + n) (f (p - n)).
Proof.
  unfold derivₙₛ.
  destruct n.
  - cbn.
    rewrite Nat.sub_0_r.

    symmetry.
    etransitivity;[|apply ren_id].
    apply ren_ext.
    apply Nat.add_0_r.
  - unfold subst_prime.
    destruct p.
    + reflexivity.
    + cbn -[leb].
      etransitivity.
      {
        apply( f_equal (ren S)).
        apply derivₙₛ_eq; auto.
      }
      unfold derivₙₛ.
      change (S p <? S n) with (p <? n).
      rewrite <- (commutes_if (ren S)).
      rewrite ren_var .
      rewrite ren_ren.
      unfold compose.
      destruct (p <? n); auto.
Qed.

(* derivation on enamings *)
Definition derivₙ (n : nat) (f : nat -> nat)  : nat -> nat := derivₙₛ (fun n => n)(fun f => f) n f.
(* derivation on substitution using substitution structure *)
Definition derivₛ {X : Type}(var : nat -> X)(subst : (nat -> X) -> (X -> X))(n : nat) (f : nat -> X)  : nat -> X :=
  derivₙₛ var (fun f => subst (fun n => var (f n))) n f.

Fixpoint  s_deriv_deriv
       {X1 : Type}(var1 : nat -> X1)(ren1 : (nat -> nat) -> (X1 -> X1))
       {X2 : Type}(var2 : nat -> X2)(ren2 : (nat -> nat) -> (X2 -> X2))
       {X3 : Type}(var3 : nat -> X3)(ren3 : (nat -> nat) -> (X3 -> X3))
       (s : (nat -> X1) -> X2 -> X3)
       (u : X1 -> X3)
       (uvar : forall n, u (var1 n) = var3 n)
       (svar : forall f n, s f (var2 n) = u (f n))
       (sren : forall f g z,  s f (ren2 g z) = s ( fun n => f (g n)  )z )
       (rens : forall f g z,  ren3 f (s g z) = s ( fun n => ren1 f (g n)  )z )
       f g n m
  :
    s (derivₙₛ var1 ren1 m f) (derivₙₛ var2 ren2 m g n) =
    derivₙₛ var3 ren3 m (fun n0 : nat => s f (g n0)) n.
Proof.
  destruct m as [|m].
  - reflexivity.
  - cbn.
    destruct n as [|n].
    + cbn.
      etransitivity.
      apply svar.
      apply uvar.
    + cbn.
      etransitivity.
      apply sren.
      cbn.
      etransitivity; revgoals.
      {
        apply(f_equal (ren3 S)).
        eapply (s_deriv_deriv _ _ _ _ _ _ _ _ _ s u) ; eassumption.
      }
      symmetry.
      apply rens.
Qed.

Fixpoint derivₙₛ_natural
      {X : Type} (varX : nat -> X) (renX : (nat -> nat) -> (X -> X))
      {Y : Type} (varY : nat -> Y) (renY : (nat -> nat) -> (Y -> Y))
      (g : X -> Y)(gvar : forall n, g (varX n) = varY n)
        (gren : forall f x, g (renX f x) = renY f (g x))
      (n : nat) (f : nat -> X) x :
  g (derivₙₛ varX renX n f x) = derivₙₛ varY renY n (fun n => g (f n)) x.
Proof.
  destruct n as [|n].
  - reflexivity.
  - cbn.
    destruct x; cbn.
    + apply gvar.
    + etransitivity; revgoals.
      {
      apply(f_equal (renY S)).
      eapply (derivₙₛ_natural _ varX renX) ; eassumption.
      }
      apply gren.
Qed.

Lemma derivₙ_id  (p : nat)(n : nat)  :
  derivₙ n (fun x => x) p = p.
  revert p.
  induction n.
  - reflexivity.
  - cbn.
    intro.
    destruct p as [|p].
    + reflexivity.
    + cbn.
      f_equal.
      apply IHn.
Qed.

Fixpoint derivₙₛ_ext_exact {X : Type}(var : nat -> X)(ren ren' : (nat -> nat) -> (X -> X))
      (ren_eq : forall f x, ren f x = ren' f x)
      (n : nat) (f g : nat -> X)
      p
      (fg_eq : p >= n ->  f (p - n) = g (p - n))
      { struct n}
  : derivₙₛ var ren n f p = derivₙₛ var ren' n g p .
Proof.
  destruct n as [|n].
  - cbn.
    rewrite <- minus_n_O in fg_eq.
    apply fg_eq.
    lia.
  - cbn.
    destruct p; cbn.
    + reflexivity.
    + etransitivity.
      apply ren_eq.
      f_equal.
      eapply (derivₙₛ_ext_exact).
      *  assumption.
      *  intros.
         apply fg_eq.
         lia.
Qed.

Lemma derivₙₛ_ext {X : Type}(var : nat -> X)(ren ren' : (nat -> nat) -> (X -> X))
      (ren_eq : forall f x, ren f x = ren' f x)
      (n : nat) (f g : nat -> X)
      p
      (fg_eq : forall q, q + n <= p -> f q = g q)
  : derivₙₛ var ren n f p = derivₙₛ var ren' n g p .
Proof.
  apply derivₙₛ_ext_exact.
  assumption.
  intros.
  apply fg_eq.
  lia.
Qed.

Lemma var_derivₙ
      {X : Type}(var : nat -> X)(ren : (nat -> nat) -> (X -> X))
      (eq_ren : forall f n, ren f (var n) = var (f n))
      (n : nat) (f : nat -> nat) (x : nat) :
  var ((derivₙ n f) x) = derivₙₛ var ren n (fun p => var (f p)) x.
Proof.
  apply derivₙₛ_natural; auto.
Qed.

Lemma derivₙₛ_var {X : Type}(var : nat -> X)ren
      (eq_ren : forall f n, ren f (var n) = var (f n))
      n m : derivₙₛ var ren n var m = var m.
Proof.
    unshelve erewrite <- (var_derivₙ _ _ (fun n => n)).
    + auto.
    + cbn.
      f_equal.
      apply derivₙ_id.
Qed.

Lemma  subst_derivₙₛ
       {X : Type}(var : nat -> X)(ren : (nat -> nat) -> (X -> X))
       (s : (nat -> X) -> (X -> X))
       (* (uvar : forall f n, s f (var n) = var' n) *)
       (svar : forall f n, s f (var n) = f n)
       (sren : forall f g z,  s f (ren g z) = s ( fun n => f (g n)  )z )
       (rens : forall f g z,  ren f (s g z) = s ( fun n => ren f (g n)  )z )
       (* (sext : forall f g, (forall n, f n = g n) -> forall x, s f x = s g x) *)
       (n m : nat)
       (f : nat -> X) (g : nat -> X)   :
  (s (derivₙₛ var ren m f) (derivₙₛ var ren m g n)) =
  (derivₙₛ var ren m (fun n0 : nat => s f (g n0)) n).
Proof.
  apply (s_deriv_deriv (u := id)); auto.
Qed.
Lemma derivₙₛ_derivₙ {X : Type}(var : nat -> X)(ren : (nat -> nat) -> (X -> X))(n m : nat) (f : nat -> X)
      (g : nat -> nat) :
  derivₙₛ var ren n f (derivₙ n g m) = derivₙₛ var ren n (fun n0 : nat => f (g n0)) m.
Proof.
  apply (s_deriv_deriv (s := id)(u := id)); auto.
Qed.

Lemma ren_derivₙ_derivₙₛ
      {X : Type}
      (var : nat -> X)
      (ren : (nat -> nat) -> (X -> X))(m n : nat) (f : nat -> X)(g : nat -> nat)
      (eq_ren : forall f n, ren f (var n) = var (f n))
      (ren_ren : forall f g x, ren f (ren g x) = ren (fun n => f (g n)) x)  :
      (* (ren_ext : forall f g , (forall x, f x = g x) -> forall x, ren f x = ren g x) : *)
  ren (derivₙ n g) (derivₙₛ var ren n f m) = derivₙₛ var ren n (fun n0 : nat => ren g (f n0)) m.
  Proof.
    eapply (s_deriv_deriv ); auto.
  Qed.

Lemma derivₛ_eq {X : Type}(var : nat -> X)
      (ren : (nat -> nat) -> (X -> X))
      (s : (nat -> X) -> (X -> X))
      (ren_eq : forall f x, ren f x = s (var ∘ f) x)
      (n : nat) (f : nat -> X)
      p
  : derivₛ var s n f p = derivₙₛ var ren n f p .
Proof.
  apply derivₙₛ_ext.
  - symmetry; apply ren_eq.
  - reflexivity.
Qed.

(** * Models of a signature and their morphisms *)

Section binding_condition.

  Context
    {X : Type}
    (var : nat -> X)
    (s : (nat -> X) -> X -> X).

  (* Notations (local to this section) *)
  Notation "x [ f ]" := (s f x).
  Notation "f ^ ( n )" := (derivₛ var s n f).

  Definition binding_condition
           (a : list nat) (op : vec X a -> X) :=
  forall (f : nat -> X)(v : vec X a),
    op v [ f ] = op (vec_map (fun n x => x [ f ^ ( n )]) v).

End binding_condition.

Record model_data (S : signature) :=
  { carrier :> Type;
    variables : nat -> carrier;
    ops : forall (o : O S), vec carrier (ar o) -> carrier;
    substitution : (nat -> carrier) -> (carrier -> carrier)
  }.

Arguments ops [S m] o.
Notation "x [ s ]" := (substitution s x).
Notation "f ^ ( n )" := (derivₛ (variables _) (substitution (m := _)) n f) .

(* In every model of lambda calculus, we have an app and abs operation *)
Definition app (m : model_data LC_sig) (a : m)(b : m) : m :=
  ops (S := LC_sig) App (a :: b :: NilV)%v.
Definition abs (m : model_data LC_sig)(a : m) : m :=
  ops (S := LC_sig) Abs (a :: NilV)%v.

Record is_model {S : signature}(m : model_data S) :=
  {
    (* fun ext for substitution *)
    substitution_ext : forall (f g : nat -> m),  (forall n, f n = g n) -> forall x,
                                    x [ f ] = x [ g ] ;
    variables_subst : forall x f, (variables m x) [ f ] = f x;
    (* operations are module morphisms *)
    ops_subst :
      forall (o : O S), binding_condition (variables m) (substitution (m := m))
                                     (ops o)
              ;
    (* additionnal laws (not needed for initiality) : associativity of substitution *)
    assoc : forall (f g : nat -> m) (x : m),
        x [ g ] [ f ] = x [ (fun n => (g n) [ f ]) ] ;

    id_neutral : forall (x : m), x [ variables m ] = x
  }.

Record model (S : signature) :=
  { mod_carrier :> model_data S;
    mod_laws : is_model mod_carrier
  }.

(** not used *)
Lemma derivₙₛ_in_model {S}{X : model S}(f : nat -> X) n p :
      f ^(n) p = if p <? n then variables X p else f (p - n) [fun x => variables X (x + n)] .

Proof.
  apply derivₙₛ_eq.
  - intros.
    apply substitution_ext; [apply mod_laws|].
    auto.
  - intros.
    apply id_neutral ; apply mod_laws.
  - intros.
    cbn.
    refine (variables_subst (mod_laws X) _ _).
  - intros.
    etransitivity.
    apply assoc ; apply mod_laws.
    apply substitution_ext; [apply mod_laws|].
    intro.
    refine (variables_subst (mod_laws X) _ _).
Qed.

Record is_model_mor
       {S : signature} (X : model_data S) (Y : model_data S)
       (u : X -> Y) :=
  {
    variables_mor : forall n, u (variables X n) = variables Y n ;
    substitution_mor : forall (f : nat -> X) (x : X), u (x [ f ]) =
                                              (u x) [ u ∘ f ];
    ops_mor : forall (o : O S)(v : vec X (ar o)), u (ops o v) =
                                             ops o (vec_map (fun _ => u) v)
  }.

Record model_mor {S : signature} (X : model_data S) (Y : model_data S) :=
  { mor_carrier :> X -> Y ;
    mor_laws : is_model_mor mor_carrier
  }.

(* model morphisms compose *)
Lemma is_model_mor_compose
       {S : signature} (X : model_data S) (Y Z : model_data S)
       (u : X -> Y)(v : Y -> Z)
       (um : is_model_mor u)(vm : is_model_mor v) :
  is_model_mor (v ∘ u).
Proof.
  unfold compose.
  split; cbn; intros.
  - rewrite 2 variables_mor; auto.
  - rewrite 2 substitution_mor; auto.
  - rewrite 2 ops_mor; auto.
    f_equal.
    apply vec_map_map.
Qed.

(** * Syntax as a model *)

(** Renaming *)
Fixpoint Z_ren {S : signature}  (f : nat -> nat) (x : Z S) {struct x} : Z S :=
  match x with
    Var _ n => Var _ (f n)
  | Op op  v => Op op (vec_map (fun n b => (Z_ren (derivₙ n f) b))  v)
  end.

(** Substitution *)
Fixpoint Z_subst {S : signature}  (f : nat -> Z S) (x : Z S) : Z S :=
  match x with
    Var _ n => f n
  | Op op v => Op op
                 (vec_map
                    (fun n b =>
                       (b [ derivₙₛ (Var S) Z_ren n f ]ₛ)
                    ) v)
  end
    where "t [ f ]ₛ" := (Z_subst f t).

Definition Z_model_data (S : signature) : model_data S :=
  {|
  carrier := Z S;
  variables := Var S;
  ops := @Op S;
  substitution := Z_subst
 |}.

Fixpoint Z_subst_ext {S}(f g : nat -> Z S) (eq : forall n, f n = g n) x :
  x [ f ]ₛ = x [ g ]ₛ.
Proof.
  destruct x.
  - cbn; apply eq.
  - cbn.
    f_equal.
    apply vec_map_ext.
    intros.
    apply Z_subst_ext.
    intro.
    eapply derivₙₛ_ext.
    + reflexivity.
    + intros; apply eq.
Defined.

Fixpoint Z_ren_subst_eq {S} (f : nat -> nat) (x : Z S) :
  Z_ren f x = x [ fun n => Var S (f n) ]ₛ.
Proof.
  destruct x.
  - reflexivity.
  - cbn.
    f_equal.
    apply vec_map_ext.
    intros.
    rewrite Z_ren_subst_eq.
    cbn.
    apply Z_subst_ext.
    intro.
    apply var_derivₙ.
    reflexivity.
Qed.

(* Uniqueness of the renamings *)
Fixpoint ZModel_unique_ren (S : signature) (s : (nat -> Z S) -> Z S -> Z S)
      (s_var : forall (f : nat -> Z S) n, s f (Var S n) = f n)
      (s_ops : forall (o : O S), binding_condition (Var S) s (Op o))
      (s_ext : forall (f g : nat -> Z S), (forall n, f n = g n) -> forall x, s f x = s g x)
      f z {struct z} :
    s (fun n => Var S (f n)) z = Z_ren f z.
Proof.
  intros.
  destruct z.
  - apply s_var.
  - etransitivity.
    apply s_ops.
    cbn.
    f_equal.
    apply vec_map_ext.
    intros.
    etransitivity ; revgoals.
    apply (ZModel_unique_ren S s s_var s_ops s_ext) .
    apply s_ext.
    intro n.
    cbn.
    symmetry.
    apply var_derivₙ.
    intros.
    refine (s_var _ _).
Qed.

(* Uniqueness of the substitution *)
Fixpoint ZModel_unique_subst (S : signature) (s : (nat -> Z S) -> Z S -> Z S)
      (s_var : forall (f : nat -> Z S) n, s f (Var S n) = f n)
      (s_ops : forall (o : O S), binding_condition (Var S) s (Op o))
      (s_ext : forall (f g : nat -> Z S), (forall n, f n = g n) -> forall x, s f x = s g x)
       f z {struct z} :
    s f z = z [ f ]ₛ.
Proof.
  intros.
  destruct z.
  - apply s_var.
  - etransitivity.
    apply s_ops.
    cbn.
    f_equal.
    apply vec_map_ext.
    intros.
    etransitivity.
    apply (ZModel_unique_subst _ _ s_var s_ops s_ext).
    apply Z_subst_ext.
    intro n.
    apply derivₙₛ_ext.
    + apply (ZModel_unique_ren s_var s_ops s_ext).
    + reflexivity.
Qed.

Fixpoint Z_ren_subst {S : signature} g f (z : Z S) :
Z_ren g z [ f ]ₛ = z [ fun n => f (g n)  ]ₛ.
Proof.
  destruct z.
  - reflexivity.
  - cbn.
    f_equal.
    rewrite vec_map_map.
    apply vec_map_ext.
    intros.
    cbn.
    etransitivity;[apply Z_ren_subst|].
    apply Z_subst_ext.
    intro n.
    apply derivₙₛ_derivₙ.
Qed.

Lemma Z_ren_ren {S : signature} g f (z : Z S) :
Z_ren g (Z_ren f z) = Z_ren (g ∘ f) z.
  rewrite Z_ren_subst_eq at 1.
  rewrite Z_ren_subst.
  symmetry.
  apply Z_ren_subst_eq.
Qed.

Fixpoint Z_subst_ren {S : signature} g f (z : Z S) :
Z_ren g (z [ f ]ₛ) = z [ fun n => Z_ren g (f n)  ]ₛ.
Proof.
  destruct z.
  - reflexivity.
  - cbn.
    f_equal.
    rewrite vec_map_map.
    apply vec_map_ext.
    intros.
    cbn.
    etransitivity;[apply Z_subst_ren|].
    apply Z_subst_ext.
    intro n.
    apply ren_derivₙ_derivₙₛ.
    + reflexivity.
    + intros. apply Z_ren_ren.
Qed.

Fixpoint Z_subst_subst {S : signature}
      (f g : nat -> Z S) (x : Z S) :
  (x [g]ₛ) [f]ₛ = x [fun n : nat => g n [f]ₛ]ₛ.
Proof.
  destruct x.
  - reflexivity.
  - cbn.
    f_equal.
    rewrite vec_map_map.
    apply vec_map_ext.
    intros.
    cbn.
    etransitivity;[apply Z_subst_subst|].
    apply Z_subst_ext.
    intro n.
    cbn.
    (* ca devrait marcher *)
    apply subst_derivₙₛ.
    + reflexivity.
    + intros. apply Z_ren_subst.
    + intros. apply Z_subst_ren.
Qed.

Fixpoint Z_subst_id {S} (z : Z S) : z [Var S ]ₛ = z.
  destruct z.
  - reflexivity.
  - cbn.
    f_equal.
    etransitivity;[|apply vec_map_id].
    apply vec_map_ext.
    intros.
    etransitivity;[|apply Z_subst_id].
    apply Z_subst_ext.
    intro n.
    apply derivₙₛ_var.
    reflexivity.
Qed.

Lemma Z_model_laws (S : signature) : is_model (Z_model_data S).
Proof.
  repeat split.
  - exact Z_subst_ext.
  - intros o v f.
    cbn.
    f_equal.
    apply vec_map_ext.
    intros.
    apply Z_subst_ext.
    intro.
    symmetry.
    apply derivₛ_eq.
    intros.
    rewrite Z_ren_subst_eq.
    reflexivity.
  - apply Z_subst_subst.
  - apply Z_subst_id.
Qed.

Definition ZModel (S : signature) : model S :=
  {| mod_carrier := Z_model_data S; mod_laws := Z_model_laws S |}.

(** * Initial morphism from the syntax *)

Fixpoint ini_mor {S : signature} (m : model_data S )(x : Z S) : m :=
  match x with
        Var _ n => variables _ n
      | Op o v   => ops o (vec_map (fun _ => ini_mor m) v)
  end.

(* the initial morphism preserves renaming *)
Fixpoint ini_mor_ren { S : signature}(m : model S)(f : nat -> nat) (x : Z S) :
  ini_mor m (Z_ren f x) = (ini_mor m x) [ variables m ∘ f ].
  destruct x as [n|o v].
  - cbn.
    rewrite (variables_subst (mod_laws m)).
    reflexivity.
  - cbn -[leb].
    rewrite (ops_subst (mod_laws m)).
    repeat rewrite vec_map_map.
    cbn -[leb].
    apply f_equal.
    induction v.
    + reflexivity.
    + cbn -[leb].
      f_equal; revgoals.
      * exact IHv.
      * cbn -[leb].
        rewrite ini_mor_ren.
        cbn -[leb].
        apply (substitution_ext (mod_laws m)).
        intro n.
        unfold compose.
        apply var_derivₙ.
        cbn.
        intros.
        rewrite (variables_subst (mod_laws m)).
        reflexivity.
Defined.

(* the initial morphism preserves substitution *)
Fixpoint ini_mor_subst {S : signature}(m : model S)(f : nat -> Z S) (x : Z S) :
  (* ini_mor m (x [ f ]ₛ) = (ini_mor m x) [fun y => ini_mor m (f y)]. *)
  ini_mor m (x [ f ]ₛ) = (ini_mor m x) [ ini_mor m ∘ f].
  destruct x as [n|o v].
  - cbn.
    rewrite (variables_subst (mod_laws m)).
    reflexivity.
  - cbn -[leb].
    rewrite (ops_subst (mod_laws m)).
    repeat rewrite vec_map_map.
    cbn -[leb].
    apply f_equal.
    induction v.
    + reflexivity.
    + cbn -[leb].
      f_equal; revgoals.
      * exact IHv.
      * rewrite ini_mor_subst.
        apply (substitution_ext (mod_laws m)).
        intro n.
        unfold compose.
        apply derivₙₛ_natural.
        -- reflexivity.
        -- intros.
           apply ini_mor_ren.
Qed.

Lemma ini_mor_is_model_mor {S : signature}(m : model S) : is_model_mor (X := ZModel S) (ini_mor m).
Proof.
  split; auto.
  apply ini_mor_subst.
Qed.

Program Definition initial_morphism {S : signature}(m : model S) : model_mor (ZModel S) m :=
  {|
  mor_carrier := ini_mor m;
  mor_laws := ini_mor_is_model_mor m
  |}.

Fixpoint initial_morphism_unique {S : signature}(m : model_data S)
         (f : (ZModel S) -> m) (hf : is_model_mor f)
     x : f x = ini_mor m x.
Proof.
  destruct x.
  - apply (variables_mor hf ).
  - etransitivity.
    apply (ops_mor hf).
    cbn.
    f_equal.
    apply vec_map_ext.
    intros.
    apply initial_morphism_unique.
    assumption.
Qed.

Corollary initial_morphism_unique' {S : signature}(m : model_data S)
         (f : model_mor (ZModel S) m)
         x : f x = ini_mor m x .
  exact (initial_morphism_unique f.(mor_laws) x).
Qed.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  An attempt at a full context model, no modules.

*)

(* TODO v-> k hunt. *)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import Coq.Init.Logic.
Require Import Coq.Bool.Bool.

Require Export CpdtTactics.
Require Export Case.
Require Export TacticNotations.

Set Implicit Arguments.

Lemma beq_nat_sym : forall (n m : nat),
                      beq_nat n m = beq_nat m n.
Proof.
  apply NPeano.Nat.eqb_sym.
Qed.

(* Why is this not in a standard library? *)
Lemma beq_nat_trans :
  forall n1 n2 n3,
    beq_nat n1 n2 = true ->
    beq_nat n2 n3 = true ->
    beq_nat n1 n3 = true.
Proof.
  induction n1; destruct n2;
  induction n3; simpl; auto. intros. inversion H.
  apply IHn1.
Qed.

Inductive TVar : Type :=
 | tvar   : nat -> TVar.

Function beq_tvar (x y : TVar) : bool :=
   match x, y with
     | (tvar x'), (tvar y') => beq_nat x' y'
  end.

Lemma beq_tvar_refl:
 forall (alpha : TVar),
   beq_tvar alpha alpha = true.
Proof.
  intros.
  destruct alpha.
  unfold beq_tvar.
  apply eq_sym.
  apply beq_nat_refl.
Qed.
Hint Resolve beq_tvar_refl.

Lemma beq_tvar_sym : forall x y : TVar, beq_tvar x y = beq_tvar y x.
Proof.
  intros.
  destruct x.
  destruct y.
  unfold beq_tvar.
  rewrite beq_nat_sym.
  reflexivity.
Qed.
Hint Immediate beq_tvar_sym.

Lemma beq_tvar_trans :
  forall x y z,
    beq_tvar x y = true -> beq_tvar y z = true -> beq_tvar x z = true.
Proof.
   destruct x.
   destruct y.
   destruct z.
   apply beq_nat_trans.
Qed.
Hint Resolve beq_tvar_trans.

Lemma beq_tvar_eq:
  forall (alpha beta : TVar),
    beq_tvar alpha beta = true ->
    alpha = beta.
Proof.
  destruct alpha.
  destruct beta.
  simpl.
  intros.
  symmetry in H.
  apply beq_nat_eq in H.
  rewrite H.
  reflexivity.
Qed.
Hint Resolve beq_tvar_eq.

Lemma beq_tvar_neq:
  forall (alpha beta : TVar),
    beq_tvar alpha beta = false ->
    alpha <> beta.
Proof.
  intros.
  case_eq (beq_tvar alpha beta).
  intros.
  destruct alpha; destruct beta.
  unfold beq_tvar in H.
  unfold beq_tvar in H0.
  apply beq_nat_false in H.
  congruence.
  intros.
  destruct alpha; destruct beta.
  unfold beq_tvar in H.
  fold beq_tvar in H.
  apply beq_nat_false in H.
  congruence.
Qed.
Hint Resolve beq_tvar_neq.

Inductive Tau : Type :=
 | tv_t   : TVar -> Tau
 | cint   : Tau
 | cross  : Tau -> Tau -> Tau.

Tactic Notation "Tau_ind_cases" tactic(first) ident(c) :=
 first;
[ Case_aux c "(tv_t t)"
| Case_aux c "cint"
| Case_aux c "(cross t t0)"
].

(* Todo  *)
Function beq_tau (t t' : Tau) : bool :=
 match t, t' with
 | tv_t alpha, tv_t beta => beq_tvar alpha beta
 | cint, cint => true
 | (cross t0 t1), (cross t0' t1') => andb (beq_tau t0 t0') (beq_tau t1 t1')
 | _ , _ => false
end.

Lemma beq_tau_refl:
 forall (t : Tau),
   beq_tau t t = true.
Proof.
  intros.
  induction t; crush.
Qed.
Hint Resolve beq_tau_refl.

Lemma beq_tau_sym : forall x y, beq_tau x y = beq_tau y x.
Proof.
  induction x; induction y; try solve [crush].
Qed.
Hint Immediate beq_tau_sym.

Lemma beq_tau_trans :
  forall x y z,
    beq_tau x y = true -> beq_tau y z = true -> beq_tau x z = true.
Proof.
  induction x; induction y; induction z; intros; try solve [inversion H]; try solve [inversion H0].
  inversion H. inversion H0.
  crush.
  apply beq_tvar_trans with (x:= t) (y:= t0) (z:= t1) in H2; try assumption.
  reflexivity.
  unfold beq_tau.
  fold beq_tau.
  unfold beq_tau in H.
  fold beq_tau in H.
  unfold beq_tau in H0.
  fold beq_tau in H0.
  apply andb_true_iff in H.
  apply andb_true_iff in H0.
  inversion H.
  inversion H0.
  apply andb_true_iff.
  apply IHx1 with (z:= z1)in H1; try assumption.
  apply IHx2 with (z:= z2)in H2; try assumption.
  split; try assumption.
Qed.
Hint Resolve beq_tau_trans.

Lemma beq_tau_eq:
  forall t0 t1, beq_tau t0 t1 = true -> t0 = t1.
Proof.
  induction t0; induction t1; intros; try solve [inversion H].
  inversion H.
  apply beq_tvar_eq in H1.
  rewrite H1.
  reflexivity.
  reflexivity.
  clear IHt1_1.
  clear IHt1_2.
  unfold beq_tau in H.
  fold beq_tau in H.
  apply andb_true_iff in H.
  inversion H.
  apply IHt0_1 in H0.
  apply IHt0_2 in H1.
  subst.
  reflexivity.
Qed.

Lemma beq_tau_neq:
  forall t0 t1, beq_tau t0 t1 = false -> t0 <> t1.
Proof.
  induction t0; induction t1; intros; try solve [inversion H]; try solve [discriminate].
  apply beq_tvar_neq in H.
  crush.
  unfold beq_tau in H.
  fold beq_tau in H.
  apply andb_false_iff in H.
  destruct H.
  apply IHt0_1 in H.
  crush.
  apply IHt0_2 in H.
  crush.
Qed.

Definition K    := TVar.
Definition K_eq := beq_tvar.
Definition T    := Tau.
Definition T_eq := beq_tau.

Inductive Context (K : Type) (T : Type) : Type :=
| Ctxt_dot  : Context K T
| Ctxt      : K -> T -> Context K T -> Context K T.

Tactic Notation "Context_ind_cases" tactic(first) ident(c) :=
 first;
[ Case_aux c "(Ctxt_dot K T)"
| Case_aux c "(Ctxt k t c)"
].

Definition empty  := Ctxt_dot K T.

Function add (c : Context K T) (k: K) (t : T)  : Context K T :=
  match c with
    | Ctxt_dot => (Ctxt k t (Ctxt_dot K T))
    | (Ctxt k' t' c') =>
      match K_eq k k' with
        | true  => (Ctxt k  t  c')
        | false => (Ctxt k' t' (add c' k t))
      end
  end.

Function map (c : Context K T) (k: K) : option T :=
  match c with
    | Ctxt_dot => None
    | (Ctxt k' t' c') =>
      match K_eq k k' with
        | true  => Some t'
        | false => (map c' k)
      end
  end.

Function nodup (c : (Context K T)) : bool :=
  match c with
    | Ctxt_dot => true
    | (Ctxt k' t' c') =>
      match map c' k' with
        | Some t  => false
        | None  => nodup c'
      end
end.

Function extends (c c' : Context K T) : bool :=
  match c with
    | Ctxt_dot => true
    | Ctxt k t c'' =>
      match map c' k with
       | Some t' =>
         match (T_eq t t') with
           | true => extends c'' c'
           | false => false
         end
       | None => false
      end
  end.

Function equal (c c' : Context K T) : bool :=
  andb (extends c c') (extends c' c).

Lemma map_empty_none: forall k, map empty k = None.
Proof.
  crush.
Qed.

Lemma nodup_empty: nodup empty = true.
Proof.
  crush.
Qed.

Lemma map_add: forall c k t, map (add c k t) k = Some t.
Proof.
  intros.
  induction c.
  Case "Ctxt_dot".
   crush.
   rewrite beq_tvar_refl.
   reflexivity.
  Case "(Ctxt k0 t0 c)".
   crush.
   case_eq (K_eq k k0).
   SCase "K_eq k k0 = true".
    intros.
    unfold map.
    rewrite beq_tvar_refl.
    reflexivity.
   SCase "K_eq k k0 = false".
    intros.
    unfold map.
    rewrite H.
    fold map.
    assumption.
Qed.

Lemma map_agreement:
  forall c k t,
    nodup c = true ->
    map c k = Some t ->
    forall t',
      map c k = Some t' ->
      t = t'.
Proof.
 intros.
 induction c; crush.
Qed.

Lemma map_some_none_neq:
  forall c k k',
    map c k  = None ->
    forall t,
      map c k' = Some t ->
      k <> k'.
Proof.
  induction c; crush.
Qed.

Lemma empty_extended_by_all:
  forall c,
    extends empty c = true.
Proof.
  crush.
Qed.

Lemma empty_extends_only_empty:
  forall c,
    extends c empty = true ->
    c = empty.
Proof.
  intros.
  induction c; crush.
Qed.

Lemma extends_r_strengthen:
  forall c c',
    extends c c' = true ->
    forall v t,
      nodup (Ctxt v t c') = true ->
      extends c (Ctxt v t c') = true.
Proof.
  intros c c'.
  functional induction (extends c c'); try solve[crush].
  intros.
  apply IHb with (v:= v) (t:= t0) in H.
  unfold extends.
  fold extends.
  case_eq(map (Ctxt v t0 c') k); intros.
  case_eq(T_eq t t1); intros; try assumption.
  pose proof H0 as H0'.
  unfold map in H1.
  fold map in H1.
  case_eq(K_eq k v); intros; try rewrite H3 in H1.
  move t1 before t.
  unfold nodup in H0.
  fold nodup in H0.
  apply beq_tvar_eq in H3.
  rewrite <- H3 in H0.
  rewrite e0 in H0.
  inversion H0.
  rewrite e0 in H1.
  crush.

  pose proof H1 as H1'.
  unfold map in H1.
  fold map in H1.
  case_eq(K_eq k v); intros; rewrite H2 in H1.
  inversion H1.
  rewrite e0 in H1.
  inversion H1.
  assumption.
Qed.

Lemma extends_refl:
  forall c,
    nodup c = true ->
    extends c c = true.
Proof.
  intros.
  induction c; try solve [crush].
  unfold extends.
  fold extends.
  simpl.
  rewrite beq_tvar_refl.
  rewrite beq_tau_refl.
  apply extends_r_strengthen; try assumption.
  unfold nodup in H.
  fold nodup in H.
  case_eq(map c k); intros; rewrite H0 in H.
  inversion H.
  apply IHc in H.
  assumption.
Qed.

Lemma extends_l_weaken:
  forall c c' k,
    extends c c' = true ->
    forall t,
      map c' k = Some t ->
      extends (Ctxt k t c) c' = true.
Proof.
  intros.
  unfold extends.
  fold extends.
  unfold map.
  fold map.
  rewrite H0.
  rewrite beq_tau_refl.
  assumption.
Qed.

Lemma extends_l_weaken_r_strengthen:
  forall c c' k,
    extends c c' = true ->
    map c' k = None  ->
    forall t,
      nodup c' = true ->
      extends (Ctxt k t c) (Ctxt k t c') = true.
Proof.
  intros.
  unfold extends.
  fold extends.
  unfold map.
  fold map.
  rewrite beq_tvar_refl.
  rewrite beq_tau_refl.

  apply extends_r_strengthen; try assumption.
  unfold nodup.
  fold nodup.
  rewrite H0.
  assumption.
Qed.

Lemma extends_l_strengthen:
  forall c c' k t,
    extends (Ctxt k t c) c' = true -> extends c c' = true.
Proof.
  intros.
  induction c; try solve[crush].
  unfold extends in H.
  fold extends in H.
  unfold extends.
  fold extends.
  case_eq(map c' k); intros; rewrite H0 in *;  case_eq(map c' k0); intros; try rewrite H1 in *; try inversion H; case_eq(T_eq t t1); intros; try rewrite H2 in *; try inversion H.
  case_eq(T_eq t0 t2); intros; rewrite H4 in *; try inversion H; reflexivity.
Qed.

Lemma map_extends_none_agreement:
  forall c c',
   extends c c' = true ->
   forall v,
     map c' v = None ->
     map c v  = None.
Proof.
  intros c c' ext.
  functional induction (extends c c'); try solve [crush].
  intros.
  apply IHb with (v:= v) in ext; try assumption.
  unfold map.
  fold map.
  case_eq (K_eq v k); intros.
  apply beq_tvar_eq in H0.
  subst.
  rewrite e0 in H.
  inversion H.
  assumption.
Qed.

Lemma equal_empty_empty:
  forall c,
    equal empty c = true ->
    c = empty.
Proof.
  intros.
  induction c; crush.
Qed.

Lemma K_eq_sym:  forall k k', K_eq k k' = K_eq k' k.
Proof.
  apply beq_tvar_sym.
Qed.

Lemma map_r_strengthen_context:
  forall c k0 t0 k t,
    map (Ctxt k0 t0 c) k = Some t ->
    K_eq k0 k = false ->
    map c k = Some t.
Proof.
  intros.
  unfold map in H.
  fold map in H.
  rewrite K_eq_sym in H0.
  rewrite H0 in H.
  assumption.
Qed.

Lemma map_r_strengthen_add:
  forall c k0 t0 k t,
    map (add c k0 t0) k = Some t ->
    K_eq k k0 = false ->
    map c k = Some t.
Proof.
  intros.
  induction c.
  unfold add in H.
  unfold map in H.
  rewrite H0 in H.
  inversion H.

  unfold map.
  fold map.
  unfold add in H.
  fold add in H.
  case_eq(K_eq k0 k1); case_eq(K_eq k k1); intros; rewrite H2 in H.
  apply beq_tvar_trans with (x:= k) in H1.
  apply beq_tvar_eq in H1.
  subst.
  rewrite beq_tvar_sym in H0.
  apply beq_tvar_eq in H2.
  subst.
  rewrite beq_tvar_refl in H0.
  inversion H0.

  apply beq_tvar_refl.
  unfold map in H.
  fold map in H.
  rewrite H0 in H.
  assumption.

  unfold map in H.
  fold map in H.
  rewrite H1 in H.
  assumption.

  unfold map in H.
  fold map in H.
  rewrite H1 in H.
  apply IHc in H.
  assumption.
Qed.

Lemma nodup_add_none:
  forall c,
    nodup c = true ->
    forall k,
     map c k = None  ->
    forall t,
      nodup (add c k t) = true.
Proof.
  induction c; try solve [crush].
  intros.
  unfold nodup in H.
  fold nodup in H.
  case_eq (map c k); intros; rewrite H1 in H; try inversion H.
  unfold map in H0.
  fold map in H0.
  case_eq (K_eq k0 k); intros; rewrite H2 in H0.
  inversion H0.
  unfold add.
  fold add.
  rewrite H2.
  unfold nodup.
  fold nodup.
  rewrite H3.
  case_eq (map (add c k0 t0) k); intros.
  apply map_r_strengthen_add in H4; try assumption.
  rewrite H4 in H1.
  inversion H1.
  apply IHc with (k:= k0) (t:= t0) in H; try assumption.
  rewrite beq_tvar_sym in H2; try assumption.
  apply IHc with (k:= k0) (t:= t0) in H; try assumption.
Qed.

(* Perhaps I want this someday too. *)
(*
Lemma nodup_add_some:
  forall c,
    nodup c = true ->
    forall k t,
     map c k = Some t  ->
    forall t',
      nodup (add c k t') = true.
*)

Lemma map_extension_disagreement_absurd:
  forall c c',
    extends c c' = true ->
    forall v t,
      map c v  = Some t ->
      map c' v = None ->
      False.
Proof.
  intros c c' ext.
  functional induction (extends c c'); try solve [crush].
  intros.
  apply IHb with (v:= v) (t:= t0) in ext; try assumption.
  unfold map in H.
  fold map in H.
  case_eq(K_eq v k); intros; rewrite H1 in H; try assumption.
  apply beq_tvar_eq in H1.
  subst.
  rewrite e0 in H0.
  inversion H0.
Qed.

Lemma map_add_recursion:
  forall c k t k',
    map (add c k' t) k = Some t ->
    K_eq k k' = false ->
    map c k = Some t.
Proof.
  intros.
  induction c.
  simpl in H.
  rewrite H0 in H.
  inversion H.
  unfold map.
  fold map.
  case_eq(K_eq k k0); intros.
  apply beq_tvar_eq in H1.
  subst.
  unfold add in H.
  fold add in H.
  rewrite K_eq_sym in H0.
  rewrite H0 in H.
  unfold map in H.
  fold map in H.
  rewrite beq_tvar_refl in H.
  assumption.
  unfold add in H.
  fold add in H.
  case_eq(K_eq k' k0); intros; rewrite H2 in H.
  unfold map in H.
  fold map in H.
  rewrite H0 in H.
  assumption.
  unfold map in H.
  fold map in H.
  rewrite H1 in H.
  apply IHc in H.
  assumption.
Qed.

Lemma extends_r_weaken:
  forall c c' k t,
    extends c (Ctxt k t c') = true ->
    nodup (Ctxt k t c') = true ->
    map c k = None ->
    extends c c' = true.
Proof.
  intros.
  induction c; try solve[crush].
  unfold extends in H.
  fold extends in H.
  unfold extends.
  fold extends.
  case_eq(map c' k0); intros;
  case_eq(map (Ctxt k t c') k0); intros; rewrite H3 in H; try solve[inversion H];
  case_eq(T_eq t0 t1); intros; try rewrite H4 in *; try solve[inversion H].
  case_eq(T_eq t0 t2); intros; rewrite H5 in H; try solve[inversion H].
  unfold map in H1.
  fold map in H1.
  case_eq(K_eq k k0); intros; rewrite H6 in H1; try inversion H1.
  apply IHc in H; try assumption.
  case_eq(T_eq t0 t2); intros; rewrite H5 in H; try solve[inversion H].
  apply beq_tau_eq in H5.
  subst.
  unfold map in H3.
  fold map in H3.
  unfold map in H1.
  fold map in H1.
  case_eq(K_eq k0 k); intros.
  rewrite K_eq_sym in H1.
  rewrite H5 in *.
  inversion H1.
  rewrite K_eq_sym in H1.
  rewrite H5 in *.
  apply beq_tau_neq in H4.
  rewrite H2 in H3.
  inversion H3.
  crush.
  apply beq_tau_eq in H4.
  subst.
  unfold map in H3.
  fold map in H3.
  unfold map in H1.
  fold map in H1.
  case_eq(K_eq k0 k); intros.
  rewrite K_eq_sym in H1.
  rewrite H4 in *.
  inversion H1.
  rewrite K_eq_sym in H1.
  rewrite H4 in *.
  rewrite H2 in H3.
  inversion H3.
Qed.

Lemma map_disagreement_absurd:
  forall c k t,
    nodup c = true ->
    map c k = Some t ->
    forall k' t',
    map (Ctxt  k' t' c) k = None ->
  False.
Proof.
  intros.
  assert (Z: extends c (Ctxt k' t' c) = true).
  assert (Y: extends c c = true).
  apply extends_refl; try assumption.
  apply extends_r_strengthen with (v:= k') (t:= t') in Y; try assumption.
  unfold nodup.
  fold nodup.
  case_eq(map c k'); intros; try assumption.
  unfold map in H1.
  fold map in H1.
  case_eq(K_eq k k'); intros; rewrite H3 in H1; try solve [inversion H1].
  rewrite H1 in H0.
  inversion H0.
  apply map_extension_disagreement_absurd with (v:= k) (t:= t) in Z; try assumption.
Qed.

Lemma map_add_disagreement_absurd:
  forall c k t,
    map c k = Some t ->
    forall k' t',
    map (add c k' t') k = None ->
  False.
Proof.
  intros c.
  induction c; try solve [crush].
  intros.
  unfold map in H.
  fold map in H.
  unfold add in H0.
  fold add in H0.
  case_eq(K_eq k0 k); case_eq(K_eq k' k); intros; rewrite H1 in H0; rewrite H2 in H.
  apply beq_tvar_trans with (x:= k') in H1.
  apply beq_tvar_eq in H2.
  subst.
  unfold map in H0.
  fold map in H0.
  rewrite beq_tvar_sym in H1.
  apply beq_tvar_eq in H1.
  subst.
  rewrite beq_tvar_refl in H0.
  inversion H0.
  apply beq_tvar_refl.
  apply beq_tvar_eq in H2.
  subst.
  unfold map in H0.
  fold map in H0.
  rewrite beq_tvar_refl in H0.
  inversion H0.
  unfold map in H0.
  fold map in H0.
  case_eq (K_eq k0 k'); intros; rewrite H3 in H0.
  inversion H0.
  rewrite H0 in H.
  inversion H0.
  inversion H.
  unfold map in H0.
  fold map in H0.
  rewrite H2 in H0.
  apply IHc with (k':= k') (t':= t') in H; try assumption.
Qed.

Lemma map_add_some_agreement:
  forall c k t,
    map c k = Some t ->
    forall k0 t0,
      K_eq k k0 = false ->
      map (add c k0 t0) k = Some t.
Proof.
(*
  intros.
  functional induction (map c k); try solve[crush].
*)

  intros.
  functional induction (add c k0 t0); try solve [crush].
  unfold map.
  fold map.
  rewrite H0.
  apply beq_tvar_eq in e0.
  subst.
  unfold map in H.
  fold map in H.
  rewrite H0 in H.
  assumption.

  unfold map in H.
  fold map in H.
  unfold map.
  fold map.
  case_eq(K_eq k k'); intros; rewrite H1 in H.
  assumption.

  apply IHc0 in H; try assumption.
Qed.

Lemma extends_r_strengthen_add:
  forall c c',
    extends c c' = true ->
    forall k t,
      map c k = None ->
      extends c (add c' k t) = true.
Proof.
  (* extends *)
  intros c c'.
  functional induction (extends c c'); try solve [crush].
  intros.
  pose proof e1 as e1'.
  apply beq_tau_eq in e1.
  subst.
  unfold map in H0.
  fold map in H0.
  case_eq(K_eq k0 k); intros; rewrite H1 in H0.
  inversion H0.
  apply IHb with (k:= k0) (t:= t0) in H; try assumption.
  apply extends_l_weaken; try assumption.
  apply map_add_some_agreement; try assumption.
  rewrite beq_tvar_sym in H1.
  assumption.
Qed.

Lemma map_extends_some_agreement:
  forall c v t,
    map c v  = Some t ->
    nodup c = true ->
    forall c',
      extends c c' = true ->
      nodup c' = true ->
      map c' v = Some t.
Proof.
  intros.
  functional induction (extends c c'); try solve [crush].
  unfold map in H.
  fold map in H.
  unfold nodup in H0.
  fold nodup in H0.
  case_eq(K_eq v k); intros; rewrite H3 in H.
  inversion H.
  subst.
  case_eq(map c'' k); intros; rewrite H4 in H0.
  inversion H0.
  clear H.
  apply beq_tvar_eq in H3.
  apply beq_tau_eq in e1.
  subst.
  assumption.
  case_eq(map c'' k); intros; rewrite H4 in H0.
  inversion H0.
  apply IHb in H; try assumption.
Qed.

Lemma extends_trans:
  forall c c' c'',
    nodup c = true ->
    extends c  c'  = true ->
    nodup c' = true ->
    extends c' c'' = true ->
    nodup c'' = true ->
    extends c  c'' = true.
Proof.
  (* triple induction *)
  intros c c' c'' nodupc extendscc' nodupc' extendsc'c'' nodupc''.
  induction c; try solve [crush]; induction c'; try solve [crush]; induction c''; try solve [crush].
  move extendscc' after IHc''.
  move extendsc'c'' after extendscc'.
  pose proof extendscc' as H'.
  apply extends_l_strengthen in extendscc'.
  inversion nodupc.
  case_eq (map c k); intros; rewrite H in H0; try solve[inversion H0].
  rewrite H0.
  apply IHc in H0; try assumption.
  apply extends_l_weaken with (k:= k) (t:= t).
  assumption.

  unfold map.
  fold map.
  case_eq (K_eq k k1); intros.
  apply beq_tvar_eq in H1.
  rewrite <- H1 in extendsc'c''.
  rewrite <- H1 in H0.
  rewrite <- H1 in nodupc''.
  assert (Z: map (Ctxt k t c) k = Some t).
  simpl.
  rewrite beq_tvar_refl.
  reflexivity.
  apply map_extends_some_agreement with (v:= k) (t:= t) in H'; try assumption.
  apply map_extends_some_agreement with (v:= k) (t:= t) in extendsc'c'';
    try assumption.
  unfold map in extendsc'c''.
  fold map in extendsc'c''.
  rewrite beq_tvar_refl in extendsc'c''.
  assumption.

  assert (Z: map (Ctxt k t c) k = Some t).
  unfold map.
  fold map.
  rewrite beq_tvar_refl.
  reflexivity.
  apply map_extends_some_agreement with (v:= k) (t:= t) in H';
    try assumption.
  apply map_extends_some_agreement with (v:= k) (t:= t) in extendsc'c'';
    try assumption.
  unfold map in extendsc'c''.
  fold map in extendsc'c''.
  rewrite H1 in extendsc'c''.
  assumption.
Qed.

Lemma equal_refl:
  forall c,
    nodup c = true ->
    equal c c = true.
Proof.
  intros.
  unfold equal.
  apply andb_true_iff.
  split.
  apply extends_refl; try assumption.
  apply extends_refl; try assumption.
Qed.

Lemma equal_sym:
  forall c c',
    equal c c' = equal c' c.
Proof.
  intros.
  unfold equal.
  crush.
Qed.

Lemma equal_trans:
  forall c c' c'',
    nodup c = true ->
    equal c  c'  = true ->
    nodup c' = true ->
    equal c' c'' = true ->
    nodup c'' = true ->
    equal c  c'' = true.
Proof.
  intros c c' c'' nodupc equalcc' nodupc' equalc'c'' nodupc''.
  unfold equal in equalcc'.
  apply andb_true_iff in equalcc'.
  inversion equalcc'.
  unfold equal in equalc'c''.
  apply andb_true_iff in equalc'c''.
  inversion equalc'c''.
  unfold equal.
  apply andb_true_iff.

  split.
  intros.
  apply extends_trans with (c:= c) (c':= c') (c'':= c'') in H; try assumption.
  apply extends_trans with (c:= c'') (c':= c') (c'':= c) in H0; try assumption.
Qed.

(* It would be nice if these were true but they're not unless I cannonicalize. *)
Lemma equal_eq:
  forall c c',
    equal c c' = true ->
    c = c'.
Admitted.

Lemma equal_neq:
  forall c c',
    equal c c' = false ->
    c <> c'.
Admitted.

Lemma equal_empty_only_empty:
  forall c,
    equal empty c = true ->
    c = empty.
Proof.
  intros.
  unfold equal in H.
  apply andb_true_iff in H.
  inversion H.
  apply empty_extends_only_empty in H1.
  assumption.
Qed.

Lemma equal_if_map_some:
  forall c c',
    nodup c  = true ->
    nodup c' = true->
    equal c c' = true ->
    (forall k t, map c k = Some t -> map c' k = Some t).
Proof.
  intros c c'.
  functional induction (equal c c').
  intros.
  apply andb_true_iff in H1.
  inversion H1.
  apply map_extends_some_agreement with (c':= c') in H2; try assumption.
Qed.

Lemma equal_iff_map_some:
  forall c c',
    nodup c  = true ->
    nodup c' = true ->
    equal c c' = true ->
    (forall k t, map c k = Some t <-> map c' k = Some t).
Proof.
  intros.

  split.
  intros.
  apply equal_if_map_some with (c:= c) (c':= c') (k:= k) (t:= t) in H; try assumption.

  intros.
  rewrite equal_sym in H1.
  apply equal_if_map_some with (c:= c') (c':= c) (k:= k) (t:= t) in H; try assumption.
Qed.


Require Import SetoidClass.
Require Import Permutation.
Require Import List.
Require Import ListSet.
Import ListNotations.

Class Eq_Dec (A : Type) : Type := {
  eq_dec  : forall (x y : A), {x = y} + {x <> y}
}.

Definition dec2bool {A B : Type} (P : A -> B -> Prop) (p_dec : forall x y, {P x y} + {~P x y}) : A -> B -> bool := fun x y => if p_dec x y then true else false.

Lemma dec2decidable {A B : Type} (P : A -> B -> Prop) (p_dec : forall x y, {P x y} + {~P x y}) : forall x y, P x y \/ ~P x y.
Proof.
  intros x y.
  destruct (p_dec x y); intuition.
Qed.

Lemma Nodup_idemp {A : Type} (eq_dec : forall (x y : A), {x = y} + {x <> y}) : forall l, NoDup l -> nodup eq_dec l = l.
Proof.
  induction l; intros.
  trivial.
  unfold nodup.
  case (in_dec eq_dec a l); intros.
  inversion H; contradiction.
  fold (nodup eq_dec l); rewrite IHl; trivial.
  apply NoDup_cons_iff in H; intuition.
Qed.

Ltac antisymmetry := apply (partial_order_antisym _).

Section Permutations.

Context {A : Type}.
Context {D : Eq_Dec A}.

Fixpoint findIndex_aux (x : A) (l : list A) (n : nat) : option nat :=
  match l with
    | [] => None
    | (y::ys) => if eq_dec x y then Some n else findIndex_aux x ys (S n)
  end.

Lemma findIndex_aux1 : forall (x : A) (l : list A) (n : nat), findIndex_aux x (x::l) n = Some n.
Proof.
  intros x l n.
  unfold findIndex_aux.
  case (eq_dec x x); [ trivial | contradiction ].
Qed.

Lemma findIndex_aux2 : forall (x a : A) (l : list A) (n : nat), x <> a -> findIndex_aux x (a::l) n = findIndex_aux x l (S n).
Proof.
  intros x a l n H.
  unfold findIndex_aux.
  case (eq_dec x a); [ contradiction | trivial ].
Qed.

Lemma findIndex_aux3 : forall x l m n, findIndex_aux x l m = Some n -> m <= n.
Proof.
  intro x; induction l; intros m n H.
  inversion H.
  case (eq_dec x a); intros.
  rewrite e, findIndex_aux1 in H; inversion H; reflexivity.
  rewrite (findIndex_aux2 _ _ _ _ n0) in H.
  apply IHl in H.
  rewrite <- H.
  apply PeanoNat.Nat.le_succ_diag_r.
Qed.

Lemma findIndex_aux4 : forall (x a : A) (l : list A) (n : nat), findIndex_aux x (a::l) n = Some n -> x = a.
Proof.
  intros x a l n.
  case (eq_dec x a); intros; [ trivial |].
  rewrite (findIndex_aux2 _ _ _ _ n0) in H.
  apply findIndex_aux3 in H.
  apply PeanoNat.Nat.nle_succ_diag_l in H; contradiction.
Qed.

Lemma findIndex_aux5 : forall (x : A) (l : list A) (n m : nat), findIndex_aux x l (S n) = Some (S m) -> findIndex_aux x l n = Some m.
Proof.
  intro x; induction l; intros m n H.
  inversion H.
  case_eq (eq_dec x a); intros.
  rewrite e in H; rewrite findIndex_aux1 in H; inversion H; rewrite e; apply findIndex_aux1.
  rewrite (findIndex_aux2 _ _ _ _ n0) in H; rewrite (findIndex_aux2 _ _ _ _ n0).
  apply (IHl _ _ H).
Qed.

Lemma findIndex_aux6 : forall (x : A) (l : list A) (n : nat), findIndex_aux x l (S n) = None -> findIndex_aux x l n = None.
Proof.
  intro x; induction l; intros n H.
  trivial.
  case_eq (eq_dec x a); intros.
  rewrite e, findIndex_aux1 in H; inversion H.
  rewrite (findIndex_aux2 _ _ _ _ n0) in H; rewrite (findIndex_aux2 _ _ _ _ n0).
  apply (IHl _ H).
Qed.

Definition findIndex (x : A) (l : list A) : option nat := findIndex_aux x l 0.

Lemma findIndex1 :  forall n x l, findIndex x l = Some n -> l = firstn n l ++ x::skipn (S n) l.
Proof.
  induction n; intros x l H.
  case_eq l; intros.
  rewrite H0 in H; inversion H.
  rewrite H0 in H.
  unfold findIndex in H; apply (findIndex_aux4) in H; rewrite H; trivial.
  case_eq l; intros.
  rewrite H0 in H; inversion H.
  simpl; replace (match l0 with | [] => []  | _ :: l1 => skipn n l1 end) with (skipn (S n) l0) by trivial.
  rewrite <- IHn; [ trivial |].
  rewrite H0 in H.
  unfold findIndex in H.
  case_eq (eq_dec x a); intros.
  rewrite e, findIndex_aux1 in H; inversion H.
  rewrite (findIndex_aux2 _ _ _ _ n0) in H.
  apply (findIndex_aux5 _ _ _ _ H).
Qed.

Lemma findIndex2 : forall x l, findIndex x l = None -> ~In x l.
Proof.
  intros x l H.
  induction l; intros.
  apply in_nil.
  unfold findIndex in H.
  case_eq (eq_dec x a); intros.
  rewrite e, findIndex_aux1 in H; inversion H.
  rewrite (findIndex_aux2 _ _ _ _ n) in H.
  apply not_in_cons; split; [ assumption |].
  apply IHl.
  unfold findIndex; apply (findIndex_aux6 _ _ 0 H).
Qed.

Lemma Permutation_middle_iff : forall (a : A) l l1 l2, Permutation l (l1 ++ l2) <-> Permutation (a :: l) (l1 ++ a :: l2).
Proof.
  intros; split; intros.
  apply (perm_skip a) in H.
  apply (Permutation_trans H), Permutation_middle.
  apply (fun H => Permutation_trans H (Permutation_sym (Permutation_middle l1 l2 a))) in H.
  apply (Permutation_cons_inv H).
Qed.

Lemma perm_dec : forall (l1 l2:list A), {Permutation l1 l2} + {~Permutation l1 l2}.
Proof.
  induction l1; intro l2.
  case l2.
  left; apply perm_nil.
  right; apply Permutation_nil_cons.
  case_eq (findIndex a l2); intros.
  apply findIndex1 in H; rewrite H.
  specialize IHl1 with (firstn n l2 ++ skipn (S n) l2).
  destruct IHl1.
  left; apply Permutation_middle_iff; assumption.
  right; contradict n0; apply Permutation_middle_iff in n0; assumption.
  right; apply findIndex2 in H; contradict H.
  apply (Permutation_in a H (in_eq a l1)).
Qed.

End Permutations.

Section Sets1.

Context {A : Type}.
Context {D : Eq_Dec A}.

Definition FSet A : Type := { l : list A | NoDup l }.

Definition fromList (l : list A) : FSet A := exist _ (nodup eq_dec l) (NoDup_nodup eq_dec l).

Definition empty_set : FSet A := fromList [].

Definition elem_set (x : A) (s : FSet A) : Prop := In x (proj1_sig s).

Definition incl_set (s1 s2 : FSet A) : Prop := forall x, elem_set x s1 -> elem_set x s2.

End Sets1.

Notation "'Ø'" := (empty_set).
Notation "'❴' x '❵'" := (fromList [x]).
Notation "'❴' x ',' y ',' .. ',' z '❵'" := (fromList (cons x (cons y .. (cons z nil) ..))).
Infix "∈" := (elem_set) (at level 70).
Notation "x ∉ s" := (~elem_set x s) (at level 70).
Infix "⊆" := (incl_set) (at level 75).

Section Sets2.

Context {A : Type}.
Context {D : Eq_Dec A}.

Global Instance SetSetoid : Setoid (FSet A)  := {|
  equiv := fun s1 s2 => Permutation (proj1_sig s1) (proj1_sig s2)
|}.
Proof.
  split.
  unfold Reflexive; intro s; apply Permutation_refl.
  unfold Symmetric; intros s1 s2; apply Permutation_sym.
  unfold Transitive; intros s1 s2 s3; apply Permutation_trans.
Defined.

Global Instance ElemProper : Proper (eq ==> equiv ==> iff) elem_set.
Proof.
  unfold Proper, "==>"; intros x y H s1 s2 H0.
  rewrite <- H; destruct s1 as [l1 p1], s2 as [l2 p2]; unfold elem_set; simpl in *.
  split; apply Permutation_in; [ | apply Permutation_sym ]; assumption.
Qed.

Lemma fset_exten : forall (s1 s2 : FSet A), s1 == s2 <-> (forall x, x ∈ s1 <-> x ∈ s2).
Proof.
  intros s1 s2; split; intros.
  rewrite H; reflexivity.
  destruct s1 as [l1 p1], s2 as [l2 p2]; unfold elem_set in H; simpl in *.
  apply (NoDup_Permutation p1 p2 H).
Qed.

Global Instance incl_PreOrder : PreOrder (@incl_set A).
Proof.
  split.
  unfold Reflexive; intros s x; trivial.
  unfold Transitive; intros s1 s2 s3 H H0 x; intuition.
Defined.

Global Instance incl_PartialOrder : PartialOrder (@equiv _ SetSetoid) (@incl_set A).
Proof.
  intros s1 s2; split; unfold incl_set, Basics.flip, relation_conjunction, predicate_intersection, pointwise_extension.
  intros H; split; intro x; rewrite fset_exten in H; specialize H with x; intuition.
  rewrite fset_exten; intros H x; destruct H; specialize H with x; specialize H0 with x; intuition.
Defined.

Global Instance elem_incl_proper (x : A) : Proper (@incl_set A ==> Basics.impl) (elem_set x).
Proof.
  unfold Proper, "==>"; intros s1 s2 H H0.
  unfold incl_set in H.
  apply H in H0; assumption.
Defined.

Definition toList (s : FSet A) : list A := proj1_sig s.

Definition union_set (s1 s2 : FSet A) : FSet A :=
  exist _ (set_union eq_dec (proj1_sig s1) (proj1_sig s2))
          (set_union_nodup eq_dec (proj2_sig s1) (proj2_sig s2)).

Global Instance UnionProper : Proper (equiv ==> equiv ==> equiv) union_set.
Proof.
  unfold Proper, "==>".
  intros s1 s1' H s2 s2' H0; destruct s1 as [l1 p1], s1' as [l1' p1'], s2 as [l2 p2], s2' as [l2' p2']; simpl in *.
  apply NoDup_Permutation; [ apply (set_union_nodup _ p1 p2)  | apply (set_union_nodup _ p1' p2') |].
  intro x.
  rewrite 2?set_union_iff; split; intros; destruct H1.
  left; apply (Permutation_in _ H H1).
  right; apply (Permutation_in _ H0 H1).
  left; apply (Permutation_in _ (Permutation_sym H) H1).
  right; apply (Permutation_in _ (Permutation_sym H0) H1).
Defined.

Definition inter_set (s1 s2 : FSet A) : FSet A :=
  exist _ (set_inter eq_dec (proj1_sig s1) (proj1_sig s2))
          (set_inter_nodup eq_dec (proj2_sig s1) (proj2_sig s2)).

Global Instance InterProper : Proper (equiv ==> equiv ==> equiv) inter_set.
Proof.
  unfold Proper, "==>".
  intros s1 s1' H s2 s2' H0; destruct s1 as [l1 p1], s1' as [l1' p1'], s2 as [l2 p2], s2' as [l2' p2']; simpl in *.
  apply NoDup_Permutation; [ apply (set_inter_nodup _ p1 p2)  | apply (set_inter_nodup _ p1' p2') |].
  intro x.
  rewrite 2?set_inter_iff; split; intros; destruct H1; split.
  apply (Permutation_in _ H H1).
  apply (Permutation_in _ H0 H2).
  apply (Permutation_in _ (Permutation_sym H) H1).
  apply (Permutation_in _ (Permutation_sym H0) H2).
Defined.

Definition diff_set (s1 s2 : FSet A) : FSet A :=
  exist _ (set_diff eq_dec (proj1_sig s1) (proj1_sig s2))
          (set_diff_nodup eq_dec (proj2_sig s1) (proj2_sig s2)).

Global Instance DiffProper : Proper (equiv ==> equiv ==> equiv) diff_set.
Proof.
  unfold Proper, "==>".
  intros s1 s1' H s2 s2' H0; destruct s1 as [l1 p1], s1' as [l1' p1'], s2 as [l2 p2], s2' as [l2' p2']; simpl in *.
  apply NoDup_Permutation; [ apply (set_diff_nodup _ p1 p2)  | apply (set_diff_nodup _ p1' p2') |].
  intro x.
  rewrite 2?set_diff_iff; split; intros; destruct H1; split.
  apply (Permutation_in _ H H1).
  intro; apply (Permutation_in _ (Permutation_sym H0)) in H3; contradiction.
  apply (Permutation_in _ (Permutation_sym H) H1).
  intro; apply (Permutation_in _ H0) in H3; contradiction.
Defined.

End Sets2.

Infix "∪" := (union_set) (at level 50, left associativity).
Infix "∩" := (inter_set) (at level 50, left associativity).
Infix "∖" := (diff_set) (at level 50, no associativity).

Section Sets3.

Context {A : Type}.
Context {D : Eq_Dec A}.

Lemma toFromList : forall (s : FSet A), fromList (toList s) == s.
Proof.
  intro s.
  destruct s as [l p]; simpl.
  rewrite (Nodup_idemp _ _ p); apply Permutation_refl.
Qed.

Lemma fromToList : forall (l : list A), toList (fromList l) = nodup eq_dec l.
Proof.
  intro l.
  unfold fromList, toList; trivial.
Qed.

Lemma fromList_in : forall x l, In x l <-> x ∈ fromList l.
Proof.
  intros x l.
  unfold fromList, elem_set; symmetry; apply nodup_In.
Qed.

Lemma toList_in : forall x (s : FSet A), x ∈ s <-> In x (toList s).
Proof.
  intros x s.
  rewrite <- toFromList at 1.
  symmetry; apply fromList_in.
Qed.

Definition elem_dec : forall (x : A) (s : FSet A), {x ∈ s} + {x ∉ s} := fun x s => in_dec eq_dec x (proj1_sig s).

Definition elem : A -> FSet A -> bool := dec2bool _ elem_dec.

Definition fset_equiv_dec : forall (s1 s2 : FSet A), {s1 == s2} + {s1 =/= s2} := fun s1 s2 : FSet A => perm_dec (proj1_sig s1) (proj1_sig s2).

(* Extras *)

Lemma elem_Prop : forall x s, elem x s = true <-> elem_set x s.
Proof.
  split; intros.
  destruct s as [l p]; simpl.
  unfold elem, dec2bool in H.
  destruct (elem_dec x (exist (fun l : list A => NoDup l) l p)).
  trivial.
  inversion H.
  unfold elem, dec2bool.
  destruct (elem_dec x s).
  trivial.
  contradiction.
Qed.

Lemma not_elem_Prop : forall x s, elem x s = false <-> ~elem_set x s.
Proof.
  split; intros.
  unfold elem, dec2bool in H; destruct (elem_dec x s).
  inversion H.
  trivial.
  unfold elem, dec2bool.
  destruct (elem_dec x s).
  contradiction.
  trivial.
Qed.

Lemma elem_singleton : forall x y, x ∈ ❴y❵ <-> x = y.
Proof.
  intros.
  unfold elem_set, fromList; simpl; intuition.
Qed.

(* End of extras *)

Lemma elem_empty : forall (x : A), x ∉ Ø.
Proof.
  intros x H.
  unfold elem_set, empty_set in H; simpl in H; contradiction.
Qed.

Lemma elem_union_iff : forall x s1 s2, x ∈ s1 ∪ s2 <-> x ∈ s1 \/ x ∈ s2.
Proof.
  intros x s1 s2.
  destruct s1 as [l1 p1], s2 as [l2 p2]; unfold union_set, elem_set; simpl.
  apply set_union_iff.
Qed.

Lemma union_idemp : forall (s : FSet A), s ∪ s == s.
Proof.
  intro s.
  apply fset_exten; intro x; rewrite elem_union_iff; intuition.
Qed.

Lemma union_empty_r : forall (s : FSet A), s ∪ Ø == s.
Proof.
  intro s.
  apply fset_exten; intro x; rewrite elem_union_iff; intuition.
Qed.

Lemma union_comm : forall s1 s2, s1 ∪ s2 == s2 ∪ s1.
Proof.
  intros s1 s2.
  apply fset_exten; intro x; rewrite 2?elem_union_iff; intuition.
Qed.

Lemma union_empty_l : forall (s : FSet A), Ø ∪ s == s.
Proof.
  intro s.
  rewrite union_comm; apply union_empty_r.
Qed.

Lemma union_assoc : forall s1 s2 s3, (s1 ∪ s2) ∪ s3 == s1 ∪ (s2 ∪ s3).
Proof.
  intros s1 s2 s3.
  apply fset_exten; intro x; rewrite 4?elem_union_iff; intuition.
Qed.

Global Instance union_mono : Proper (incl_set ==> incl_set ==> incl_set) union_set.
Proof.
  unfold Proper, "==>".
  intros s1 s1' H s2 s2' H0.
  unfold incl_set; intro x; rewrite 2?elem_union_iff; intuition.
Defined.

Lemma union_exp_l : forall s1 s2, s1 ⊆ s1 ∪ s2.
Proof.
  intros s1 s2.
  unfold incl_set; intro x; rewrite elem_union_iff; intuition.
Qed.

Lemma union_exp_r : forall s1 s2, s2 ⊆ s1 ∪ s2.
Proof.
  intros s1 s2; rewrite union_comm; apply union_exp_l.
Qed.

Lemma union_glb : forall s s1 s2, s1 ∪ s2 ⊆ s <-> s1 ⊆ s /\ s2 ⊆ s.
Proof.
  intros s s1 s2; split; intros; [ split |].
  rewrite <- H; apply union_exp_l.
  rewrite <- H; apply union_exp_r.
  destruct H; rewrite H, H0, union_idemp; reflexivity.
Qed.

Lemma union_incl : forall s1 s2, s1 ⊆ s2 <-> s1 ∪ s2 == s2.
Proof.
  intros s1 s2; split; intro.
  antisymmetry.
  rewrite H; rewrite union_idemp; reflexivity.
  apply union_exp_r.
  rewrite <- H; apply union_exp_l.
Qed.

Lemma union_empty: forall (s1 s2 : FSet A), s1 ∪ s2 == Ø <-> s1 == Ø /\ s2 == Ø.
Proof.
  intros s1 s2.
  split; intros; [| destruct H ].
  rewrite 2?fset_exten; split; intro x; split; intros.
  rewrite <- H, elem_union_iff; intuition.
  contradiction.
  rewrite <- H, elem_union_iff; intuition.
  contradiction.
  rewrite H, H0; apply union_empty_r.
Qed.

Lemma elem_inter_iff : forall x s1 s2, x ∈ s1 ∩ s2 <-> x ∈ s1 /\ x ∈ s2.
Proof.
  intros x s1 s2.
  destruct s1 as [l1 p1], s2 as [l2 p2]; unfold inter_set, elem_set; simpl.
  apply set_inter_iff.
Qed.

Lemma inter_idemp : forall (s : FSet A), s ∩ s == s.
Proof.
  intro s.
  apply fset_exten; intro x; rewrite elem_inter_iff; intuition.
Qed.

Lemma inter_empty_r : forall (s : FSet A), s ∩ Ø == Ø.
Proof.
  intro s.
  apply fset_exten; intro x; rewrite elem_inter_iff; intuition.
Qed.

Lemma inter_comm : forall s1 s2, s1 ∩ s2 == s2 ∩ s1.
Proof.
  intros s1 s2.
  apply fset_exten; intro x; rewrite 2?elem_inter_iff; intuition.
Qed.

Lemma inter_empty_l : forall (s : FSet A), Ø ∩ s == Ø.
Proof.
  intro s.
  rewrite inter_comm; apply inter_empty_r.
Qed.

Lemma inter_assoc : forall s1 s2 s3, (s1 ∩ s2) ∩ s3 == s1 ∩ (s2 ∩ s3).
Proof.
  intros s1 s2 s3.
  apply fset_exten; intro x; rewrite 4?elem_inter_iff; intuition.
Qed.

Global Instance inter_mono : Proper (incl_set ==> incl_set ==> incl_set) inter_set.
Proof.
  unfold Proper, "==>".
  intros s1 s1' H s2 s2' H0.
  unfold incl_set; intro x; rewrite 2?elem_inter_iff; intuition.
Defined.

Lemma inter_contr_l : forall s1 s2, s1 ∩ s2 ⊆ s1.
Proof.
  intros s1 s2.
  unfold incl_set; intro x; rewrite elem_inter_iff; intuition.
Qed.

Lemma inter_contr_r : forall s1 s2, s1 ∩ s2 ⊆ s2.
Proof.
  intros s1 s2; rewrite inter_comm; apply inter_contr_l.
Qed.

Lemma inter_lub : forall s s1 s2, s ⊆ s1 ∩ s2 <-> s ⊆ s1 /\ s ⊆ s2.
Proof.
  intros s s1 s2; split; intros; [ split |].
  rewrite H; apply inter_contr_l.
  rewrite H; apply inter_contr_r.
  destruct H; rewrite <- H, <- H0, inter_idemp; reflexivity.
Qed.

Lemma inter_incl : forall s1 s2, s1 ⊆ s2 <-> s1 ∩ s2 == s1.
Proof.
  intros s1 s2; split; intro.
  antisymmetry.
  apply inter_contr_l.
  rewrite <- H; rewrite inter_idemp; reflexivity.
  rewrite <- H; apply inter_contr_r.
Qed.

Lemma inter_union_distr : forall s1 s2 s3, s1 ∩ (s2 ∪ s3) == (s1 ∩ s2) ∪ (s1 ∩ s3).
Proof.
  intros s1 s2 s3.
  apply fset_exten; intro x; rewrite elem_inter_iff, 2?elem_union_iff, 2?elem_inter_iff; intuition.
Qed.

Lemma union_inter_distr : forall s1 s2 s3, s1 ∪ (s2 ∩ s3) == (s1 ∪ s2) ∩ (s1 ∪ s3).
Proof.
  intros s1 s2 s3.
  apply fset_exten; intro x; rewrite elem_union_iff, 2?elem_inter_iff, 2?elem_union_iff; intuition.
Qed.

Lemma elem_diff_iff : forall x s1 s2, x ∈ s1 ∖ s2 <-> x ∈ s1 /\ x ∉ s2.
Proof.
  intros x s1 s2.
  destruct s1 as [l1 p1], s2 as [l2 p2]; unfold diff_set, elem_set; simpl.
  apply set_diff_iff.
Qed.

Lemma diff_empty_l : forall s, Ø ∖ s == Ø.
Proof.
  intro s.
  apply fset_exten; intro x; rewrite elem_diff_iff; intuition.
Qed.

Lemma diff_empty_r : forall s, s ∖ Ø == s.
Proof.
  intro s.
  apply fset_exten; intro x; rewrite elem_diff_iff; intuition.
Qed.

Lemma diff_equal : forall s, s ∖ s == Ø.
Proof.
  intro s.
  apply fset_exten; intro x; rewrite elem_diff_iff; intuition.
Qed.

Lemma diff_union_l : forall s1 s2 s3, (s1 ∪ s2) ∖ s3 ==  (s1 ∖ s3) ∪ (s2 ∖ s3).
Proof.
  intros s1 s2 s3.
  apply fset_exten; intro x; rewrite elem_union_iff, 3?elem_diff_iff, elem_union_iff; intuition.
Qed.

Lemma diff_union_r : forall s1 s2 s3, s1 ∖ (s2 ∪ s3) == (s1 ∖ s2) ∩ (s1 ∖ s3).
Proof.
  intros s1 s2 s3.
  apply fset_exten; intro x; rewrite elem_inter_iff, 3?elem_diff_iff, elem_union_iff; intuition.
Qed.

Lemma diff_union_diff : forall s1 s2 s3, s1 ∖ (s2 ∪ s3) == (s1 ∖ s2) ∖ s3.
Proof.
  intros s1 s2 s3.
  apply fset_exten; intro x; rewrite 3?elem_diff_iff, elem_union_iff; intuition.
Qed.

Lemma diff_diff : forall s1 s2 s3, s1 ∖ (s2 ∖ s3) == (s1 ∖ s2) ∪ (s1 ∩ s3).
Proof.
  intros s1 s2 s3.
  apply fset_exten; intro x; rewrite elem_union_iff, 3?elem_diff_iff, elem_inter_iff.
  split; [| intuition ]; intro; destruct H.
  apply (Decidable.not_and _ _ (dec2decidable _ elem_dec _ _)) in H0; destruct H0.
  left; intuition.
  right; apply (Decidable.not_not _ (dec2decidable _ elem_dec _ _)) in H0; intuition.
Qed.

Lemma diff_exchange : forall s1 s2 s3, (s1 ∖ s2) ∖ s3 == (s1 ∖ s3) ∖ s2.
Proof.
  intros s1 s2 s3.
  rewrite <- 2?diff_union_diff.
  rewrite union_comm.
  reflexivity.
Qed.

Lemma diff_inter_l : forall s1 s2 s3, (s1 ∩ s2) ∖ s3 ==  (s1 ∖ s3) ∩ (s2 ∖ s3).
Proof.
  intros s1 s2 s3.
  apply fset_exten; intro x; rewrite elem_inter_iff, 3?elem_diff_iff, elem_inter_iff; intuition.
Qed.

Lemma diff_inter_r : forall s1 s2 s3, s1 ∖ (s2 ∩ s3) == (s1 ∖ s2) ∪ (s1 ∖ s3).
Proof.
  intros s1 s2 s3.
  apply fset_exten; intro x; rewrite elem_union_iff, 3?elem_diff_iff, elem_inter_iff.
  split; intros; [| intuition]; destruct H.
  apply (Decidable.not_and _ _ (dec2decidable _ elem_dec _ _)) in H0; destruct H0.
  left; intuition.
  right; intuition.
Qed.

Global Instance diff_anti_mono : Proper (incl_set ==> incl_set --> incl_set) diff_set.
Proof.
  unfold Proper, "==>", Basics.flip.
  intros s1 s1' H s2 s2' H0.
  unfold incl_set; intro x; rewrite 2?elem_diff_iff; intuition.
Defined.

Lemma diff_exp_l : forall s1 s2, s1 ∖ s2 ⊆ s1.
Proof.
  intros s1 s2.
  unfold incl_set; intro x; rewrite elem_diff_iff; intuition.
Qed.

Lemma diff_empty : forall s1 s2, s1 ∖ s2 == Ø <-> s1 ⊆ s2.
Proof.
  intros s1 s2; unfold incl_set; rewrite fset_exten; split; intros H x.
  intro H0; specialize H with x; rewrite elem_diff_iff in H; destruct H.
  case (elem_dec x s2); intro.
  assumption.
  assert (H2 := H (conj H0 n)); contradiction.
  split; intro.
  rewrite elem_diff_iff in H0; destruct H0; apply H in H0; contradiction.
  contradiction.
Qed.

Lemma union_fromList : forall l1 l2, fromList l1 ∪ fromList l2 == fromList (l1 ++ l2).
Proof.
  intros.
  apply fset_exten; intros.
  rewrite elem_union_iff, <- 3?fromList_in.
  symmetry; apply in_app_iff.
Qed.

End Sets3.


Require Export SfLib.
Require Export HelperFunctions.
Require Export HelperProofs.
Require Export BPlusTree.
Require Export InductiveDataTypes.
Require Export SortingProofs.

(*
 * Proofs about appears In List
 *)
Lemma element_at_index_impl_appears: forall (X: Type) (b k: nat) (v: X) (l: list (nat*X)),
  element_at_index b l = Some (k, v) -> appears_in_kvl k l.
Proof.
  intro X. induction b; intros; destruct l; inversion H; destruct p.
  Case "b = 0".
     inversion H. apply aik_here.
  Case "b = S b".
    apply aik_later. apply IHb with (v:=v). inversion H. reflexivity.
Qed.

Lemma appears_in_kvl_app : forall (X: Type) (k: nat) (l: list (nat*X)),
  appears_in_kvl k l -> exists l1, exists l2, exists v, l = l1++(k,v)::l2.
Proof.
  intros X k l H. induction H. exists []. exists l. exists v. reflexivity.
  inversion IHappears_in_kvl. inversion H0. inversion H1.
  exists ((k0, v)::witness). exists witness0. exists witness1. simpl. rewrite cons_remove. apply H2.
Qed.

Lemma kv_appears_in_kvl_app : forall (X: Type) (k: nat) (v: X) (l: list (nat*X)),
  kv_appears_in_kvl k v l -> exists l1, exists l2, l = l1++(k,v)::l2.
Proof.
  intros X k v l H. induction H. exists []. exists l. reflexivity.
  inversion IHkv_appears_in_kvl. inversion H0. inversion H1.
  exists ((k0, v0)::witness). exists witness0.
  simpl. reflexivity.
Qed.

Lemma appears_in_super_set_appears : forall (X: Type) k (x: (nat*X)) (l l': list (nat*X)),
  x :: l' = l -> appears_in_kvl k l' -> appears_in_kvl k l.
Proof.
  intros. generalize dependent l. generalize dependent x. induction H0. intros.
  rewrite <- H. destruct x. apply aik_later. apply aik_here.
  intros. destruct l0. inversion H. inversion H. destruct p. apply aik_later.
  apply IHappears_in_kvl with (x:= (k0, v)). reflexivity.
Qed.

Lemma kv_appears_in_super_set_appears : forall (X: Type) k v (x: (nat*X)) (l l': list (nat*X)),
  x :: l' = l -> kv_appears_in_kvl k v l' -> kv_appears_in_kvl k v l.
Proof.
  intros. generalize dependent l. generalize dependent x. induction H0. intros.
  rewrite <- H. destruct x. apply kv_aik_later. apply kv_aik_here.
  intros. destruct l0. inversion H. inversion H. destruct p. apply kv_aik_later.
  apply IHkv_appears_in_kvl with (x:= (k0, v0)). reflexivity.
Qed.

Lemma appears_in_kvl_dist_app : forall (X: Type) (k: nat) (l l1 l2: list (nat*X)),
  l = l1++l2 -> appears_in_kvl k l ->
  appears_in_kvl k l1 \/ appears_in_kvl k l2.
Proof.
  intros. generalize dependent l1. induction H0; intros.
  Case "aik_here".
    destruct l1. destruct l2; inversion H. destruct p. simpl in H1.
    inversion H1. right. apply aik_here.
    destruct p. inversion H. left. apply aik_here.
  Case "aik_later".
    destruct l1. simpl in H. right. eapply appears_in_super_set_appears. apply H. assumption.
    inversion H.
      assert(
        appears_in_kvl k l1 \/ appears_in_kvl k l2 ->
        appears_in_kvl k ((k0, v) :: l1) \/ appears_in_kvl k l2).
        intros. destruct H1. left. apply aik_later. assumption. right. assumption.
    apply H1. apply IHappears_in_kvl. apply H3.
Qed.

Lemma kv_appears_in_kvl_dist_app : forall (X: Type) (k: nat) (v: X) (l l1 l2: list (nat*X)),
  l = l1++l2 -> kv_appears_in_kvl k v l ->
  kv_appears_in_kvl k v l1 \/ kv_appears_in_kvl k v l2.
Proof.
  intros. generalize dependent l1. induction H0; intros.
  Case "kv_aik_here".
    destruct l1. destruct l2; inversion H. destruct p.
    inversion H1. right. apply kv_aik_here.
    destruct p. inversion H. left. apply kv_aik_here.
  Case "kv_aik_later".
    destruct l1. simpl in H. right. eapply kv_appears_in_super_set_appears. apply H. assumption.
    inversion H.
      assert(
        kv_appears_in_kvl k v l1 \/ kv_appears_in_kvl k v l2 ->
        kv_appears_in_kvl k v ((k0, v0) :: l1) \/ kv_appears_in_kvl k v l2).
        intros. destruct H1. left. apply kv_aik_later. assumption. right. assumption.
    apply H1. apply IHkv_appears_in_kvl. apply H3.
Qed.

Theorem appears_kvl_appears_leaf_tree: forall {X: Type} (b: nat) k l,
  appears_in_kvl k l -> appears_in_tree k (bptLeaf b X l).
Proof.
  intros. induction H. apply ait_leaf. apply aik_here. apply ait_leaf.
  eapply appears_in_super_set_appears. reflexivity. apply H.
Qed.

Lemma appears_cons : forall (X: Type) (k k1: nat) (v1: X) (l: list (nat*X)),
  appears_in_kvl k ((k1, v1) :: l) ->
  k <> k1 ->
  appears_in_kvl k (l).
Proof.
  intros.
  inversion H.
  subst.
  apply ex_falso_quodlibet. omega.
  subst.
  apply H2.
Qed.

Lemma kv_appears_cons : forall (X: Type) (k k1: nat) (v v1: X) (l: list (nat*X)),
  kv_appears_in_kvl k v ((k1, v1) :: l) ->
  k <> k1 ->
  kv_appears_in_kvl k v (l).
Proof.
  intros.
  inversion H.
  subst.
  apply ex_falso_quodlibet. omega.
  subst.
  apply H2.
Qed.

Theorem insert_into_list_appears : forall (X: Type) (l: list (nat * X)) (k: nat) (v: X),
  kv_appears_in_kvl k v (insert_into_list k v l).
Proof.
  intros.
  induction l.
  Case "l = []".
    simpl. apply kv_aik_here.
  Case "l = a::l".
    destruct a. simpl.
    remember (ble_nat k n) as klen.
    destruct klen; symmetry in Heqklen; [apply ble_nat_true in Heqklen | apply ble_nat_false in Heqklen].
    SCase "k <= n". remember (beq_nat k n) as keqn.
      destruct keqn; symmetry in Heqkeqn; [apply beq_nat_true_iff in Heqkeqn | apply beq_nat_false_iff in Heqkeqn].
      SSCase "k = n".
        apply kv_aik_here.
      SSCase "k <> n".
      apply kv_aik_here.
    SCase "k > n".
      apply kv_aik_later. apply IHl.
Qed.

Lemma key_greater_than_all_keys_does_not_appear : forall (X: Type) (k kb: nat) (l: list (nat*X)),
  kvl_sorted l ->
  all_keys X (below kb) l ->
  k >= kb ->

  ~ appears_in_kvl k l.
Proof.
  unfold not.
  intros.
  induction H0.
  inversion H2.
  apply IHall_keys.
  apply list_tail_is_sorted in H. apply H.
  remember (beq_nat k n).
  destruct b; symmetry in Heqb; [apply beq_nat_true_iff in Heqb|apply beq_nat_false_iff in Heqb].
  subst.
  inversion H3. apply blt_nat_true in H5. apply ex_falso_quodlibet. omega.
  apply appears_cons in H2. assumption.
  assumption.
Qed.

Lemma key_greater_than_all_keys_does_not_appear_ble : forall (X: Type) (k kb: nat) (l: list (nat*X)),
  kvl_sorted l ->
  all_keys X (below_equal kb) l ->
  k > kb ->

  ~ appears_in_kvl k l.
Proof.
  unfold not.
  intros.
  induction H0.
  inversion H2.
  apply IHall_keys.
  apply list_tail_is_sorted in H. apply H.
  remember (beq_nat k n).
  destruct b; symmetry in Heqb; [apply beq_nat_true_iff in Heqb|apply beq_nat_false_iff in Heqb].
  subst.
  inversion H3. apply ble_nat_true in H5. apply ex_falso_quodlibet. omega.
  apply appears_cons in H2. assumption.
  assumption.
Qed.

Lemma key_smaller_than_all_keys_does_not_appear : forall (X: Type) (k kb: nat) (l: list (nat*X)),
  kvl_sorted l ->
  all_keys X (above kb) l ->
  k < kb ->

  ~ appears_in_kvl k l.
Proof.
  unfold not.
  intros.
  induction H0.
  subst. inversion H2.
  apply IHall_keys.
  apply list_tail_is_sorted in H. apply H.
  remember (beq_nat k n).
  destruct b; symmetry in Heqb; [apply beq_nat_true_iff in Heqb|apply beq_nat_false_iff in Heqb].
  subst.
  inversion H3. apply ble_nat_true in H5. apply ex_falso_quodlibet. omega.
  apply appears_cons in H2. assumption.
  assumption.
Qed.

Lemma appears_in_kvl_cons_middle: forall (X: Type) k n x (l1 l2: list (nat * X)),
  appears_in_kvl k (l1 ++ l2) ->
  appears_in_kvl k (l1 ++ (n, x) :: l2).
Proof.
  intros. induction l1. destruct l2. inversion H.
  destruct p. simpl in H. simpl. apply aik_later. apply H.
  destruct a.
  remember (beq_nat k n0).  destruct b.
  symmetry in Heqb. apply beq_nat_true_iff in Heqb. subst.
  apply aik_here.
  simpl.
  apply aik_later. apply IHl1.
  simpl in H.
  apply appears_cons in H. assumption. apply beq_nat_false_iff. symmetry. assumption.
Qed.

Lemma not_appears_in_kvl_impl_remove_element: forall (X: Type) n x k (l1 l2: list (nat * X)),
  ~ appears_in_kvl k (l1 ++ (n, x) :: l2) ->
  ~ appears_in_kvl k (l1 ++ l2).
Proof.
  intros. unfold not in H. unfold not. intro.
  eapply appears_in_kvl_cons_middle in H0. apply H in H0. assumption.
Qed.

Lemma not_appears_in_kvl_key_not_equal: forall (X: Type) n x k (l1 l2: list (nat * X)),
  ~ appears_in_kvl k (l1 ++ (n, x) :: l2) ->
  k <> n.
Proof.
  intros. unfold not. unfold not in H. intro. apply H.
  induction l1; simpl; subst.
  Case "l1 = []".
    apply aik_here.
  Case "l1 = a :: l1".
    destruct a.
      apply aik_later.
      simpl in H.
      apply IHl1. intro. apply H.
      apply aik_later. assumption.
Qed.

Lemma insert_into_list_eq_nil_impl_false: forall (X: Type) b k1 v1 (l: list (nat * bplustree b X)),
  [] = insert_into_list k1 v1 l -> False.
Proof.
  intros.
  induction l.
    inversion H.
    apply IHl.
    simpl in H.
    destruct a.
    remember (ble_nat k1 n).
    destruct b1; symmetry in Heqb1; [apply ble_nat_true in Heqb1 | apply ble_nat_false in Heqb1].
      remember (beq_nat k1 n).
      destruct b1; symmetry in Heqb0; [apply beq_nat_true in Heqb0 | apply beq_nat_false in Heqb0]; inversion H.
      inversion H.
Qed.