(* Copyright (c) 2008, Harvard University
 * All rights reserved.
 *
 * Author: Avi Shinnar
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:
 *
 * - Redistributions of source code must retain the above copyright notice,
 *   this list of conditions and the following disclaimer.
 * - Redistributions in binary form must reproduce the above copyright notice,
 *   this list of conditions and the following disclaimer in the documentation
 *   and/or other materials provided with the distribution.
 * - The names of contributors may not be used to endorse or promote products
 *   derived from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 * POSSIBILITY OF SUCH DAMAGE.
 *)

(* This files defines a module for an association type with a decidable equality on the keys
  and an AssocList functor that provides a basic model of a functional association list based on
  the provided association.  It is used as the model for FiniteMaps *)

Require Import Ynot.
Set Implicit Arguments.

(*************************************************************************)
(* Module that defines an association with decidable equality on the key *)
(*************************************************************************)
Module Type ASSOCIATION.
  Variable key_t : Set.
  Variable value_t : key_t -> Set.  (* note that value types depend on the keys *)
  Variable key_eq_dec : forall (k1 k2:key_t), {k1 = k2} + {k1 <> k2}.
  Notation "k1 =! k2" := (key_eq_dec k1 k2) (at level 70, right associativity).
End ASSOCIATION.

(*********************************************)
(* The functional model -- association lists *)
(*********************************************)
Module AssocList(A : ASSOCIATION).
Require Export List.
  Require Export Coq.Sorting.Permutation.
  Export A.
  Notation "( x ,, y )" := (@existT _ _ x y) : core_scope.
  Notation "` x" := (projT1 x) (at level 10): core_scope.

  Require Import Eqdep_dec.
  Module DecKey : DecidableType with Definition U:=A.key_t with Definition eq_dec:=A.key_eq_dec.
    Definition U := A.key_t.
    Definition eq_dec := A.key_eq_dec.
  End DecKey.
  Module DecKeyFacts := DecidableEqDep(DecKey).

  Definition key_eq_irr : (forall (k:A.key_t)(p:k = k), p = refl_equal k) := DecKeyFacts.UIP_refl.
  Definition inj_pairT2 := DecKeyFacts.inj_pairT2.

  (* because of the dependency of values on keys, we don't just use normal lists *)
  Definition alist_t := list (sigT A.value_t).

  Definition nil_al := @nil (sigT A.value_t).
  Fixpoint remove(k:A.key_t)(l:alist_t) {struct l} : alist_t :=
    match l with
    | nil => nil
    | (k',, v')::l' => if k =! k' then remove k l'
                          else (k',, v')::(remove k l')
    end.

  Definition insert(k:A.key_t)(v:A.value_t k)(l:alist_t) := (k,, v)::(remove k l).
  Lemma insert_eq k v l : (k,,v)::(remove k l) = insert v l.
  Proof. reflexivity. Qed.
  Hint Rewrite insert_eq : AssocListModel.

  Definition coerce(k1 k2:A.key_t)(H:k1 = k2)(v:A.value_t k1) : A.value_t k2.
    intros. rewrite H in v. apply v.
  Defined.

  Ltac uncoerce :=
    let rev_hyps := repeat
      match goal with
        | [H: _ = _ |- _ ] =>
          match goal with
            | [H2: context [H]|- _ ] => revert H2
          end
      end
      in let gen_eqs := repeat
        match goal with
          | [H: _ = _ |- _ ] =>
            match goal with
              | [|- context [H]] => generalize H
            end
        end
        in let refl_eqs := repeat
          match goal with
            [|- forall (x : ?a = ?a), _] =>
            let H2 := (fresh "H") in
              intro H2; rewrite (key_eq_irr H2); clear H2
          end in
          rev_hyps; gen_eqs; subst; refl_eqs; simpl.

  Fixpoint lookup(k:A.key_t)(l:alist_t) {struct l} : option(A.value_t k) :=
    match l with
    | nil => None
    | (k',, v'):: l' =>
      match k' =! k with
      | left k_eq_k' => Some (coerce k_eq_k' v')
      | right k_neq_k' => lookup k l'
      end
    end.

    Fixpoint distinct (l:alist_t) : Prop :=
      match l with
        | nil => True
        | (k,,v)::ls => lookup k ls = None /\ distinct ls
      end.

    Ltac simpler := try discriminate; try uncoerce;
      repeat (progress ((repeat
        match goal with
        | [H: _ = _ |- context [coerce ?pf _]] => equate pf H || equate pf (sym_eq H)
        | [H:?e = ?e |- _] => clear H
        | [H: Some _ = Some _ |- _] => inversion H; clear H
        | [H: (?k,,?v1) = (?k,,?v2) |- _] => generalize (inj_pairT2 H); clear H; intro H
        | [H:(?k1,, _) = (?k2,, _) |- _] => inversion H; (subst k2 || subst k1); clear H
        | [|- context [match ?k1 =! ?k2 with
                         | left _ => _
                         | right _ => _ end]] =>
        case_eq (k1 =! k2) ; intros; try congruence ; try solve [assert False; intuition]; try subst
        | [H:context [match ?k1 =! ?k2 with
                         | left _ => _
                         | right _ => _ end] |- _] =>
        destruct (k1 =! k2) ; try congruence ; try solve [assert False; intuition]; try subst
        |[H: sigT _ |- _] => destruct H
        |[|- ?a::_ = ?a::_ ]=> f_equal
      end))).

  Ltac t := repeat progress (simpler; simpl in *; autorewrite with AssocListModel; eauto; intuition).

  (* interactions of lookup and the other operations *)
  Lemma lookup_remove_eq k l : lookup k (remove k l) = None.
  Proof. induction l; t. Qed.

  Lemma lookup_remove_neq k k' l : k <> k' -> lookup k (remove k' l) = lookup k l.
  Proof. induction l; t. Qed.

  Lemma lookup_insert_eq k v l : lookup k (insert v l) = Some v.
  Proof. induction l; t. Qed.

  Lemma lookup_insert_neq k k' (v:value_t k') l : k <> k' -> lookup k (insert v l) = lookup k l.
  Proof. induction l; t. Qed.
  Hint Rewrite lookup_remove_eq lookup_insert_eq : AssocListModel.
  Hint Rewrite lookup_remove_neq lookup_insert_neq using solve[t] : AssocListModel.

  Lemma lookup_none_remove k l : lookup k l = None -> remove k l = l.
  Proof. induction l; t. Qed.

  Lemma lookup_none_perm k l l' : Permutation l l' -> lookup k l = None -> lookup k l' = None.
  Proof. induction 1; t. Qed.

  (* interactions of distinct and the other operations *)
  Lemma distinct_remove k l : distinct l -> distinct (remove k l).
  Proof. induction l; t. Qed.

  Lemma distinct_insert k (v:A.value_t k) l : distinct l -> distinct (insert v l).
  Proof. induction l; t. Qed.

  Hint Resolve lookup_none_remove lookup_none_perm distinct_remove distinct_insert.

  Lemma distinct_perm l l' : Permutation l l' -> distinct l -> distinct l'.
  Proof. induction 1; t. Qed.

  Hint Resolve distinct_remove distinct_perm Permutation_sym Permutation_refl.

  Lemma lookup_dis_perm k l l' : Permutation l l' -> distinct l -> lookup k l = lookup k l'.
  Proof. induction 1; t. rewrite H2; eauto. Qed.

  Lemma remove_perm k l l' : Permutation l l' -> Permutation (remove k l) (remove k l').
  Proof.  Hint Constructors Permutation. induction 1; t. Qed.
  Hint Resolve lookup_dis_perm remove_perm.

  Lemma insert_perm k l l' (v:A.value_t k) : Permutation l l' -> Permutation (insert v l) (insert v l').
  Proof. unfold insert. intros. constructor. t. Qed.

  Lemma remove_swap k k' l : remove k (remove k' l) = remove k' (remove k l).
  Proof. induction l; t. Qed.

  Lemma insert_swap k (v:A.value_t k) k' (v':A.value_t k') l : k <> k' ->
    Permutation (insert v (insert v' l)) (insert v' (insert v l)).
  Proof. intros. Hint Constructors Permutation. unfold insert. simpler. rewrite remove_swap. t. Qed.
  Hint Resolve remove_swap insert_perm insert_swap.

  Lemma lookup_none_notin l k : lookup k l = None -> forall v, ~ In (k,,v) l.
  Proof. induction l; t. Qed.

  Lemma lookup_some_in l k v: lookup k l = Some v -> In (k,,v) l.
  Proof. induction l; t. Qed.
  Hint Resolve lookup_none_notin lookup_some_in.

  Lemma lookup_app_none1 k l1 l2 : lookup k l1 = None -> lookup k (l1++l2) = lookup k l2.
  Proof. induction l1; t. Qed.

  Lemma distinct_NoDup l : distinct l -> NoDup l.
  Proof. Hint Constructors NoDup. induction l; t. Qed.
  Hint Resolve distinct_NoDup.

  Lemma distinct_In_inj k v1 v2 l : distinct l -> In (k,,v1) l -> In (k,,v2) l -> v1 = v2.
  Proof. induction l; t. elim (lookup_none_notin _ H2 _ H0). elim (lookup_none_notin _ H2 _ H). Qed.

  Lemma lookup_dis_in_some l k v : distinct l -> In (k,,v) l -> lookup k l = Some v.
  Proof. intros. remember (lookup k l) as x.
         destruct x. pose (lookup_some_in _ (sym_eq Heqx)). f_equal. eapply distinct_In_inj; eauto.
         elim (lookup_none_notin _ (sym_eq Heqx) _ H0).
  Qed.

  Lemma distinct_look_perm l l' : distinct l -> distinct l' -> (forall k, lookup k l = lookup k l') -> Permutation l l'.
  Proof. intros. apply NoDup_Permutation; t; pose (H1 x).
         rewrite (lookup_dis_in_some _ _ H H2) in e; apply lookup_some_in; auto.
         rewrite (lookup_dis_in_some _ _ H0 H2) in e; apply lookup_some_in; auto.
  Qed.

  Lemma distinct_in_perm l l' : distinct l -> distinct l' -> incl l l' -> incl l' l -> Permutation l l'.
  Proof. intros. apply NoDup_Permutation; t. Qed.

  Lemma lookup_app_some1 k v l1 l2 : lookup k l1 = Some v -> lookup k (l1++l2) = Some v.
  Proof. induction l1; t. Qed.

  Lemma lookup_app_inv k v l1 l2 : lookup k (l1++l2) = Some v ->
    lookup k l1 = Some v \/ lookup k l1 = None /\ lookup k l2 = Some v.
  Proof. induction l1; t. Qed.

  Lemma remove_app k l1 l2 : remove k (l1++l2) = remove k l1 ++ remove k l2.
  Proof. induction l1; t. Qed.
  Hint Rewrite remove_app : AssocListModel.

  Lemma insert_app k v l1 l2 : insert (k:=k) v (l1++l2) = insert v l1 ++ remove k l2.
  Proof. unfold insert; t. Qed.
  Hint Rewrite insert_app : AssocListModel.

End AssocList.


(** * Testcases for [it_suffices_to_show.v]
Authors:
    - Lulof Pirée (1363638)
Creation date: 7 June 2021

--------------------------------------------------------------------------------

This file is part of Waterproof-lib.

Waterproof-lib is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

Waterproof-lib 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 General Public License
along with Waterproof-lib.  If not, see <https://www.gnu.org/licenses/>.
*)
From Ltac2 Require Import Ltac2.
From Ltac2 Require Option.

Require Import Waterproof.message.

Require Import Waterproof.set_search_depth.To_5.
Require Import Waterproof.set_intuition.Disabled.
Load it_suffices_to_show.
Require Import Waterproof.test_auxiliary.
Require Import Waterproof.load_database.DisableWildcard.

(* -------------------------------------------------------------------------- *)
(** * Testcases for [It suffices to show that ...]
    Variant without the [by] clause.
*)

Open Scope nat_scope.

(** * Test 1
    Base case: give a statement that indeed suffices.
*)
Lemma test_it_suffices_1: forall x:nat, x>0 /\ x < 2 -> x = S (0).
Proof.
    intros x.
    It suffices to show that (x = 1).
    (* Old goal should have been proven by the above,
        now the assumption used remains to be proven.*)
    assert_goal_is constr:(x=1).
Abort.

(** * Test 2
    Error case: give a statement does not suffice to complete the proof.
*)
Lemma test_it_suffices_2: forall A B : Prop , A /\ A -> B.
Proof.
    intros A B.
    (* Clearly this statement isn't helpful in proving the goal! *)
    let result () := It suffices to show that (1 + 1 = 2) in
    assert_raises_error result.
Abort.

Require Import Waterproof.load_database.Integers.

Local Parameter f : nat -> nat.
Local Parameter f_increasing : forall m n : nat, m <= n -> f m <= f n.

Lemma test_it_suffices_3: f 1 <= f 2.
    By f_increasing it suffices to show that (1 <= 2).
    assert_goal_is constr:(1 <= 2).
Abort.

(** * Test 2
    Error case: give a statement does not suffice to complete the proof.
*)
Lemma test_it_suffices_2: forall A B : Prop , A /\ A -> B.
Proof.
    intros A B.
    (* Clearly this statement isn't helpful in proving the goal! *)
    let result () := By (f_increasing) it suffices to show that (1 + 1 = 2) in
    assert_raises_error result.
Abort.

(* -------------------------------------------------------------------------- *)
(** * Testcases for [It suffices to show that ... by ...]
    Variant with the [by] clause.
*)

(** * Test 1
    Basic case: correct tactic given, but useless statement.
*)

(*
Lemma test_it_suffices_by_1: 0 <> 1.
Proof.
    It suffices to show that (0 = 0) by (trivial).
Abort.

Inductive even : nat -> Prop :=
    even0 : even 0
  | evenS : forall x:nat, even x -> even (S (S x)).

(** * Test 2
    Basic case: correct tactic given, and usefull statement.
*)
Lemma test_it_suffices_by_2: even 4.
Proof.
    It suffices to show that (even 2) by (apply evenS;assumption).
Abort.

(** * Test 3
    Error case: the given tactic does not prove it.
*)
Lemma test_it_suffices_by_3: 0 <> 1.
Proof.
    let result () := It suffices to show that (1 <> 0) by reflexivity in
    assert_raises_error result.
Abort.
*)


Require Import String.

Section string_dec.

  (* The goal of this section is to prove the following theorem:
     string_dec_refl l : string_dec l l = left (eq_refl l)
   *)

  Theorem bool_dec_refl b : Bool.bool_dec b b = left (eq_refl b).
  Proof.
    induction b ; reflexivity.
  Qed.

  Theorem ascii_dec_refl a : Ascii.ascii_dec a a = left (eq_refl a).
  Proof.
    induction a.
    unfold Ascii.ascii_dec, Ascii.ascii_rec, Ascii.ascii_rect.
    repeat rewrite bool_dec_refl.
    reflexivity.
  Qed.

  (* To prove the corresponding lemma on strings,
     we first write a lemma wich unfolds the boring definitions *)

  Lemma string_dec_cons_eq1 a l :
    string_dec (String a l) (String a l) =
    match Ascii.ascii_dec a a with
      | left a0 =>
        eq_rec_r
          (fun a' => {String a' l = String a l} + {String a' l <> String a l})
          match string_dec l l with
            | left a3 =>
              eq_rec_r
                (fun s => {String a s = String a l} + {String a s <> String a l})
                (left eq_refl) a3
            | right diseq =>
              right
                (fun absurd : String a l = String a l =>
                   diseq
                     (f_equal
                        (fun e =>
                           match e with
                             | ""%string => l
                             | String _ s => s
                           end) absurd))
          end a0
      | right diseq =>
        right
          (fun absurd : String a l = String a l =>
             diseq
               (f_equal
                  (fun e =>
                     match e with
                       | ""%string => a
                       | String a _ => a
                     end) absurd))
    end.
  Proof.
    reflexivity.
  Qed.

  (* We can simplify this expression using the theorem on chars. *)
  Lemma string_dec_cons_eq2 a l :
    string_dec (String a l) (String a l) =
    match string_dec l l with
      | left a3 =>
        eq_rec_r
          (fun s => {String a s = String a l} + {String a s <> String a l})
          (left eq_refl) a3
      | right diseq =>
        right
          (fun absurd : String a l = String a l =>
             diseq
               (f_equal
                  (fun e =>
                     match e with
                       | ""%string => l
                       | String _ s => s
                     end) absurd))
    end.
  Proof.
    rewrite string_dec_cons_eq1.
    rewrite ascii_dec_refl.
    reflexivity.
  Qed.

  Theorem string_dec_refl l : string_dec l l = left (eq_refl l).
  Proof.
    induction l.
    - reflexivity.
    - rewrite string_dec_cons_eq2.
      rewrite IHl.
      reflexivity.
  Qed.
End string_dec.

Section types.
  (* Object types are records of types, we define them as association lists *)

  Inductive type :=
  | Empty_type
  | Cons_type : string -> type -> type -> type.

  (* Alternative constructor used for notation purpose *)
  Definition Cons_type_2 : (string * type) -> type -> type :=
    fun f B => let (l, A) := f in Cons_type l A B.
End types.

(* Scope of object types *)
Bind Scope obj_type_scope with type.
Delimit Scope obj_type_scope with ty.
(* Scope of object type fields (pairs of strings and types) *)
Delimit Scope type_field_scope with tf.

(* Notations for object types:
   [ "l₁" : A₁ ; "l₂" : A₂ ; … ; "lₙ" : Aₙ ]
 *)
Notation "l : A" := (l%string, A) (at level 50) : type_field_scope.
Notation "[ x1 ; .. ; xn ]" :=
  (Cons_type_2 x1%tf .. (Cons_type_2 xn%tf Empty_type) ..) : obj_type_scope.

Section objects.
  (* Objects are records of methods.
   A well-typed object of type A = [ lᵢ : Aᵢ ]
   is of the form [ lᵢ = ς(x !: A) tᵢ ] where x : A ⊢ tᵢ : Aᵢ

   The type A appears 3 times in the definition of well-typed object of type A :
    - in each ς binder
    - to type each tᵢ
    - to list the labels

   Since we cannot construct an object without breaking the invariant, we define
   preobjects of type (A, f, d) such that Obj A = Preobject (A, assoc A, domain A).

   *)

  (* We have to axiomatize the type of methods because
   Method A B := Obj A -> Obj B has a negative occurence of Obj which blocks
   the recursive definition
   *)

  Parameter Method : type -> type -> Type.

  Inductive Preobject : type -> (string -> type) -> list string -> Type :=
  | poempty : forall A f, Preobject A f nil
  | pocons : forall A f d (l : string),
               Method A (f l) ->
               Preobject A f d ->
               Preobject A f (cons l d).

  Fixpoint assoc (A : type) (l : string) : type :=
    match A with
      | Empty_type => Empty_type
      | Cons_type l2 B C =>
        if string_dec l l2 then B else assoc C l
    end.

  Fixpoint domain A :=
    match A with
      | Empty_type => nil
      | Cons_type l _ C => cons l (domain C)
    end.

  Definition Obj A := Preobject A (assoc A) (domain A).

  (* End of the axiomatisation of methods: Method A B is equivalent to Obj A -> Obj B. *)
  Parameter Eval_meth : forall A B, Method A B -> Obj A -> Obj B.
  Parameter Make_meth : forall A B, (Obj A -> Obj B) -> Method A B.
  Axiom beta : forall A B f a, Eval_meth A B (Make_meth A B f) a = f a.

  (* We will often need to test wether a label is in a domain
     so we reimplement the decidable membership test on lists of strings. *)
  Fixpoint in_dom l d :=
    match d with
      | nil => false
      | cons l2 d =>
        if (string_dec l l2) then true else in_dom l d
    end.
End objects.

Delimit Scope object_scope with obj.
Delimit Scope method_scope with meth.

Bind Scope method_scope with Method.
Bind Scope object_scope with Preobject.

Notation "l = 'ς' ( x !: A ) m" :=
  (existT (fun l2 => Method A (assoc A l2)) l%string (Make_meth A (assoc A l) (fun x => m%obj)))
    (at level 50) : method_scope.

Notation "l ∈ d" := (in_dom l d = true) (at level 60).
Notation "l ∉ d" := (~ l ∈ d) (at level 60).

Section semantics.
  (* Selection and update go inside objects so they have to be defined on preobjects first. *)

  Definition empty_object := poempty Empty_type (assoc Empty_type).

  (* Properties of ∈ *)
  Lemma not_in_nil l : l ∉ nil.
  Proof.
    discriminate.
  Defined.

  Lemma in_cons_hd l d : l ∈ (cons l d).
  Proof.
    simpl.
    rewrite (string_dec_refl l).
    reflexivity.
  Defined.

  Lemma in_cons_tl l1 l2 d : l1 ∈ d -> l1 ∈ (cons l2 d).
  Proof.
    simpl.
    intro e.
    rewrite e.
    case (string_dec l1 l2) ; reflexivity.
  Defined.

  (* preselect was actually defined in proof mode like this: *)

  Fixpoint preselect l A f d (po : Preobject A f d) :
    l ∈ d -> Obj A -> Obj (f l).
  Proof.
    destruct po as [ | A f d l2 m tail ].
    - intro H.
      destruct (not_in_nil l H).
    - simpl.
      case (string_dec l l2).
      + intros e _.
        destruct e.
        apply Eval_meth.
        assumption.
      + intro.
        apply preselect.
        assumption.
  Defined.

  Definition select l A a (H : l ∈ (domain A)) : Obj (assoc A l) :=
    preselect l A (assoc A) (domain A) a H a.

  Fixpoint preupdate l (A : type) (f : string -> type) (d : list string)
           (po : Preobject A f d) :
    Method A (f l) -> Preobject A f d :=
    match
      po
    with
      | poempty A f => fun _ => poempty A f
      | pocons A f d l1 m p =>
        fun m1 =>
          match
            string_dec l l1
          with
            | left e =>
              pocons A f d l1
                     (eq_rect l (fun l2 => Method A (f l2)) m1 l1 e) p
            | right n =>
              pocons A f d l1 m (preupdate l A f d p m1)
          end
    end.

  Definition update A l (a : Obj A) m :=
    preupdate l A (assoc A) (domain A) a m.

  (* Specification of select: *)

  Theorem presel_cons_eq l A f d m1 po : preselect l A f (cons l d) (pocons A f d l m1 po) (in_cons_hd l d) = Eval_meth _ _ m1.
  Proof.
    simpl.
    unfold in_cons_hd.
    rewrite (string_dec_refl).
    reflexivity.
  Qed.

  Theorem presel_cons_diff l l2 A f d m1 po H :
    l <> l2 ->
    preselect l A f (cons l2 d) (pocons A f d l2 m1 po) (in_cons_tl l l2 d H)
    = preselect l A f d po H.
  Proof.
    intro diff.
    simpl.
    unfold in_cons_tl.
    case (string_dec l l2).
    - intro eq.
      destruct (diff eq).
    - intro diff2.
      apply f_equal.
      case H.
      reflexivity.
  Qed.

  (* Specification of update: *)

  Theorem preup_empty A f l m : preupdate l A f nil (poempty A f) m = poempty A f.
  Proof.
    reflexivity.
  Qed.

  Theorem preup_cons_eq A f d l po m1 m2 : preupdate l A f (cons l d) (pocons A f d l m1 po) m2 = pocons A f d l m2 po.
  Proof.
    unfold preupdate.
    rewrite string_dec_refl.
    apply f_equal2 ; reflexivity.
  Qed.

  Theorem preup_cons_diff A f d l l2 m1 m2 po :
    l <> l2 ->
    preupdate l A f (cons l2 d) (pocons A f d l2 m1 po) m2
    = pocons A f d l2 m1 (preupdate l A f d po m2).
  Proof.
    unfold preupdate.
    intro diff.
    case (string_dec l l2).
    - intro eq.
      destruct (diff eq).
    - intro diff2.
      reflexivity.
  Qed.
End semantics.

Notation "a # l" := (select l%string _ a%obj eq_refl) (at level 50) : object_scope.
Notation "o ## l ⇐ 'ς' ( x !: A ) m" := (update A l%string o (Make_meth A (assoc A l) (fun x => m))) (at level 50).

Section init.
  Fixpoint preinit A d :
    (forall l, l ∈ d -> l ∈ domain A) ->
    Preobject A (assoc A) d.
  Proof.
    destruct d as [ | l d ].
    - intro.
      apply poempty.
    - intro H.
      apply pocons.
      + apply Make_meth.
        intro a.
        apply select.
        * exact a.
        * apply H.
          apply in_cons_hd.
      + apply preinit.
        intros l1 H1.
        apply H.
        apply in_cons_tl.
        assumption.
  Defined.

  Definition init A : Obj A := preinit A (domain A) (fun _ H => H).
End init.

(* Definition of objects without respecting the order of labels given by the type. *)
Definition pocons_3 A (lm : sigT (fun l2 => Method A (assoc A l2))) (a : Obj A) :
  Obj A :=
  let (l, m) := lm in
  update A l a m.

Notation "[ m1 ; .. ; mn ]" := (pocons_3 _ m1%meth (.. (pocons_3 _ mn%meth (init _)) .. )) : object_scope.

Section examples.
  (* Encodding of booleans *)
  Definition Bool A : type :=
    [ "if" : A ; "then" : A ; "else" : A ]%ty.

  Definition true A : Obj (Bool A) :=
    [ "if" = ς(x !: Bool A) (x#"then") ]%obj.

  Definition false A : Obj (Bool A) :=
    [ "if" = ς(x !: Bool A) (x#"else") ]%obj.

  Theorem true_select A : ((true A)#"if")%obj = ((true A)#"then")%obj.
  Proof.
    unfold select.
    simpl.
    rewrite beta.
    reflexivity.
  Qed.

  Definition Ifthenelse A b t e :=
    (((b##"then" ⇐ ς(x !: Bool A) t)##"else" ⇐ ς(x !: Bool A) e)#"if")%obj.

  Notation "'IF' b 'THEN' t 'ELSE' e" := (Ifthenelse _ b t e) (at level 50) : object_scope.

  Theorem if_true A b c : Ifthenelse A (true A) b c = b.
  Proof.
    unfold Ifthenelse.
    unfold update.
    simpl.
    unfold select.
    simpl.
    rewrite beta.
    simpl.
    rewrite beta.
    reflexivity.
  Qed.

  Theorem if_false A b c : Ifthenelse A (false A) b c = c.
  Proof.
    unfold Ifthenelse.
    unfold update.
    simpl.
    unfold select.
    simpl.
    rewrite beta.
    simpl.
    rewrite beta.
    reflexivity.
  Qed.

  (* Encodding of the simply-typed λ-calculus *)

  Definition Arrow A B :=
    [ "arg" : A ; "val" : B ]%ty.

  Infix "→" := Arrow (at level 50).

  Definition Lambda A B (f : Obj A -> Obj B) : Obj (A → B) :=
    [ "val" = ς(x !: A → B) (f (x#"arg")) ]%obj.

  Notation "'λ' ( x !: A ) b" := (Lambda A _ (fun x : Obj A => b)) (at level 50).

  Definition App A B (f : Obj (A → B)) (a : Obj A) : Obj B :=
    ((f##"arg" ⇐ ς(x !: A → B) a)#"val")%obj.

  Infix "@" := (App _ _) (at level 50).

  Theorem beta_red A B f c : (Lambda A B f) @ c = f c.
  Proof.
    unfold Lambda, App.
    unfold update, select.
    simpl ; rewrite beta.
    apply f_equal.
    simpl ; rewrite beta.
    reflexivity.
  Qed.
End examples.

Section subtyping.
  (* We define directly type_dec instead of using the decide equality tactic
     in order to get an easier proof of type_dec_refl. *)

  Lemma diff_empty_cons l A B : Empty_type <> Cons_type l A B.
  Proof.
    discriminate.
  Defined.

  Lemma diff_cons_empty l A B : Cons_type l A B <> Empty_type.
  Proof.
    discriminate.
  Defined.

  Lemma eq_cons_cons lA A1 A2 lB B1 B2 : lA = lB -> A1 = B1 -> A2 = B2 -> Cons_type lA A1 A2 = Cons_type lB B1 B2.
  Proof.
    intros.
    destruct H.
    destruct H0.
    destruct H1.
    reflexivity.
  Defined.

  Definition eq_cons_cons_1 C :=
    match C with
      | Empty_type => ""%string
      | Cons_type l _ _ => l
    end.

  Definition eq_cons_cons_2 C :=
    match C with
      | Empty_type => Empty_type
      | Cons_type _ A _ => A
    end.

  Definition eq_cons_cons_3 C :=
    match C with
      | Empty_type => Empty_type
      | Cons_type _ _ A => A
    end.

  Fixpoint type_dec (A B : type) : {A = B} + {A <> B} :=
    match A with
      | Empty_type =>
        match B with
          | Empty_type => left eq_refl
          | Cons_type lB B1 B2 => right (diff_empty_cons lB B1 B2)
        end
      | Cons_type lA A1 A2 =>
        match B with
          | Empty_type => right (diff_cons_empty lA A1 A2)
          | Cons_type lB B1 B2 =>
            match string_dec lA lB with
              | left el =>
                match type_dec A1 B1 with
                  | left e1 =>
                    match type_dec A2 B2 with
                      | left e2 =>
                        left (eq_cons_cons lA A1 A2 lB B1 B2 el e1 e2)
                      | right n2 =>
                        right
                          (fun H : Cons_type lA A1 A2 = Cons_type lB B1 B2 =>
                             n2 (f_equal eq_cons_cons_3 H))
                    end
                  | right n1 =>
                    right
                      (fun H : Cons_type lA A1 A2 = Cons_type lB B1 B2 =>
                         n1 (f_equal eq_cons_cons_2 H))
                end
              | right nl =>
                right
                  (fun H : Cons_type lA A1 A2 = Cons_type lB B1 B2 =>
                     nl (f_equal eq_cons_cons_1 H))
            end
        end
    end.

  Theorem type_dec_refl A : type_dec A A = left (eq_refl A).
  Proof.
    induction A.
    - reflexivity.
    - simpl.
      rewrite string_dec_refl.
      rewrite IHA1.
      rewrite IHA2.
      reflexivity.
  Qed.

  (* Definition of the subtyping relation: A <: B if B is a subset of A. *)
  Fixpoint Subtype A B :=
    match B with
      | Empty_type => True
      | Cons_type l B1 B2 =>
        l ∈ domain A /\ B1 = assoc A l /\ Subtype A B2
    end.

  Infix "<:" := Subtype (at level 60).

  Lemma subtype_cons A B l C :
    A <: B ->
         l ∉ domain A ->
         Cons_type l C A <: B.
  Proof.
    induction B ; intros.
    - exact I.
    - simpl.
      destruct H as (H1, H2).
      case (string_dec s l) ; intro.
      + destruct e.
        destruct (H0 H1).
      + intuition.
  Qed.

  Section subtype_reflexivity.

    (* Unfortunately, the theorem forall A, A <: A is false
       when A has several occurences of the same label *)
    (* Hence we can only prove it for well-formed types: types without duplicates. *)
    Fixpoint well_formed_type A :=
      match A with
        | Empty_type => True
        | Cons_type l A1 A2 => l ∉ domain A2 /\ well_formed_type A2
      end.

    Theorem well_formed_dec A : {well_formed_type A} + {~ well_formed_type A}.
    Proof.
      induction A.
      - left.
        exact I.
      - simpl.
        destruct IHA2.
        + case (in_dom s (domain A2)).
          * right.
            intro H.
            destruct H as (H, _).
            destruct (H eq_refl).
          * left.
            split ; [discriminate | exact w].
        + right.
          intro H.
          destruct H as (H1, H2).
          exact (n H2).
    Defined.

    Theorem subtype_refl A : well_formed_type A -> A <: A.
    Proof.
      intro.
      induction A.
      - exact I.
      - simpl in *.
        split.
        + rewrite string_dec_refl.
          reflexivity.
        + rewrite string_dec_refl.
          split.
          reflexivity.
          destruct H.
          apply subtype_cons.
          * apply IHA2.
            assumption.
          * assumption.
    Defined.
  End subtype_reflexivity.

  (* The goal of the reminding of this section is to define a function
     coerce : forall A B, A <: B -> Obj A -> Obj B *)

  Lemma precast A B d : Obj A -> (forall l, l ∈ d -> l ∈ domain A) -> Preobject B (assoc A) d.
  Proof.
    intros a H.
    induction d as [ |  l d].
    - apply poempty.
    - apply pocons.
      + apply Make_meth.
        intro self.
        apply select.
        * exact a.
        * apply (H l).
          simpl.
          rewrite string_dec_refl.
          reflexivity.
      + apply IHd.
        intros.
        apply H.
        simpl.
        rewrite H0.
        case (string_dec l0 l) ; reflexivity.
  Defined.

  Lemma domain_subtype A B l : A <: B -> l ∈ domain B -> l ∈ domain A.
  Proof.
    induction B ; simpl.
    - discriminate.
    - intro H ; destruct H as (H1, (H2, H3)).
      case (string_dec l s) ; intros.
      + destruct e.
        assumption.
      + apply IHB2.
        * assumption.
        * assumption.
  Defined.

  Definition ocast A B : A <: B -> Obj A -> Preobject B (assoc A) (domain B).
  Proof.
    intros.
    apply precast.
    - assumption.
    - intro l.
      apply domain_subtype ; assumption.
  Defined.

  Lemma meth_eq A B1 B2 : B2 = B1 -> Method A B1 -> Method A B2.
    intros.
    rewrite H.
    assumption.
  Defined.

  Lemma coerce_1 A f g d : (forall l, l ∈ d -> f l = g l) -> Preobject A f d -> Preobject A g d.
  Proof.
    intros.
    induction X.
    - apply poempty.
    - apply pocons.
      + assert (Method A (f l) = Method A (g l)).
        * apply f_equal.
          apply H.
          apply in_cons_hd.
        * rewrite H0 in m.
          assumption.
      + apply IHX.
        intros.
        apply (H l0).
        apply in_cons_tl.
        assumption.
  Defined.

  Lemma assoc_subtype A B l : A <: B -> l ∈ domain B -> assoc A l = assoc B l.
  Proof.
    intro.
    induction B.
    - intro H0.
      apply not_in_nil in H0.
      destruct H0.
    - simpl.
      case (string_dec l s) ; intro.
      + destruct e.
        destruct H as (_, (H, _)).
        symmetry.
        assumption.
      + apply IHB2.
        destruct H as (_, (_, H)).
        assumption.
  Defined.

  Definition coerce A B : A <: B -> Obj A -> Obj B.
  Proof.
    intros.
    apply (coerce_1 B (assoc A) (assoc B) (domain B)).
    - intros.
      apply assoc_subtype ; assumption.
    - apply ocast ; assumption.
  Defined.
End subtyping.

Definition add_loop A d l : l ∈ domain A ->
                            Preobject A (assoc A) d -> Preobject A (assoc A) (cons l d).
Proof.
  intros Hd a.
  apply pocons.
  - apply Make_meth.
    intro self.
    apply select ; assumption.
  - assumption.
Defined.

Definition preupdate_inversion A f d l : l ∈ domain A ->
                                         f = assoc A ->
                                         forall a,
                                         l ∈ d ->
                                         exists m b,
                                           a = preupdate l A f d b m.
Proof.
  intros HdA Hf a.
  induction a as [ | A f d l1 m a ].
  - simpl.
    discriminate.
  - simpl.
    case (string_dec l l1).
    + intros e _.
      destruct e.
      symmetry in Hf.
      destruct Hf.
      exists m.
      exists (add_loop A d l HdA a).
      unfold add_loop.
      rewrite preup_cons_eq.
      reflexivity.
    + intros ldiff Hd.
      destruct (IHa HdA Hf Hd) as (m1, (b1, H1)).
      exists m1.
      exists (pocons A f d l1 m b1).
      rewrite preup_cons_diff.
      * rewrite H1.
        reflexivity.
      * assumption.
Defined.

Definition update_inversion A a l : l ∈ domain A ->
                                    exists m b, a = update A l b m :=
  fun Hd =>
    preupdate_inversion A (assoc A) (domain A) l Hd (eq_refl) a Hd.


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

- Stephane Le Roux, 2006-10-17
- Adam Koprowski, 2006-04-28
- Solange Coupet-Grimal and William Delobel, 2006-01-09
- Frederic Blanqui, 2005-02-03, 2009-07-06
- Sebastien Hinderer, 2004-05-25

extension of the Coq library on lists
*)

Set Implicit Arguments.

Require Import LogicUtil NatUtil EqUtil Setoid SetoidList RelMidex Omega
  RelUtil BoolUtil.
Require Export List.
Require Program.

Arguments nil {A}.
Arguments incl {A} l m.
Arguments in_app_or [A l m a] _.
Arguments in_map [A B] f [l x] _.
Arguments in_combine_l [A B l l' x y] _.
Arguments in_combine_r [A B l l' x y] _.
Arguments nth_In [A n l] d _.

Ltac elt_type l := match type of l with list ?A => A end.

Infix "[=" := incl (at level 70).

(***********************************************************************)
(** membership *)

Section In.

  Variable A : Type.

  Lemma in_app : forall l m (x : A), In x (l ++ m) <-> In x l \/ In x m.

  Proof. intuition. Qed.

  Lemma notin_app : forall l m (x : A), ~In x (l ++ m) <-> ~In x l /\ ~In x m.

  Proof. intuition. rewrite in_app in H0. intuition. Qed.

  Lemma in_appl : forall (x : A) l1 l2, In x l1 -> In x (l1 ++ l2).

  Proof.
    induction l1; simpl; intros. contr. destruct H. subst x. auto.
    right. apply IHl1. hyp.
  Qed.

  Lemma in_appr : forall (x : A) l1 l2, In x l2 -> In x (l1 ++ l2).

  Proof. induction l1; simpl; intros. hyp. right. apply IHl1. hyp. Qed.

  Lemma in_app_com : forall (x : A) l1 l2 l3,
    In x ((l1 ++ l3) ++ l2) -> In x ((l1 ++ l2) ++ l3).

  Proof. intros. rewrite !in_app in H. intuition. Qed.

  Lemma in_elim : forall (x : A) l,
    In x l -> exists l1, exists l2, l = l1 ++ x :: l2.

  Proof.
    induction l; simpl; intros. contr. destruct H. subst x.
    exists nil. exists l. refl. ded (IHl H). do 2 destruct H0. rewrite H0.
    exists (a :: x0). exists x1. refl.
  Qed.

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

  Lemma in_elim_dec : forall (x : A) l,
    In x l -> exists m, exists p, l = m ++ x :: p /\ ~In x m.

  Proof.
    induction l; simpl; intros. contr. destruct H. subst x.
    exists nil. exists l. intuition. ded (IHl H). do 3 destruct H0.
    subst l. case (eqA_dec a x); intro.
    subst x. exists nil. exists (x0 ++ a :: x1). intuition.
    exists (a :: x0). exists x1. intuition. simpl in H2. destruct H2; auto.
  Qed.

  Lemma In_midex : eq_midex A -> forall (x : A) l, In x l \/ ~In x l.

  Proof.
    induction l. tauto. simpl. destruct (H a x); destruct IHl; tauto.
  Qed.

  Lemma In_elim_right : eq_midex A -> forall (x : A) l,
    In x l -> exists l', exists l'', l = l'++x::l'' /\ ~In x l''.

  Proof.
    induction l; simpl; intros. contr.
    destruct (In_midex H x l). destruct IHl. hyp. destruct H2.
    exists (a::x0). exists x1. rewrite (proj1 H2).
    rewrite <- (app_comm_cons x0 (x::x1) a). tauto.
    destruct H0. exists nil. exists l. simpl. rewrite H0. tauto.
    contr.
  Qed.

  Lemma In_cons : forall (x a : A) l, In x (a::l) <-> a=x \/ In x l.

  Proof.
    intros. simpl. tauto.
  Qed.

  Lemma In_InA_eq : forall (x : A) l, In x l <-> InA eq x l.

  Proof.
    induction l; simpl. sym. apply InA_nil. rewrite IHl, InA_cons.
    intuition.
  Qed.

End In.

Implicit Arguments in_elim [A x l].
Implicit Arguments in_elim_dec [A x l].

Ltac intac := repeat (apply in_eq || apply in_cons).

Ltac list_ok := let x := fresh in intro x;
  match goal with
    | |- In _ ?l => vm_compute; destruct x; tauto
  end.

(***********************************************************************)
(** inclusion *)

Instance incl_rel A : PreOrder (@incl A).

Proof.
  constructor.
  intro x. apply incl_refl.
  intros x y z xy yz. apply incl_tran with y; hyp.
Qed.

Instance app_incl A : Proper (incl ==> incl ==> incl) (@app A).

Proof. intros l l' ll' m m' mm' x. rewrite !in_app. intuition. Qed.

Section incl.

  Variable A : Type.

  Lemma incl_nil_elim : forall l : list A, l [= nil <-> l = nil.

  Proof.
    unfold incl. destruct l; intuition. assert (In a (a::l)). left. refl.
    ded (H _ H0). contr. discr.
  Qed.

  Lemma incl_nil : forall l : list A, nil [= l.

  Proof. induction l. refl. apply incl_tl. hyp. Qed.

  Lemma incl_cons_l : forall (a : A) l m, a :: l [= m -> In a m /\ l [= m.

  Proof. intros a l m. unfold incl. simpl. intuition. Qed.

  Lemma incl_cons_l_in : forall (x : A) l m, x :: l [= m -> In x m.

  Proof. unfold incl. simpl. intros. apply H. left. refl. Qed.

  Lemma incl_cons_l_incl : forall (x : A) l m, x :: l [= m -> l [= m.

  Proof. unfold incl. simpl. intros. apply H. tauto. Qed.

  Lemma incl_app_elim : forall l1 l2 l3 : list A,
    l1 ++ l2 [= l3 -> l1 [= l3 /\ l2 [= l3.

  Proof.
    intuition.
    trans (l1 ++ l2). apply incl_appl. refl. hyp.
    trans (l1 ++ l2). apply incl_appr. refl. hyp.
  Qed.

  Lemma incl_appr_incl : forall l1 l2 l3 : list A, l1 ++ l2 [= l3 -> l1 [= l3.

  Proof.
    induction l1; intros. apply incl_nil.
    trans ((a::l1) ++ l2). 2: hyp. apply incl_appl. refl.
  Qed.

  Lemma incl_appl_incl : forall l1 l2 l3 : list A, l1 ++ l2 [= l3 -> l2 [= l3.

  Proof.
    induction l1; intros. hyp.
    trans ((a::l1) ++ l2). 2: hyp. apply incl_appr. refl.
  Qed.

  Lemma appl_incl : forall l l2 l2' : list A, l2 [= l2' -> l ++ l2 [= l ++ l2'.

  Proof. intros. apply app_incl. refl. hyp. Qed.

  Lemma appr_incl : forall l l1 l1' : list A, l1 [= l1' -> l1 ++ l [= l1' ++ l.

  Proof. intros. apply app_incl. hyp. refl. Qed.

  Lemma app_com_incl : forall l1 l2 l3 l4 : list A,
    (l1 ++ l3) ++ l2 [= l4 -> (l1 ++ l2) ++ l3 [= l4.

  Proof. unfold incl. intros. apply H. apply in_app_com. hyp. Qed.

  Lemma incl_cons_r : forall x : A, forall m l, l [= x :: m -> In x l \/ l [= m.

  Proof.
    induction l; simpl; intros. right. apply incl_nil.
    ded (incl_cons_l H). destruct H0. simpl in H0. destruct H0. auto.
    ded (IHl H1). destruct H2. auto.
    right. apply List.incl_cons; hyp.
  Qed.

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

  Lemma not_incl : forall l m, ~ l [= m <-> exists x:A, In x l /\ ~In x m.

  Proof.
    induction l; simpl; intros.
    (* nil *)
    intuition. absurd (nil[=m). hyp. apply incl_nil.
    do 2 destruct H. contr.
    (* cons *)
    split; intro.
    Focus 2. do 3 destruct H.
    subst. intro. apply H0. apply H. left. refl.
    intro. absurd (In x m). hyp. apply H1. right. hyp.
    Focus 1. case (In_dec eqA_dec a m); intro.
    assert (~l[=m). intro. apply H. unfold incl. intro b. simpl. intuition.
    rewrite IHl in H0. do 2 destruct H0. exists x. tauto.
    exists a. tauto.
  Qed.

End incl.

Implicit Arguments incl_app_elim [A l1 l2 l3].

(***********************************************************************)
(** strict inclusion *)

Definition strict_incl A (l m : list A) := l [= m /\ ~m [= l.

Infix "[" := strict_incl (at level 70).

Lemma strict_incl_tran : forall A (l m n : list A), l [ m -> m [ n -> l [ n.

Proof.
unfold strict_incl. intuition. trans m; hyp.
apply H2. trans n; hyp.
Qed.

Instance strict_incl_rel A : Transitive (@strict_incl A).

Proof. intros x y z xy yz. apply strict_incl_tran with y; hyp. Qed.

(***********************************************************************)
(** equivalence *)

Definition lequiv {A} (l1 l2 : list A) := l1 [= l2 /\ l2 [= l1.

Infix "[=]" := lequiv (at level 70).

Instance lequiv_rel A : Equivalence (@lequiv A).

Proof. fo. Qed.

Instance app_lequiv A : Proper (lequiv ==> lequiv ==> lequiv) (@app A).

Proof. intros l l' ll' m m' mm'. unfold lequiv in *. intuition. Qed.

Instance incl_lequiv1 A1 B (f : list A1 -> relation B) :
  Proper (incl ==> inclusion) f -> Proper (lequiv ==> same_rel) f.

Proof. intros hf l1 l1' [l1l1' l1'l1]. split; apply hf; hyp. Qed.

Instance incl_lequiv2 A1 A2 B (f : list A1 -> list A2 -> relation B) :
  Proper (incl ==> incl ==> inclusion) f ->
  Proper (lequiv ==> lequiv ==> same_rel) f.

Proof.
  intros hf l1 l1' [l1l1' l1'l1] l2 l2' [l2l2' l2'l2]. split; apply hf; hyp.
Qed.

(***********************************************************************)
(** empty list *)

Section nil.

  Variable A : Type.

  Lemma list_empty_dec : forall l : list A, {l = nil} + {l <> nil}.

  Proof. destruct l; auto. right; congruence. Qed.

  Definition is_empty (l : list A) : bool :=
    match l with
      | nil => true
      | _ => false
    end.

End nil.

(***********************************************************************)
(** cons *)

Instance cons_incl A : Proper (Logic.eq ==> incl ==> incl) (@cons A).

Proof. intros x x' xx'. subst x'. fo. Qed.

Instance cons_lequiv A : Proper (Logic.eq ==> lequiv ==> lequiv) (@cons A).

Proof. intros x x' xx'. subst x'. fo. Qed.

Section cons.

  Variable A : Type.

  Lemma cons_eq : forall x x' : A, forall l l',
    x = x' -> l = l' -> x :: l = x' :: l'.

  Proof. intros. rewrite H. rewrite H0. refl. Qed.

  Lemma head_eq : forall x x' : A, forall l, x = x' -> x :: l = x' :: l.

  Proof. intros. rewrite H. refl. Qed.

  Lemma tail_eq : forall x : A, forall l l', l = l' -> x :: l = x :: l'.

  Proof. intros. rewrite H. refl. Qed.

End cons.

(***********************************************************************)
(** append *)

Section app.

  Variable A : Type.

  Lemma length_app : forall l m : list A, length (l ++ m) = length l + length m.

  Proof. induction l; simpl; intros. refl. rewrite IHl. refl. Qed.

  Lemma app_nil : forall l1 l2 : list A, l1 = nil -> l2 = nil -> l1 ++ l2 = nil.

  Proof. intros. subst l1. subst l2. refl. Qed.

  Lemma app_eq : forall l1 l2 l1' l2' : list A,
    l1 = l1' -> l2 = l2' -> l1 ++ l2 = l1' ++ l2'.

  Proof. intros. rewrite H. rewrite H0. refl. Qed.

  Lemma appl_eq : forall l1 l2 l1' : list A, l1 = l1' -> l1 ++ l2 = l1' ++ l2.

  Proof. intros. rewrite H. refl. Qed.

  Lemma appr_eq : forall l1 l2 l2' : list A, l2 = l2' -> l1 ++ l2 = l1 ++ l2'.

  Proof. intros. rewrite H. refl. Qed.

  Lemma list_app_first_last : forall l m (a : A),
    (l ++ a::nil) ++ m = l ++ a::m.

  Proof.
    induction l. auto.
    intros m a'. rewrite <- !app_comm_cons. destruct (IHl m a'); trivial.
  Qed.

  Lemma list_app_last : forall l m n (a : A),
    l ++ m = n ++ a::nil -> m <> nil -> In a m.

  Proof.
    intros l m n; revert l m; induction n; simpl; intros.
    (* induction base *)
    destruct l.
    simpl in H; rewrite H; auto with datatypes.
    inversion H.
    absurd (m = nil); trivial.
    apply (proj2 (app_eq_nil l m H3)).
    (* induction case *)
    destruct l.
    simpl in H; rewrite H; auto with datatypes.
    inversion H.
    apply IHn with l; trivial.
  Qed.

  Lemma list_drop_last : forall l m n (a : A),
    l ++ m = n ++ a::nil -> m <> nil -> exists2 w, w [= m & l ++ w = n.

  Proof.
    induction l; intros.
    (* induction base *)
    simpl in H.
    exists n.
    rewrite H; auto with datatypes.
    auto.
    (* induction case *)
    destruct n.
    (* n = nil -> contr *)
    simpl in H.
    destruct (app_eq_unit (a::l) m H) as
      [[l_nil r_unit] | [l_unit r_nil]]; try contr.
    discr.
    (* n <> nil *)
    inversion H.
    destruct (IHl m n a0); trivial.
    exists x; trivial.
    rewrite <- H4.
    auto with datatypes.
  Qed.

  Lemma last_intro : forall l : list A, length l > 0 ->
    exists m, exists a, l = m ++ a :: nil /\ length m = length l - 1.

  Proof.
    induction l; simpl; intros. apply False_ind. omega.
    destruct l. exists nil. exists a. intuition.
    assert (length (a0::l) > 0). simpl. omega.
    ded (IHl H0). do 3 destruct H1.
    exists (a::x). exists x0. split. rewrite H1. refl.
    simpl. simpl in H2. omega.
  Qed.

End app.

(***********************************************************************)
(** length *)

Section length.

  Variable A : Type.

  Lemma length_0 : forall l : list A, length l = 0 -> l = nil.

  Proof. intros. destruct l. refl. discr. Qed.

End length.

Implicit Arguments length_0 [A l].

(***********************************************************************)
(** head & tail *)

Section head_tail.

  Variable A : Type.

  Lemma head_app : forall (l l': list A) (lne: l <> nil),
    head (l ++ l') = head l.

  Proof. destruct l. tauto. auto. Qed.

  Lemma length_tail : forall l : list A, length (tail l) <= length l.

  Proof. induction l; simpl; intros; omega. Qed.

  Lemma tail_in : forall (x: A) l, In x (tail l) -> In x l.

  Proof. intros. destruct l; auto with datatypes. Qed.

  Lemma tail_cons_tail : forall (l1 l2: list A),
    l1 <> nil -> tail l1 ++ l2 = tail (l1 ++ l2).

  Proof. destruct l1. tauto. auto. Qed.

  Lemma length_tail_minus : forall (l : list A), length (tail l) = length l - 1.

  Proof. destruct l; simpl; omega. Qed.

  Lemma list_decompose_head : forall (l : list A) el (lne: l <> nil),
    head l = Some el -> l = el :: tail l.

  Proof. intros. destruct l. discr. inversion H. rewrite <- H1; trivial. Qed.

  Lemma in_head_tail : forall a (l : list A),
    In a l -> Some a = head l \/ In a (tail l).

  Proof.
    induction l; intros; inversion H.
    left; simpl; rewrite H0; trivial.
    right; trivial.
  Qed.

  Lemma head_notNil : forall (l : list A) (lne : l <> nil),
    {a : A | head l = Some a}.

  Proof. destruct l. tauto. exists a; auto. Defined.

  Lemma head_of_notNil : forall (l : list A) a (lne: l <> nil),
    head l = Some a -> proj1_sig (head_notNil lne) = a.

  Proof. intros. destruct l; try discr. simpl; inversion H; trivial. Qed.

End head_tail.

Hint Resolve tail_in tail_cons_tail head_app : datatypes.
Hint Rewrite head_app length_app : datatypes.

(***********************************************************************)
(** tail_nth *)

Section tail_nth.

  Variable A : Type.

  Fixpoint tail_nth (l : list A) (n : nat) : option (list A) :=
    match l, n with
      | _, 0 => Some l
      | a :: l', S n' => tail_nth l' n'
      | _, _ => None
    end.

End tail_nth.

(***********************************************************************)
(** list filtering *)

Section filter.

  Variables (A : Type) (f : A -> bool).

  Lemma filter_app : forall l m, filter f (l ++ m) = filter f l ++ filter f m.

  Proof.
    induction l; simpl; intros. refl. rewrite IHl. destruct (f a); refl.
  Qed.

  Lemma filter_incl : forall l, filter f l [= l.

  Proof.
    induction l; simpl; intros. refl. case (f a); rewrite IHl.
    refl. apply incl_tl. refl.
  Qed.

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

  Lemma notIn_filter : forall x l,
    ~In x (filter f l) <-> ~In x l \/ (In x l /\ f x = false).

  Proof.
    intros. rewrite filter_In. intuition. case (In_dec eq_dec x l); intro.
    right. intuition. revert H. case (f x). irrefl. refl. auto.
    rewrite H2 in H3. discr.
  Qed.

End filter.

Section filter_opt.

  Variables (A B : Type) (f : A -> option B).

  Fixpoint filter_opt (l : list A) : list B :=
    match l with
      | nil => nil
      | cons a m =>
        match f a with
          | Some b => cons b (filter_opt m)
          | _ => filter_opt m
        end
    end.

End filter_opt.

(***********************************************************************)
(** boolean membership when the equality on A is decidable *)

Section Inb.

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

  Fixpoint Inb (x : A) (l : list A) : bool :=
    match l with
      | nil => false
      | cons y l' =>
        match eq_dec x y with
	  | left _ => true
	  | _ => Inb x l'
        end
    end.

  Lemma Inb_true : forall x l, Inb x l = true -> In x l.

  Proof. induction l; simpl. intro. discr. case (eq_dec x a); auto. Qed.

  Lemma Inb_false : forall x l, Inb x l = false -> In x l -> False.

  Proof.
    induction l; simpl. intros. contr. case (eq_dec x a).
    intros. discr. intros. destruct H0; auto.
  Qed.

  Lemma Inb_intro : forall x l, In x l -> Inb x l = true.

  Proof.
    induction l; simpl; intros. contr. case (eq_dec x a). auto.
    destruct H. intro. absurd (x = a); auto. auto.
  Qed.

  Lemma Inb_elim : forall x l, ~In x l -> Inb x l = false.

  Proof.
    induction l; simpl; intros. refl. case (eq_dec x a). intro. subst x.
    intuition. intuition.
  Qed.

  Lemma Inb_correct : forall x l, In x l <-> Inb x l = true.

  Proof.
    intuition. apply Inb_intro. hyp. apply Inb_true. hyp.
  Qed.

  Lemma Inb_incl : forall x l l', l [= l' -> Inb x l = true -> Inb x l' = true.

  Proof.
    intros. apply Inb_intro. apply H. apply Inb_true. hyp.
  Qed.

  Lemma Inb_equiv : forall x l l', lequiv l l' -> Inb x l = Inb x l'.

  Proof.
    intros. destruct H.
    case_eq (Inb x l'); intros; case_eq (Inb x l); intros; try refl.
    ded (Inb_incl _ H0 H1). rewrite H2 in H3. discr.
    ded (Inb_incl _ H H2). rewrite H1 in H3. discr.
  Qed.

  Definition Inclb (l1 l2 : list A) := forallb (fun x => Inb x l2) l1.

  Lemma Inclb_ok : forall l1 l2, Inclb l1 l2 = true <-> l1 [= l2.

  Proof.
    intros. induction l2. unfold Inclb. simpl. case l1. simpl; split; auto.
    intro. refl.
    intros. simpl; split; intro. discr.
    rewrite incl_nil_elim in H. discr.
    split; unfold Inclb; simpl; rewrite forallb_forall; intro.
    intros x Hx. gen (H _ Hx). case (eq_dec x a); intros.
    rewrite e; apply in_eq. apply in_cons. apply Inb_true; auto.
    intros. case (eq_dec x a); auto; intros.
    destruct (in_inv (H _ H0)); auto. apply Inb_intro; auto.
  Qed.

End Inb.

Ltac inbtac :=
  match goal with
    | _ : In ?x ?l |- _ =>
      let H0 := fresh "H" in
	(assert (H0 : Inb x l = true); apply Inb_intro; hyp; rewrite H0)
  end.

(***********************************************************************)
(** remove *)

Section remove.

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

  Fixpoint remove (y : A) (l : list A) : list A :=
    match l with
      | nil => nil
      | cons x l' =>
        match eq_dec x y with
	  | left _ => remove y l'
	  | right _ => cons x (remove y l')
        end
    end.

  Lemma length_remove : forall (x : A) l, length (remove x l) <= length l.

  Proof.
    induction l; simpl; intros. apply le_O_n. destruct (eq_dec a x).
    apply le_trans with (length l). apply IHl. apply le_n_Sn. simpl.
    apply le_n_S. apply IHl.
  Qed.

  Lemma In_length_remove : forall (x : A) l,
    In x l -> length (remove x l) < length l.

  Proof.
    induction l; simpl; intros. contr. destruct (eq_dec a x).
    apply le_lt_n_Sm.
    apply length_remove. destruct H. rewrite H in n. tauto. simpl. apply lt_n_S.
    apply IHl. hyp.
  Qed.

  Lemma In_remove : forall (x y : A) l, x <> y -> In y l -> In y (remove x l).

  Proof.
    induction l; simpl; intros. hyp.
    destruct (eq_dec a x); destruct H0. rewrite e in H0. tauto.
    tauto. rewrite H0. simpl. tauto. simpl. tauto.
  Qed.

  Lemma incl_remove : forall (x : A) l m, ~In x l -> l [= m -> l [= remove x m.

  Proof.
    induction l; simpl; intros. apply incl_nil. assert (~a=x /\ ~In x l). tauto.
    unfold incl. intros. simpl in H2. destruct H2. subst a0.
    apply In_remove. auto. unfold incl in H0. apply H0. simpl. auto.
    apply IHl. auto. apply incl_cons_l_incl with (x := a). exact H0. exact H2.
  Qed.

  Lemma notin_remove : forall x l, In x (remove x l) -> False.

  Proof.
    induction l; simpl. auto. destruct (eq_dec a x). auto. simpl. tauto.
  Qed.

  Lemma remove_In : forall a x l, In a (remove x l) -> In a l.

  Proof.
    induction l;intros. simpl in *. auto.
    simpl in H. destruct (eq_dec a0 x).
    subst; simpl; right; auto.
    simpl in *; tauto.
  Qed.

  Lemma remove_eq : forall a x l, In a (remove x l) <-> a <> x /\ In a l.

  Proof.
    intuition. subst. eapply notin_remove. apply H. eapply remove_In. apply H.
    apply In_remove; auto.
  Qed.

End remove.

(***********************************************************************)
(** removes *)

Section removes.

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

  Notation In_dec := (In_dec eqdec).

  Fixpoint removes (l m : list A) : list A :=
    match m with
      | nil => nil
      | x :: m' =>
        match In_dec x l with
          | left _ => removes l m'
          | right _ => x :: removes l m'
        end
    end.

  Lemma incl_removes : forall l m, removes l m [= m.

  Proof.
    unfold incl. induction m; simpl. contr.
    case (In_dec a l). intros. right. apply IHm. hyp.
    simpl. intuition.
  Qed.

  Lemma incl_removes_app : forall l m, m [= removes l m ++ l.

  Proof.
    unfold incl. induction m; simpl. contr. intros. destruct H.
    subst a0. case (In_dec a l); intro. apply in_appr. hyp. simpl. auto.
    case (In_dec a l); intro. apply IHm. hyp. simpl.
    case (eqdec a a0); intro. subst a0. auto. right. apply IHm. hyp.
  Qed.

  Lemma In_removes : forall x l m, In x (removes l m) <-> In x m /\ ~In x l.

  Proof.
    induction m; simpl; intros. tauto. case (In_dec a l); intro. rewrite IHm.
    fo. subst. contr. simpl. rewrite IHm. fo. subst.
    hyp.
  Qed.

End removes.

(***********************************************************************)
(** map *)

Section map.

  Variable (A B : Type) (f : A->B).

  Lemma map_app : forall l1 l2, map f (l1 ++ l2) = (map f l1) ++ map f l2.

  Proof.
    induction l1; simpl; intros. refl. rewrite IHl1. refl.
  Qed.

  Lemma in_map_elim : forall x l, In x (map f l) -> exists y, In y l /\ x = f y.

  Proof.
    induction l; simpl; intros. contr. destruct H.
    exists a. auto. ded (IHl H). do 2 destruct H0. exists x0. auto.
  Qed.

  Lemma map_eq : forall (g : A->B) l,
    (forall x, In x l -> f x = g x) -> map f l = map g l.

  Proof.
    induction l; simpl; intros. refl. apply cons_eq. ded (H a). intuition.
    apply IHl. intro. ded (H x). intuition.
  Qed.

End map.

Implicit Arguments in_map_elim [A B f x l].

Lemma map_eq_id : forall A (f:A->A) l,
  (forall x, In x l -> f x = x) -> map f l = l.

Proof.
induction l; simpl; intros. refl. apply cons_eq. ded (H a). intuition.
apply IHl. intro. ded (H x). intuition.
Qed.

(***********************************************************************)
(** flat_map *)

Section flat_map.

  Variables (A B : Type) (f : A -> list B).

  Lemma In_flat_map_intro : forall x l y,
    In y l -> In x (f y) -> In x (flat_map f l).

  Proof.
    intros. apply (proj2 (@in_flat_map _ _ f l x)).
    exists y. auto.
  Qed.

  Lemma In_flat_map_elim : forall l y,
    In y (flat_map f l) -> exists x, In x l /\ In y (f x).

  Proof.
    intros. exact (proj1 (@in_flat_map _ _ _ _ _) H).
  Qed.

  Lemma flat_map_app : forall l m,
    flat_map f (l ++ m) = flat_map f l ++ flat_map f m.

  Proof.
    induction l; simpl; intros. refl. rewrite IHl. rewrite app_ass. refl.
  Qed.

End flat_map.

(***********************************************************************)
(** flattening *)

Section flat.

  Variable A : Type.

  Fixpoint flat (l : list (list A)) : list A :=
    match l with
      | nil => nil
      | cons x l' => x ++ flat l'
    end.

  Lemma In_incl_flat : forall x l, In x l -> x [= flat l.

  Proof.
    induction l; simpl; intros. contr. intuition. subst. apply incl_appl. refl.
  Qed.

  Lemma incl_flat_In : forall x c cs l,
    In x c -> In c cs -> flat cs [= l -> In x l.

  Proof. intros. apply H1. apply (In_incl_flat _ _ H0). hyp. Qed.

End flat.

Implicit Arguments In_incl_flat [A x l].

(***********************************************************************)
(** element & replacement at a position *)

Section Element_At_List.

  Variable A : Type.

  Fixpoint element_at (l : list A) (p : nat) : option A :=
    match l with
      | nil => None
      | h :: t =>
	match p with
          | 0 => Some h
          | S p' => element_at t p'
        end
    end.

  Notation "l '[' p ']'" := (element_at l p) (at level 50).

  Fixpoint replace_at (l : list A) (p : nat) (a : A) : list A :=
    match l with
      | nil => nil
      | h :: t =>
	match p with
          | 0 => a :: t
          | S p' => h :: (replace_at t p' a)
        end
    end.

  Notation "l '[' p ':=' a ']'" := (replace_at l p a) (at level 50).

  Lemma element_at_exists : forall l p,
    p < length l <-> ex (fun a => l[p] = Some a).

  Proof.
    intro l; induction l as [ | h t IHl].
    simpl; intro p; split; intro H; [inversion H | inversion H as [x Hx]].
    inversion Hx.
    simpl; intro p; split.
    intro Hp; destruct p as [ | p].
    exists h; trivial.
    assert (Hp' : p < length t).
    gen Hp; auto with arith.
    elim (IHl p); intros H1 H2.
    elim (H1 Hp'); intros a Ha; exists a; trivial.
    destruct p as [ | p]; intro H.
    auto with arith.
    elim (IHl p); intros H1 H2.
    gen (H2 H); auto with arith.
  Qed.

  Lemma element_at_replaced : forall l p a, p < length l -> l[p:=a][p] = Some a.

  Proof.
    intro l; induction l as [ | h t IHl]; simpl; intros p a Hlength.
    inversion Hlength.
    destruct p as [ | p]; simpl.
    trivial.
    apply IHl; gen Hlength; auto with arith.
  Qed.

  Lemma element_at_not_replaced : forall l p q a, p <> q -> l[p] = l[q:=a][p].

  Proof.
    intro l; induction l as [ | h t IHl]; intros p q a p_neq_q; simpl.
    trivial.
    destruct p as [ | p'].
    destruct q as [ | q']; simpl.
    elim p_neq_q; trivial.
    trivial.
    destruct q as [ | q']; simpl.
    trivial.
    apply IHl.
    intro H; apply p_neq_q; subst; trivial.
  Qed.

  Lemma in_exists_element_at :
    forall l a, In a l -> ex (fun p => l[p] = Some a).

  Proof.
    intro l; induction l as [ | h t IHl]; intros a a_in_l.
    inversion a_in_l.
    elim a_in_l; clear a_in_l; intro a_in_l.
    exists 0; subst; trivial.
    elim (IHl a a_in_l); intros p Hp.
    exists (S p); simpl; trivial.
  Qed.

  Lemma exists_element_at_in :
    forall l a, ex (fun p => l[p] = Some a) -> In a l.

  Proof.
    intro l; induction l as [ | h t IHl]; intros a Hex;
      elim Hex; clear Hex; intros p Hp.
    inversion Hp.
    destruct p as [ | p]; inversion Hp.
    left; trivial.
    right; apply IHl; exists p; trivial.
  Qed.

  Lemma element_at_in : forall (x:A) l n, l[n] = Some x -> In x l.

  Proof.
    induction l; simpl; intros. discr. destruct n.
    inversion H. subst. auto. ded (IHl _ H). auto.
  Qed.

  Lemma element_at_in2 :
    forall (x:A) l n, l[n] = Some x -> In x l /\ n < length l.

  Proof.
    induction l; intros; simpl in H; try discr. destruct n.
    inversion H; subst; simpl; auto with *.
    ded (IHl n H). intuition; simpl; omega.
  Qed.

  Lemma element_at_app_r : forall l l' p,
    p >= length l -> (l ++ l') [p] = l' [p - length l].

  Proof.
    induction l. intuition.
    intros. destruct p.
    inversion H.
    simpl. apply IHl. simpl in H. auto with arith.
  Qed.

  Lemma replace_at_app_r : forall l l' p a,
    p >= length l -> (l ++ l') [p := a] = l ++ l' [p - length l := a].

  Proof.
    induction l; intros.
    simpl. rewrite <- minus_n_O. refl.
    destruct p. inversion H.
    simpl. rewrite IHl. refl. intuition.
  Qed.

End Element_At_List.

Implicit Arguments element_at_in [A x l n].
Implicit Arguments element_at_in2 [A x l n].
Implicit Arguments in_exists_element_at [A l a].
Implicit Arguments element_at_exists [A l p].

Notation "l '[' p ']'" := (element_at l p) (at level 50) : list_scope.
Notation "l '[' p ':=' a ']'" := (replace_at l p a) (at level 50) : list_scope.

(***********************************************************************)
(** one_less *)

Section one_less.

  Variables (A : Type) (r : relation A).

  Inductive one_less : relation (list A) :=
    | one_less_cons : forall (l l' : list A) (p : nat) (a a' : A),
      r a a' -> l[p] = Some a -> l' = l[p:=a'] -> one_less l l'.

  Lemma one_less_length : forall l l', one_less l l' -> length l = length l'.

  Proof.
    intro l; induction l as [ | h t IHl]; intros l' Hr.
    inversion Hr; subst.
    simpl; trivial.
    inversion Hr; subst; simpl.
    destruct p as [ | p].
    simpl; trivial.
    simpl; rewrite IHl with (t[p:=a']); trivial.
    apply (@one_less_cons t (t[p:=a']) p a a'); trivial.
  Qed.

End one_less.

Implicit Arguments one_less [A].
Implicit Arguments one_less_cons [A].

(***********************************************************************)
(** reverse *)

Section reverse.

  Variable A : Type.

  Lemma in_rev : forall (x : A) l, In x l -> In x (rev l).

  Proof.
    induction l; simpl; intros. hyp. apply in_or_app. simpl. tauto.
  Qed.

  Lemma incl_rev : forall l : list A, l [= rev l.

  Proof.
    unfold incl. intros. apply in_rev. hyp.
  Qed.

  Lemma rev_incl : forall l : list A, rev l [= l.

  Proof.
    intros. pose (incl_rev (rev l)). rewrite (rev_involutive l) in i. hyp.
  Qed.

  Lemma incl_rev_intro : forall l l' : list A, rev l [= rev l' -> l [= l'.

  Proof.
    intros. trans (rev l). apply incl_rev. trans (rev l'). hyp. apply rev_incl.
  Qed.

End reverse.

Section reverse_tail_recursive.

  Variable A : Type.

  Fixpoint rev_append (l' l : list A) : list A :=
    match l with
      | nil => l'
      | a :: l => rev_append (a :: l') l
    end.

  Notation rev' := (rev_append nil).

  Lemma rev_append_rev : forall l l', rev_append l' l = rev l ++ l'.

  Proof. induction l; simpl; auto; intros. rewrite <- ass_app; fo. Qed.

  Lemma rev_append_app : forall l l' acc : list A,
    rev_append acc (l ++ l') = rev_append (rev_append acc l) l'.

  Proof. induction l; simpl; intros. refl. rewrite IHl. refl. Qed.

  Lemma rev'_app : forall l l' : list A, rev' (l ++ l') = rev' l' ++ rev' l.

  Proof.
    intros. rewrite rev_append_app, !rev_append_rev, <- !app_nil_end. refl.
  Qed.

  Lemma rev'_rev : forall l : list A, rev' l = rev l.

  Proof. intro. rewrite rev_append_rev, <- app_nil_end. refl. Qed.

  Lemma rev'_rev' : forall l : list A, rev' (rev' l) = l.

  Proof. intro. rewrite !rev'_rev. apply rev_involutive. Qed.

  Lemma rev'_cons : forall a (l : list A), rev' (a::l) = rev' l ++ (a::nil).

  Proof.
    intros. change (rev' ((a::nil) ++ l) = rev' l ++ (a::nil)).
    rewrite rev'_app. refl.
  Qed.

End reverse_tail_recursive.

Notation rev' := (rev_append nil).

(***********************************************************************)
(** split *)

Section split.

  Variable A : Type.

  Fixpoint split_aux (acc l : list A) (n : nat) : option (list A * list A) :=
    match l, n with
      | _, 0 => Some (rev' acc, l)
      | a :: l', S n' => split_aux (a::acc) l' n'
      | _, _ => None
    end.

  Lemma split_aux_correct : forall l n l1 l2 acc,
    split_aux acc l n = Some (l1, l2) -> rev' acc ++ l = l1 ++ l2.

  Proof.
    induction l; destruct n; simpl; intros. inversion H. refl. discr.
    inversion H. refl. ded (IHl _ _ _ _ H). rewrite rev'_cons in H0.
    rewrite app_ass in H0. hyp.
  Qed.

  Implicit Arguments split_aux_correct [l n l1 l2].

  Notation split := (split_aux nil).

  Lemma split_correct : forall l n l1 l2,
    split l n = Some (l1, l2) -> l = l1 ++ l2.

  Proof.
    intros. change (rev' nil ++ l = l1 ++ l2). apply (split_aux_correct _ H).
  Qed.

End split.

Notation split := (split_aux nil).

Implicit Arguments split_correct [A l n l1 l2].

(***********************************************************************)
(** last element *)

Section last.

  Variable A : Type.

  Lemma last_nth : forall (d : A) l, last l d = nth (length l - 1) l d.

  Proof.
    induction l; simpl; intros. refl. rewrite IHl.
    elim l; simpl; intros. refl. destruct l0; simpl. refl. refl.
  Qed.

  Lemma last_default : forall (d1 : A) d2 l, l <> nil -> last l d1 = last l d2.

  Proof.
    induction l; simpl; intros. irrefl. destruct l. refl. apply IHl. discr.
  Qed.

End last.

Implicit Arguments last_intro [A l].

(***********************************************************************)
(** partition *)

Section partition.

  Variables (A : Type) (f : A -> bool) (a : A) (l : list A).

  Lemma partition_complete : let p := partition f l in
    In a l -> In a (fst p) \/ In a (snd p).

  Proof.
    induction l. auto.
    simpl. intro. destruct (partition f l0). destruct H.
    destruct (f a0); simpl; auto.
    destruct (f a0); simpl in *; destruct IHl0; auto.
  Qed.

  Lemma partition_inleft : In a (fst (partition f l)) -> In a l.

  Proof.
    induction l. auto.
    simpl. intro. destruct (partition f l0). destruct (f a0).
    destruct H; auto.
    right. apply IHl0. auto.
  Qed.

  Lemma partition_inright : In a (snd (partition f l)) -> In a l.

  Proof.
    induction l. auto.
    simpl. intro. destruct (partition f l0). destruct (f a0).
    right. apply IHl0. auto.
    destruct H; auto.
  Qed.

  Lemma partition_left : In a (fst (partition f l)) -> f a = true.

  Proof.
    induction l; simpl. auto.
    destruct (partition f l0). destruct (bool_dec (f a0) true).
    rewrite e. intro. destruct H.
    subst a0. hyp.
    apply IHl0. hyp.
    rewrite (not_true_is_false (f a0)); hyp.
  Qed.

  Lemma partition_right : In a (snd (partition f l)) -> f a = false.

  Proof.
    induction l; simpl. intuition.
    destruct (partition f l0). destruct (bool_dec (f a0) true).
    rewrite e. apply IHl0.
    rewrite (not_true_is_false (f a0)). intro. destruct H.
    subst a0. destruct (f a); intuition.
    apply IHl0. hyp. hyp.
  Qed.

End partition.

Section partition_by_prop.

  Variables (A : Type) (P : A -> Prop) (P_dec : forall x, {P x}+{~P x}).

  Definition partition_by_prop a :=
    match P_dec a with
    | left _ => true
    | right _ => false
    end.

  Lemma partition_by_prop_true : forall a, partition_by_prop a = true -> P a.

  Proof.
    intros. unfold partition_by_prop in H.
    destruct (P_dec a). hyp. discr.
  Qed.

End partition_by_prop.

Section partition_by_rel.

  Variables (A : Type) (R : relation A) (R_dec : rel_dec R).

  Definition partition_by_rel p :=
    if R_dec (fst p) (snd p) then true else false.

  Lemma partition_by_rel_true : forall a b,
    partition_by_rel (a, b) = true -> R a b.

  Proof.
    intros. unfold partition_by_rel in H. simpl in H.
    destruct (R_dec a b). hyp. discr.
  Qed.

End partition_by_rel.

(***********************************************************************)
(** listfilter *)

Section ListFilter.

  Variable A : Type.

  Fixpoint listfilter (L : list A) l :=
    match L with
      | nil => nil
      | a :: Q =>
        match l with
          | nil => nil
          | true :: q => a :: listfilter Q q
          | false :: q => listfilter Q q
        end
    end.

  Lemma listfilter_in : forall L l i x,
    L[i]=Some x -> l[i]=Some true -> In x (listfilter L l) .

  Proof.
    induction L.
    intros. simpl in *. discr.

    intros.
    destruct i; simpl in H.
    simpl.
    inversion H; subst.
    destruct l; simpl in *. discr.
    inversion H0; subst. simpl; left; auto.

    destruct l; auto. simpl in H0; discr.
    inversion H0.
    simpl.
    destruct b.
    right. eapply IHL; eauto.
    eapply IHL; eauto.
  Qed.

End ListFilter.

(****************************************************************************)
(** nth/nth_error *)

Section ListsNth.

  Variable A: Type.

  Lemma In_nth : forall A d (x : A) l,
    In x l -> exists i, i < length l /\ nth i l d = x.

  Proof.
    induction l; simpl; intros. contr. destruct H.
    subst. exists 0. intuition.
    destruct (IHl H) as [i hi]. exists (S i). intuition.
  Qed.

  Lemma nth_error_In : forall (l : list A) i,
    {a : A | nth_error l i = Some a} + {nth_error l i = None}.

  Proof.
    induction l.
    right; compute; case i; trivial.
    intro i.
    case i.
    left; exists a; trivial.
    intro n.
    destruct (IHl n) as [[a' a'nth] | nth_none].
    left; exists a'; trivial.
    right; trivial.
  Qed.

  Lemma nth_some_in :
    forall (l : list A) i a, nth_error l i = Some a -> In a l.

  Proof.
    induction l; intros.
    destruct i; simpl in *; discr.
    destruct i; simpl in *.
    left; compute in *; congruence.
    right; eapply IHl; eauto.
  Qed.

  Lemma list_In_nth : forall (l : list A) a,
    In a l -> exists p: nat, nth_error l p = Some a.

  Proof.
    induction l.
    contr.
    intros; destruct H.
    exists 0.
    rewrite H; trivial.
    destruct (IHl a0 H).
    exists (S x); trivial.
  Qed.

  Lemma nth_app_left : forall (l m: list A) i,
    i < length l -> nth_error (l ++ m) i = nth_error l i.

  Proof.
    induction l; simpl; intros m i i_l.
    absurd_arith.
    destruct i; simpl.
    trivial.
    apply (IHl m i).
    auto with arith.
  Qed.

  Lemma nth_app_right : forall (l m: list A) i, i >= length l ->
     nth_error (l ++ m) i = nth_error m (i - length l).

  Proof.
    induction l; simpl; intros m i i_l.
    auto with arith.
    destruct i; simpl.
    absurd_arith.
    apply IHl.
    auto with arith.
  Qed.

  Lemma nth_app : forall (l m: list A) a i, nth_error (l ++ m) i = Some a ->
    (nth_error l i = Some a /\ i < length l) \/
    (nth_error m (i - length l) = Some a /\ i >= length l).

  Proof.
    intros.
    destruct (le_lt_dec (length l) i).
    right; split; trivial.
    rewrite (nth_app_right l m l0) in H; trivial.
    left; split; trivial.
    rewrite (nth_app_left l m l0) in H; trivial.
  Qed.

  Lemma nth_beyond : forall (l : list A) i,
    i >= length l -> nth_error l i = None.

  Proof.
    induction l; simpl; intro i.
    destruct i; trivial.
    destruct i; simpl.
    intros.
    absurd_arith.
    intro.
    rewrite (IHl i); trivial.
    auto with arith.
  Qed.

  Lemma nth_beyond_idx : forall (l : list A) i,
    nth_error l i = None -> i >= length l.

  Proof.
    induction l; simpl; intro i.
    auto with arith.
    destruct i; simpl.
    intros.
    discr.
    intro.
    assert (i >= length l).
    apply (IHl i); trivial.
    auto with arith.
  Qed.

  Lemma nth_in : forall (l : list A) i,
    nth_error l i <> None <-> i < length l.

  Proof.
    induction l; simpl; intro i.
    split.
    destruct i; intro; elimtype False; auto.
    intro; absurd_arith.
    destruct i; simpl.
    split; intro.
    auto with arith.
    discr.
    split; intro.
    assert (i < length l).
    apply (proj1 (IHl i)); trivial.
    auto with arith.
    apply (proj2 (IHl i)); auto with arith.
  Qed.

  Lemma nth_some : forall (l : list A) n a,
    nth_error l n = Some a -> n < length l.

  Proof.
    intros.
    apply (proj1 (nth_in l n)).
    rewrite H; discr.
  Qed.

  Lemma nth_map_none : forall (l : list A) i (f: A -> A),
    nth_error l i = None -> nth_error (map f l) i = None.

  Proof.
    induction l.
    trivial.
    intros i f; destruct i; simpl.
    intro; discr.
    apply IHl.
  Qed.

  Lemma nth_map_none_rev : forall (l : list A) i (f: A -> A),
    nth_error (map f l) i = None -> nth_error l i = None.

  Proof.
    induction l.
    trivial.
    intros i f; destruct i; simpl.
    intro; discr.
    apply IHl.
  Qed.

  Lemma nth_map_some : forall (l : list A) i (f: A -> A) a,
    nth_error l i = Some a -> nth_error (map f l) i = Some (f a).

  Proof.
    induction l.
    destruct i; intros; discr.
    intros i f a'.
    destruct i; simpl.
    intro aa'; inversion aa'; trivial.
    apply IHl.
  Qed.

  Lemma nth_map_some_rev : forall (l : list A) i (f: A -> A) a,
    nth_error (map f l) i = Some a ->
    exists a', nth_error l i = Some a' /\ f a' = a.

  Proof.
    induction l.
    destruct i; intros; discr.
    intros i f a'.
    destruct i; simpl.
    intros aa'; inversion aa'; exists a; auto.
    apply IHl.
  Qed.

  Lemma nth_error_singleton_in : forall (a b: A) i,
    nth_error (a :: nil) i = Some b -> a = b /\ i = 0.

  Proof.
    intros.
    destruct i.
    inversion H; auto.
    inversion H; destruct i; discr.
  Qed.

End ListsNth.

Implicit Arguments In_nth [A x l].

(****************************************************************************)
(** ith *)

Unset Strict Implicit.
Set Contextual Implicit.

Section ith.

  Variable A : Type.

  Fixpoint ith (l : list A) : forall i, i < length l -> A :=
    match l as l return forall i, i < length l -> A with
      | nil => fun i H => False_rect A (lt_n_O H)
      | cons x m => fun i =>
        match i return i < S (length m) -> A with
	  | O => fun _ => x
	  | S j => fun H => ith (lt_S_n H)
        end
    end.

  Lemma ith_In : forall l i (h : i < length l), In (ith h) l.

  Proof.
    induction l; simpl; intros. omega. destruct i. auto. right. apply IHl.
  Qed.

  Lemma ith_eq : forall l i (hi : i < length l) j (hj : j < length l),
    i = j -> ith hi = ith hj.

  Proof.
    intros. subst j. rewrite (lt_unique hi hj). refl.
  Qed.

  Lemma ith_eq_app : forall m l i (hi : i < length (l++m))
    j (hj : j < length l), i = j -> ith hi = ith hj.

  Proof.
    induction l; simpl; intros. contradict hj; omega. subst j.
    destruct i. refl. apply IHl. refl.
  Qed.

End ith.

Implicit Arguments ith_In [A l i].

(****************************************************************************)
(** list of values of a function *)

Section values.

  Variables (A : Type) (f : nat -> A).

  Fixpoint values j : list A :=
    match j with
      | 0 => nil
      | S k => f k :: values k
    end.

End values.

(****************************************************************************)
(** list of values of a partial function *)

Section pvalues.

  Variable A : Type.

  Fixpoint pvalues n : (forall i, i < n -> A) -> list A :=
    match n as n return (forall i, i < n -> A) -> list A with
      | 0 => fun _ => nil
      | S k => fun f =>
        f 0 (lt_O_Sn k) :: pvalues (fun i h => f (S i) (lt_n_S h))
    end.

  Lemma pvalues_eq : forall n (f g : forall i, i < n -> A),
    (forall i (hi : i < n), f i hi = g i hi) -> pvalues f = pvalues g.

  Proof.
    induction n; intros; simpl. refl. apply cons_eq. apply H. apply IHn.
    intros. apply H.
  Qed.

End pvalues.

Section pvalues_map.

  Variables (A B : Type) (f : A -> B).

  Definition f_ith (l : list A) i (hi : i < length l) := f (ith hi).

  Lemma pvalues_ith_eq_map : forall l, pvalues (@f_ith l) = map f l.

  Proof.
    induction l; intros; unfold f_ith; simpl. refl. apply tail_eq.
    rewrite <- IHl. apply pvalues_eq. intros. unfold f_ith. apply (f_equal f).
    apply ith_eq. refl.
  Qed.

End pvalues_map.

(***********************************************************************)
(** lists of bounded natural numbers *)

Definition nat_lts n := list (nat_lt n).

Lemma in_map_val : forall n (l : nat_lts n) i, In i (map (@val n) l) -> i<n.

Proof.
intros. destruct (in_map_elim H). destruct H0. subst. destruct x. simpl. hyp.
Qed.

Implicit Arguments in_map_val [n l i].

Section mk_nat_lts.

  Variable n : nat.

  Lemma mk_nat_lts_aux1 : forall k', S k' < n -> k' < n.

  Proof. Omega. Qed.

  (* mk_nat_lts_aux hk = k :: ... :: 0 *)

  Fixpoint mk_nat_lts_aux k :=
    match k as k return k<n -> list (nat_lt n) with
      | 0 => fun h => mk_nat_lt h :: nil
      | S k' => fun h => mk_nat_lt h :: mk_nat_lts_aux k' (mk_nat_lts_aux1 h)
    end.

  Lemma mk_nat_lts_aux_correct : forall x k (h : k<n) i,
    i <= k -> val (nth i (mk_nat_lts_aux h) x) = k - i.

  Proof.
    induction k; simpl; intros; destruct i. auto. absurd_arith.
    auto. rewrite IHk. auto. omega.
  Qed.

  Lemma mk_nat_lts_aux_complete : forall k (h : k<n) i (p : i<n),
    i <= k -> In (mk_nat_lt p) (mk_nat_lts_aux h).

  Proof.
    induction k; simpl; intros.
    assert (i=0). omega. subst. assert (h=p). apply lt_unique. subst. auto.
    destruct (lt_ge_dec i (S k)). right. apply IHk. omega.
    assert (i=S k). omega. subst. assert (h=p). apply lt_unique. subst. auto.
  Qed.

End mk_nat_lts.

Implicit Arguments mk_nat_lts_aux [].

(* mk_nat_lts n = n-1 :: ... :: 0 *)

Definition mk_nat_lts n :=
  match n return list (nat_lt n) with
    | 0 => nil
    | S p => mk_nat_lts_aux (S p) p (le_n (S p))
  end.

Implicit Arguments mk_nat_lts [].

Lemma mk_nat_lts_correct : forall n x i,
  i < n -> val (nth i (mk_nat_lts n) x) = pred n - i.

Proof.
intros. unfold mk_nat_lts. destruct n. absurd_arith.
apply mk_nat_lts_aux_correct. omega.
Qed.

Lemma mk_nat_lts_complete : forall n i (p : i<n),
  In (mk_nat_lt p) (mk_nat_lts n).

Proof.
intros. unfold mk_nat_lts. destruct n. absurd_arith.
apply mk_nat_lts_aux_complete. omega.
Qed.

(***********************************************************************)
(** first element satisfying some boolean predicate *)

Section first.

  Variable (A : Type) (f : A -> bool).

  Fixpoint first l :=
    match l with
      | nil => None
      | x :: l' => if f x then Some x else first l'
    end.

End first.

(***********************************************************************)
(** transpose *)

Instance transpose_inclusion A B : Proper (inclusion ==> Logic.eq ==> impl)
  (@transpose A B).

Proof. intros R R' RR' f f' ff' h x y z. subst f'. apply RR'. apply h. Qed.

Instance transpose_same_rel A B :
  Proper (same_rel ==> Logic.eq ==> iff) (@transpose A B).

Proof.
  intros R R' [h1 h2] f f' ff'. subst f'.
  split; apply transpose_inclusion; auto.
Qed.

(***********************************************************************)
(** fold_left *)

Section fold_left.

  Variables (A : Type) (eqA : relation A) (B : Type) (eqB : relation B).

  Definition feq f f' :=
    forall a a', eqA a a' -> forall b b', eqB b b' -> eqA (f a b) (f' a' b').

  Global Instance fold_left_m_ext :
    Proper (feq ==> eqlistA eqB ==> eqA ==> eqA) (@fold_left A B).

  Proof.
    intros f f' ff' l l' ll' a a' aa'. revert l l' ll' a a' aa'.
    induction l; destruct l'; intros; simpl.
    hyp. inversion ll'. inversion ll'.
    inversion ll'. subst. apply IHl. hyp. apply ff'; hyp.
  Qed.

End fold_left.

Section fold_left_list.

  Variables (A B : Type) (f : list A -> B -> list A).

  Variable g : B -> list A.

  Variable hyp : forall l b, f l b = g b ++ l.

  Lemma fold_left_flat_map : forall bs l,
    fold_left f bs l = flat_map g (rev bs) ++ l.

  Proof.
    induction bs; simpl; intro. refl.
    rewrite IHbs. rewrite hyp. rewrite flat_map_app. rewrite app_ass. simpl.
    rewrite <- app_nil_end. refl.
  Qed.

  Lemma In_fold_left : forall a bs l,
    In a (fold_left f bs l) <-> (In a l \/ exists b, In b bs /\ In a (g b)).

  Proof.
    intros. rewrite fold_left_flat_map, in_app, in_flat_map.
    intuition. destruct H0. right. exists x. rewrite In_rev. hyp.
    destruct H0. left. exists x. rewrite <- In_rev. hyp.
  Qed.

End fold_left_list.

Implicit Arguments fold_left_flat_map [A B f].
Implicit Arguments In_fold_left [A B f].

(****************************************************************************)
(** checking a boolean property [P 0 && ... && P (n-1)], where the domain of
    the predicate P is restricted to numbers smaller than [n]. *)

Section Check_seq_aux.

  Variables (n : nat) (Pr : nat_lt n -> Prop)
    (P : forall i : nat_lt n, Exc (Pr i)).

  Program Fixpoint check_seq_aux p (H : forall i : nat_lt n, val i < p -> Pr i)
    {measure (n - p)} : Exc (forall i : nat_lt n, Pr i) :=
    match le_lt_dec n p with
      | left _ => value _
      | right cmp =>
        match @P (mk_nat_lt cmp) with
          | error => error
          | value _ => @check_seq_aux (S p) _ _
        end
    end.

  Next Obligation.
  Proof.
    apply H. destruct i. simpl. omega.
  Qed.
  Next Obligation.
  Proof.
    destruct i as [x l]. simpl in *.
    destruct (eq_nat_dec x p).
    subst. rewrite (lt_unique l cmp). hyp.
    apply H. simpl. omega.
  Qed.
  Next Obligation.
  Proof.
    omega.
  Qed.

End Check_seq_aux.

Program Definition check_seq (n : nat) (Pr : nat_lt n -> Prop)
  (P : forall (i : nat_lt n), Exc (Pr i)) :
  Exc (forall (i : nat_lt n), Pr i) :=
  check_seq_aux P (p:=0) _.

Next Obligation.
Proof.
  elimtype False. omega.
Qed.

(****************************************************************************)
(** [lookup el default l] takes an association list of pairs of keys, values
    and returns [v] such that [(el, v)] belongs to the list, or [default]
    if there is no element with key equal to [el]. *)

Section lookup.

  Variable (A B : Type).
  Variable (eqA_dec : forall x y : A, {x = y} + {x <> y}).
  Variable (el : A).
  Variable (default : B).

  Fixpoint lookup (l : list (A * B)) : B :=
    match l with
    | nil => default
    | (el', v)::l' =>
        if @eqA_dec el el' then
          v
        else
          lookup l'
    end.

  Variable P : B -> Prop.

  Lemma lookup_prop l :
    (forall x, In x l -> P (snd x)) -> P default -> P (lookup l).
  Proof with auto with datatypes.
    induction l; intros...
    simpl. destruct a. destruct (@eqA_dec el a).
    apply (H (a, b))...
    apply IHl...
  Qed.

End lookup.

(****************************************************************************)
(** [lookup_dep] is equivalent to [lookup] above but works on lists of
    dependent pairs instead. *)

Section lookup_dep.

  Variable (A : Type) (B : A -> Type).
  Variable (eqA_dec : forall x y : A, {x = y} + {x <> y}).
  Variable (el : A).
  Variable (default : forall a : A, B a).

  Program Fixpoint lookup_dep (l : list { el : A & B el}) : B el :=
    match l with
    | nil => @default el
    | x::l' =>
        let (el', v) := x in
        if @eqA_dec el el' then
          v
        else
          lookup_dep l'
    end.

  Variable P : forall a : A, B a -> Prop.

  Lemma lookup_dep_prop (l : list {el : A & B el}) :
    (forall x, In x l -> P (projT2 x)) ->
    (forall a : A, P (@default a)) -> P (lookup_dep l).

  Proof with auto with datatypes.
    induction l; intros.
    apply H0.
    simpl. destruct a. destruct (@eqA_dec el x).

    unfold eq_rect, lookup_dep_obligation_1.
    set (w := eq_ind_r (fun el => x = el) refl_equal e).
    dependent inversion w.

    apply (H (existT x b))...
    apply IHl...
  Qed.

End lookup_dep.

(****************************************************************************)
(** forallb *)

Section forallb.

  Variables (A : Type) (P : A -> Prop)
    (f : A -> bool) (f_ok : forall x, f x = true <-> P x).

  Lemma forallb_false : forall l,
    forallb f l = false <-> exists x, In x l /\ f x = false.

  Proof.
    induction l; simpl. intuition. destruct H. intuition.
    rewrite andb_eq_false. rewrite IHl. intuition.
    exists a. tauto. destruct H0. exists x. tauto.
    destruct H1. intuition. subst. tauto. right. exists x. tauto.
  Qed.

  Lemma forallb_neg : forall l,
    forallb f l = false <-> exists x, In x l /\ ~P x.

  Proof.
    intro l. rewrite forallb_false. split; intro.
    do 2 destruct H. exists x. rewrite <- (ko (@f_ok)). tauto.
    do 2 destruct H. exists x. rewrite (ko (@f_ok)). tauto.
  Qed.

  Variables (As : list A) (As_ok : forall x, In x As).

  Lemma forallb_ok_fintype : forallb f As = true <-> forall x, P x.

  Proof.
    split; intro H.
    intro x. rewrite <- f_ok. rewrite forallb_forall in H. apply H. apply As_ok.
    rewrite forallb_forall. intros x hx. rewrite f_ok. apply H.
  Qed.

End forallb.

(****************************************************************************)
(** sub_list *)

Section sub_list.

  Variable A : Type.

  Fixpoint sub_list l k n : list A :=
    match l, k, n with
      | _ :: l', S k', _ => sub_list l' k' n
      | x :: l', 0, S n' => x :: sub_list l' 0 n'
      | _, _, _ => nil
    end.

  Functional Scheme sub_list_ind := Induction for sub_list Sort Prop.

  Lemma sub_list_ok : forall l k n i,
    k < length l -> k+n <= length l -> i < n ->
    element_at (sub_list l k n) i = element_at l (k+i).

  Proof.
    intros l k n. functional induction (sub_list l k n); simpl; intros.
    refl. absurd_arith. destruct i. refl. apply IHl0; try omega.
    apply IHl0; omega.
  Qed.

  Lemma length_sub_list : forall l k n,
    k < length l -> k+n <= length l -> length (sub_list l k n) = n.

  Proof.
    intros l k n. functional induction (sub_list l k n); simpl; intros.
    omega. omega.
    destruct l'. simpl in *. omega. rewrite IHl0; simpl in *; omega.
    rewrite IHl0; omega.
  Qed.

  Lemma eq_app_elim_l : forall l1 l l2,
    l = l1 ++ l2 -> l1 = sub_list l 0 (length l1).

  Proof.
    induction l1; destruct l; simpl; intros. refl. refl. discr.
    inversion H. subst. apply tail_eq. eapply IHl1. refl.
  Qed.

  Lemma eq_app_elim_r : forall l1 l l2,
    l = l1 ++ l2 -> l2 = sub_list l (length l1) (length l2).

  Proof.
    induction l1; simpl; intros. subst l2.
    induction l; simpl; intros. refl. rewrite <- IHl. refl.
    destruct l. discr. inversion H. subst. simpl. apply IHl1. refl.
  Qed.

  Lemma sub_list_0 : forall l k, sub_list l k 0 = nil.

  Proof.
    induction l; induction k; simpl; auto.
  Qed.

  Lemma sub_list_length : forall l, sub_list l 0 (length l) = l.

  Proof.
    induction l; simpl; intros. refl. rewrite IHl. refl.
  Qed.

  Lemma app_eq_sub_list : forall l1 l2, l1++l2 =
    sub_list (l1++l2) 0 (length l1)
    ++ sub_list (l1++l2) (length l1) (length l2).

  Proof.
    induction l1; simpl; intros. rewrite sub_list_0. rewrite sub_list_length.
    refl. rewrite <- IHl1. refl.
  Qed.

End sub_list.

Implicit Arguments eq_app_elim_l [A l1 l l2].
Implicit Arguments eq_app_elim_r [A l1 l l2].

(****************************************************************************)
(** natural numbers from n-1 to 0 *)

Fixpoint nats_decr_lt n :=
  match n with
    | 0 => nil
    | S n' => n' :: nats_decr_lt n'
  end.

Definition nats_incr_lt n := rev' (nats_decr_lt n).

Lemma In_nats_decr_lt : forall n x, x < n <-> In x (nats_decr_lt n).

Proof. induction n; simpl; intros. omega. rewrite <- IHn. omega. Qed.


(* This file shows that the fancy update can be encoded in terms of the
view shift, and that the laws of the fancy update can be derived from the
laws of the view shift. *)
From iris.base_logic Require Export base_logic.
From iris.proofmode Require Import tactics.
From stdpp Require Export coPset.
Set Default Proof Using "Type*".

Section fupd.
Context {M} (vs : coPset → coPset → uPred M → uPred M → uPred M).

Notation "P ={ E1 , E2 }=> Q" := (vs E1 E2 P Q)
  (at level 99, E1,E2 at level 50, Q at level 200,
   format "P  ={ E1 , E2 }=>  Q") : bi_scope.

Context (vs_ne : ∀ E1 E2, NonExpansive2 (vs E1 E2)).
Context (vs_persistent : ∀ E1 E2 P Q, Persistent (P ={E1,E2}=> Q)).

Context (vs_impl : ∀ E P Q, □ (P → Q) ⊢ P ={E,E}=> Q).
Context (vs_transitive : ∀ E1 E2 E3 P Q R,
  (P ={E1,E2}=> Q) ∧ (Q ={E2,E3}=> R) ⊢ P ={E1,E3}=> R).
Context (vs_mask_frame_r : ∀ E1 E2 Ef P Q,
  E1 ## Ef → (P ={E1,E2}=> Q) ⊢ P ={E1 ∪ Ef,E2 ∪ Ef}=> Q).
Context (vs_frame_r : ∀ E1 E2 P Q R, (P ={E1,E2}=> Q) ⊢ P ∗ R ={E1,E2}=> Q ∗ R).
Context (vs_exists : ∀ {A} E1 E2 (Φ : A → uPred M) Q,
  (∀ x, Φ x ={E1,E2}=> Q) ⊢ (∃ x, Φ x) ={E1,E2}=> Q).
Context (vs_persistent_intro_r : ∀ E1 E2 P Q R,
  Persistent R →
  (R -∗ (P ={E1,E2}=> Q)) ⊢ P ∗ R ={E1,E2}=> Q).

Definition fupd (E1 E2 : coPset) (P : uPred M) : uPred M :=
  (∃ R, R ∗ vs E1 E2 R P)%I.

Notation "|={ E1 , E2 }=> Q" := (fupd E1 E2 Q)
  (at level 99, E1, E2 at level 50, Q at level 200,
   format "|={ E1 , E2 }=>  Q") : bi_scope.

Global Instance fupd_ne E1 E2 : NonExpansive (@fupd E1 E2).
Proof. solve_proper. Qed.

Lemma fupd_intro E P : P ⊢ |={E,E}=> P.
Proof. iIntros "HP". iExists P. iFrame "HP". iApply vs_impl; auto. Qed.

Lemma fupd_mono E1 E2 P Q : (P ⊢ Q) → (|={E1,E2}=> P) ⊢ |={E1,E2}=> Q.
Proof.
  iIntros (HPQ); iDestruct 1 as (R) "[HR Hvs]".
  iExists R; iFrame "HR". iApply (vs_transitive with "[$Hvs]").
  iApply vs_impl. iIntros "!# HP". by iApply HPQ.
Qed.

Lemma fupd_trans E1 E2 E3 P : (|={E1,E2}=> |={E2,E3}=> P) ⊢ |={E1,E3}=> P.
Proof.
  iDestruct 1 as (R) "[HR Hvs]". iExists R. iFrame "HR".
  iApply (vs_transitive with "[$Hvs]"). clear R.
  iApply vs_exists; iIntros (R). iApply vs_persistent_intro_r; iIntros "Hvs".
  iApply (vs_transitive with "[$Hvs]"). iApply vs_impl; auto.
Qed.

Lemma fupd_mask_frame_r E1 E2 Ef P :
  E1 ## Ef → (|={E1,E2}=> P) ⊢ |={E1 ∪ Ef,E2 ∪ Ef}=> P.
Proof.
  iIntros (HE); iDestruct 1 as (R) "[HR Hvs]". iExists R; iFrame "HR".
  by iApply vs_mask_frame_r.
Qed.

Lemma fupd_frame_r E1 E2 P Q : (|={E1,E2}=> P) ∗ Q ⊢ |={E1,E2}=> P ∗ Q.
Proof.
  iIntros "[Hvs HQ]". iDestruct "Hvs" as (R) "[HR Hvs]".
  iExists (R ∗ Q)%I. iFrame "HR HQ". by iApply vs_frame_r.
Qed.
End fupd.


Require Import Data.TwoThreeTrees.
Require Import Data.UoAssoc.

Definition omap := two3map.
Definition umap := uo_assoc_map.
Definition ummap := uo_assoc_multimap.

Definition oset := two3set.
Definition uset := uo_assoc_set.
Definition umset := uo_assoc_multiset.