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

 This defines the static semantics of statements and expressions, pg. 63.

*)

Set Implicit Arguments.
Require Export Cyclone_Dynamic_Semantics_Heap_Objects.
Require Export Cyclone_Static_Semantics_Typing_Heap_Objects.
Require Export Cyclone_Static_Semantics_Kinding_And_Context_Well_Formedness.
Close Scope list_scope.
Import LibEnvNotations.
Import LVPE.LibVarPathEnvNotations.

Inductive ret : St -> Prop :=
| ret_ret       : forall (e : E),
                       ret (retn e)

| ret_if        : forall (e : E) (s1 s2 : St),
                       ret s1 ->
                       ret s2 ->
                       ret (if_s e s1 s2)

| ret_seq_1     : forall (s s' : St),
                       ret s ->
                       ret (seqx s s')

| ret_seq_2     : forall (s s' : St),
                       ret s' ->
                       ret (seqx s s')

| ret_let       : forall (e : E) (s : St),
                       ret s ->
                       ret (letx e s)

| ret_open      : forall (e : E) (s : St),
                       ret s ->
                       ret (openx e s)

| ret_openstar  : forall (e : E) (s : St),
                       ret s ->
                       ret (openstar e s).
Hint Constructors ret.

Inductive styp : Delta -> Upsilon -> Gamma -> Tau -> St   -> Prop :=
  | styp_e_3_1    : forall (d : Delta) (u : Upsilon) (g : Gamma)
                           (tau: Tau) (e : E),
                      rtyp d u g e  tau ->
                      styp d u g tau (e_s e)

(* This is correct, return at end of program. *)
  | styp_return_3_2 : forall (d : Delta) (u : Upsilon) (g : Gamma)
                             (tau : Tau) (e : E),
                         rtyp d u g e tau ->
                         styp d u g tau (retn e)

  | styp_seq_3_3    : forall (d : Delta) (u : Upsilon) (g : Gamma)
                             (tau : Tau) (s1 s2 : St),
                         styp d u g tau s1 ->
                         styp d u g tau s2 ->
                         styp d u g tau (seqx s1 s2)

  | styp_while_3_4  : forall (d : Delta) (u : Upsilon) (g : Gamma)
                             (tau : Tau) (e: E) (s : St),
                         rtyp d u g e cint ->
                         styp d u g tau s ->
                         styp d u g tau (while e s)

  | styp_if_3_5     :  forall (d : Delta) (u : Upsilon) (g : Gamma)
                              (tau : Tau) (e: E) (s1 s2 : St),
                          rtyp d u g e cint ->
                          styp d u g tau s1 ->
                          styp d u g tau s2 ->
                          styp d u g tau (if_s e s1 s2)

  | styp_let_3_6    :  forall (L : vars) (d : Delta) (u : Upsilon) (g : Gamma)
                               (tau tau' : Tau)
                               (s : St) (e : E),
                          (forall (x : var),
                            x \notin L ->
                            styp d u (g & (x ~ tau')) tau (TM.open_rec_st 0 x s)) ->
                            rtyp d u g e tau' ->
                            K d tau' A ->  (* Thesis change. *)
                            styp d u g tau  (letx e s)

  | styp_open_3_7   :  forall (L : vars) (d : Delta) (u : Upsilon) (g : Gamma)
                               (p : Phi)
                               (k : Kappa) (tau tau' : Tau)
                               (s : St) (e : E),
                         (forall (x : var) (alpha : var),
                             x \notin L ->
                             alpha \notin L ->
                             styp ((alpha ~ k) & d)
                                  u
                                  (g & (x ~ (T.open_rec 0 (ftvar alpha) tau')))
                                  tau
                                  (TTM.open_rec_st 0 (ftvar alpha)
                                                   (TM.open_rec_st 0 x s)) ) ->
                         rtyp d u g e (etype p k tau') ->
                         K d tau A      ->
                         styp d u g tau (openx e s)

  | styp_openstar_3_8 :  forall (L : vars) (d : Delta) (u : Upsilon) (g : Gamma)
                               (k : Kappa) (tau tau' : Tau)
                               (s : St) (e : E),
                         (forall (x : var) (alpha : var),
                             x \notin L ->
                             alpha \notin L ->
                             styp (d & (alpha ~ k))
                                  u
                                  (g & (x ~ (T.open_rec 0 (ftvar alpha) (ptype tau'))))
                                  tau
                                  (TTM.open_rec_st 0 (ftvar alpha)
                                                   (TM.open_rec_st 0 x s))) ->
                         (* Thesis bug? typo but No says Dan. *)
                          ltyp d u g e (etype aliases k tau') ->
                          K d tau A      ->
                          styp d u g tau (openstar e s)

with      ltyp :   Delta -> Upsilon -> Gamma -> E -> Tau -> Prop :=

  | SL_3_1     : forall (d : Delta) (g : Gamma) (u : Upsilon)
                           (x : var) (p : Path) (tau tau': Tau),
                      get x g = Some tau' ->
                      gettype u x nil tau' p tau ->
                      WFC d u g ->
                      K d tau' A ->
                      ltyp d u g (p_e (fevar x) p) tau

  | SL_3_2     : forall (d : Delta) (u : Upsilon) (g : Gamma)
                        (e : E) (tau : Tau) ,
                      rtyp d u g e (ptype tau) ->
                      K d tau A ->
                      ltyp d u g (star e) tau

  | SL_3_3     : forall (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t0 t1 : Tau),
                      ltyp d u g e (cross t0 t1) ->
                      ltyp d u g (dot e zero_pe) t0

  | SL_3_4     : forall (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t0 t1 : Tau),
                      ltyp d u g e (cross t0 t1) ->
                      ltyp d u g (dot e one_pe) t1

with      rtyp :  Delta -> Upsilon -> Gamma -> E   -> Tau -> Prop :=
  | SR_3_1  : forall (d : Delta) (g : Gamma) (u : Upsilon)
                        (x  : var) (p : Path) (tau tau': Tau),
                   get x g = Some tau' ->
                   gettype u x nil tau' p tau ->
                   K d tau' A ->
                   WFC d u g ->
                   rtyp d u g (p_e (fevar x) p) tau

  | SR_3_2  :  forall (e : E) (tau : Tau)
                      (d : Delta) (u : Upsilon) (g : Gamma),
                    rtyp d u g e (ptype tau) ->
                    K d tau A ->
                    rtyp d u g (star e) tau

  | SR_3_3  :  forall (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t0 t1 : Tau),
                        rtyp d u g e (cross t0 t1) ->
                        rtyp d u g (dot e zero_pe) t0

  | SR_3_4  : forall (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (t0 t1 : Tau),
                      rtyp d u g e (cross t0 t1) ->
                      rtyp d u g (dot e one_pe) t1

  | SR_3_5  : forall (d : Delta) (u : Upsilon) (g : Gamma) (n : nat),
                   WFC d u g ->
                   rtyp d u g (i_e (i_i n)) cint

  | SR_3_6  : forall (d : Delta) (u : Upsilon) (g : Gamma) (e : E) (tau : Tau),
                   ltyp d u g e tau ->
                   rtyp d u g (amp e) (ptype tau)

  | SR_3_7  : forall (d : Delta) (u : Upsilon) (g : Gamma) (e0 e1: E) (t0 t1 : Tau),
                   rtyp d u g e0 t0 ->
                   rtyp d u g e1 t1 ->
                   rtyp d u g (cpair e0 e1) (cross t0 t1)

  | SR_3_8  : forall (d : Delta) (u : Upsilon) (g : Gamma) (e1 e2 : E) (tau : Tau),
                   ltyp d u g e1 tau ->
                   rtyp d u g e2 tau ->
                   ASGN d tau    ->
                   rtyp d u g (assign e1 e2) tau

  | SR_3_9  : forall (d : Delta) (u : Upsilon) (g : Gamma) (e1 e2 : E) (tau tau' : Tau),
                   rtyp d u g e1 (arrow tau' tau) ->
                   rtyp d u g e2 tau' ->
                   rtyp d u g (appl e1 e2) tau

  | SR_3_10 : forall (d : Delta) (u : Upsilon) (g : Gamma) (tau : Tau) (s : St),
                   styp d u g tau s ->
                   ret s ->
                   rtyp d u g (call s) tau

  | SR_3_11 : forall (d : Delta) (u : Upsilon) (g : Gamma) (e : E)
                        (tau tau' tau'': Tau) (k : Kappa),
                   rtyp d u g e (utype k tau') ->
                   AK   d tau k ->
                   (T.open_rec 0 tau tau') = tau'' ->
                   rtyp d u g (inst e tau) tau''

  | SR_3_12 : forall (L : vars) (d : Delta) (u : Upsilon) (g : Gamma) (e : E)
                        (tau tau': Tau) (k : Kappa) (p : Phi),
               (forall (alpha : var),
                   alpha \notin L ->
                   rtyp d u g e (T.open_rec 0 tau' tau)) ->
                   K    d (etype p k tau) A ->
                   AK   d tau' k ->
                   rtyp d u g (pack tau' e (etype p k tau))
                              (etype p k tau)

  | SR_3_13 : forall (L : vars) (d : Delta) (u : Upsilon) (g : Gamma) (tau tau': Tau)
                     (s : St),
               (forall (x : var),
                   x \notin L ->
                   styp d u (g & (x ~ tau)) tau' (TM.open_rec_st 0 x s)) ->
                   ret s ->
                   rtyp d u g (f_e (dfun tau tau' s)) (arrow tau tau')

  | SR_3_14 : forall (L : vars) (d : Delta) (u : Upsilon) (g : Gamma) (f : F)
                        (tau : Tau) (k : Kappa),
                 (forall alpha,
                     alpha \notin L ->
                     rtyp (d & (alpha ~ k)) u g (f_e (TTM.open_rec_f 0 (ftvar alpha) f))
                          (T.open_rec 0 (ftvar alpha) tau)) ->
                   WFC  d u g ->
                   rtyp d u g (f_e (ufun k f)) (utype k tau).

Scheme styp_ind_mutual := Induction for styp Sort Prop
with   ltyp_ind_mutual := Induction for ltyp Sort Prop
with   rtyp_ind_mutual := Induction for rtyp Sort Prop.
Combined Scheme typ_ind_mutual from
          styp_ind_mutual, ltyp_ind_mutual, rtyp_ind_mutual.

Hint Constructors styp.
Hint Constructors rtyp.
Hint Constructors ltyp.

Inductive htyp: Upsilon -> Gamma -> Heap -> Gamma -> Prop :=
   | htyp_empty : forall (u : Upsilon) (g: Gamma),
                       htyp u g hdot gdot

   | htyp_xv    : forall (u : Upsilon) (g g' g'': Gamma) (h h': Heap) (x : var)
                         (v : E) (tau : Tau),
                      Value v ->
                      (* Question is this env hacking right ? *)
                      (* Arthur works from the right. *)
                      htyp u g (h & h') (g' & g'') ->
                      rtyp ddot u g v tau ->
                      htyp u g (h & (x ~ v) & h') (g' & (x ~ tau) & g'').
Hint Constructors htyp.

Inductive refp  : Heap -> Upsilon -> Prop :=
  | refp_empty  : forall (h : Heap),
                       refp h udot

  | refp_pack  : forall (h : Heap) (u : Upsilon) (x : var) (p : Path)
                        (tau tau' : Tau) (k : Kappa) (v v' : E),
                      get x h = Some v' ->
                      get' v' p (pack tau' v (etype aliases k tau)) ->
                      refp h u ->
                      refp h (u &p ((x,p) ~p tau')).
Hint Constructors refp.

(* This has an arbitrary return type due to Dan's style. So it is not syntax directed. *)
Inductive prog  : Heap -> St -> Prop :=
  | program  : forall (h : Heap) (u : Upsilon) (g : Gamma) (tau : Tau) (s : St),
                    htyp u g h g ->
                    refp h u     ->
                    styp ddot u g tau s ->
                    ret s ->
                    prog h s.
Hint Constructors prog.


(** Concurrent bag specification from the HOCAP paper.
    "Modular Reasoning about Separation of Concurrent Data Structures"
    <http://www.kasv.dk/articles/hocap-ext.pdf>

Deriving the concurrent specification from the abstract one
*)
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.proofmode Require Import proofmode.
From iris.heap_lang Require Import proofmode notation.
From iris_examples.hocap Require Import abstract_bag.
From iris.prelude Require Import options.

Section proof.
  Context `{heapGS Σ}.
  Variable b : bag Σ.
  Variable N : namespace.
  Definition NB := N.@"bag".
  Definition NI := N.@"inv".
  (** Predicate that will be satisfied by all the elements in the bag.
      The first argument is the bag itself. *)
  Variable P : val → val → iProp Σ.

  Definition bagS_inv (γ : name Σ b) (y : val) : iProp Σ :=
    inv NI (∃ X, bag_contents b γ X ∗ [∗ mset] x ∈ X, P y x)%I.
  Definition bagS (γ : name Σ b) (x : val) : iProp Σ :=
    (is_bag b NB γ x ∗ bagS_inv γ x)%I.

  Global Instance bagS_persistent γ x : Persistent (bagS γ x).
  Proof. apply _. Qed.

  Lemma newBag_spec :
    {{{ True }}}
      newBag b #()
    {{{ x, RET x; ∃ γ, bagS γ x }}}.
  Proof.
    iIntros (Φ) "_ HΦ". iApply wp_fupd.
    iApply (newBag_spec b NB); eauto.
    iNext. iIntros (v γ) "[#Hbag Hcntn]".
    iMod (inv_alloc NI _ (∃ X, bag_contents b γ X ∗ [∗ mset] x ∈ X, P v x)%I with "[Hcntn]") as "#Hinv".
    { iNext. iExists _. iFrame. by rewrite big_sepMS_empty. }
    iApply "HΦ". iModIntro. iExists _; by iFrame "Hinv".
  Qed.

  Lemma pushBag_spec γ x v :
    {{{ bagS γ x ∗ P x v }}}
       pushBag b x (of_val v)
    {{{ RET #(); bagS γ x }}}.
  Proof.
    iIntros (Φ) "[#[Hbag Hinv] HP] HΦ". rewrite /bagS_inv.
    iApply (pushBag_spec b NB (P x v)%I (True)%I with "[] [Hbag HP]"); eauto.
    { iModIntro. iIntros (Y) "[Hb1 HP]".
      iInv NI as (X) "[>Hb2 HPs]" "Hcl".
      iDestruct (bag_contents_agree with "Hb1 Hb2") as %<-.
      iMod (bag_contents_update b ({[v]} ⊎ Y) with "[$Hb1 $Hb2]") as "[Hb1 Hb2]".
      iFrame. iApply "Hcl".
      iNext. iExists _; iFrame.
      rewrite big_sepMS_singleton. iFrame. }
    { iNext. iIntros "_". iApply "HΦ". by iFrame "Hinv". }
  Qed.

  Lemma popBag_spec γ x :
    {{{ bagS γ x }}}
       popBag b x
    {{{ v, RET v; bagS γ x ∗ (⌜v = NONEV⌝ ∨ (∃ y, ⌜v = SOMEV y⌝ ∧ P x y)) }}}.
  Proof.
    iIntros (Φ) "[#Hbag #Hinv] HΦ".
    iApply (popBag_spec b NB (True)%I (fun v => (⌜v = NONEV⌝ ∨ (∃ y, ⌜v = SOMEV y⌝ ∧ P x y)))%I with "[] [] [Hbag]"); eauto.
    { iModIntro. iIntros (Y y) "[Hb1 _]".
      iInv NI as (X) "[>Hb2 HPs]" "Hcl".
      iDestruct (bag_contents_agree with "Hb1 Hb2") as %<-.
      iMod (bag_contents_update b Y with "[$Hb1 $Hb2]") as "[Hb1 Hb2]".
      rewrite big_sepMS_disj_union bi.later_sep big_sepMS_singleton.
      iDestruct "HPs" as "[HP HPs]".
      iMod ("Hcl" with "[-HP Hb1]") as "_".
      { iNext. iExists _; iFrame. }
      iModIntro. iNext. iFrame. iRight; eauto. }
    { iModIntro. iIntros "[Hb1 _]".
      iModIntro. iNext. iFrame. iLeft; eauto. }
    { iNext. iIntros (v) "H". iApply "HΦ". iFrame "Hinv Hbag H". }
  Qed.

End proof.


(*|
###################################
Which vector library to use in Coq?
###################################

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

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

I'm wondering, is there a commonly used library for vectors in Coq,
i.e. lists indexed by their length in their type.

Some tutorials reference ``Bvector``, but it's not found when I try to
import it.

There's ``Coq.Vectors.Vectordef``, but the type defined there is just
named ``t`` which makes me think it's intended for internal use.

What is the best or most common practice for someone who doesn't want
to roll their own library? Am I wrong about the vectors in the
standard library? Or is there another lib I'm missing? Or do people
just use lists, paired with proofs of their length?

----

**A:** I think @ejgallego answers this question in this `coq-club
thread
<https://sympa.inria.fr/sympa/arc/coq-club/2017-01/msg00099.html>`__.
Also, `this answer <http://stackoverflow.com/a/30159566/2747511>`__ by
Arthur Azevedo de Amorim has the same spirit: "While dependent types
are interesting for some things, it not clear how useful they are in
general. My impression is that some feel that they are very
complicated to use, and that the benefit of having certain properties
expressed at the type level versus having them as separate theorems is
not worth this additional complexity."

**A:** Also, you can ``Require Vector`` (without importing) and use
the qualified name ``Vector.t``.

**A:** If you want something ready to use AFAICT math-comp's ``tuple``
is the only option, others have experimented with "the fixpoint
definition", you may have luck with it too.
|*)

(*|
Answer
******

There are generally three approaches to vectors in Coq, each with
their own trade-offs:

1. Inductively defined vectors, as provided by the Coq standard
   library.
2. Lists paired with an assertion of their length.
3. Recursively-nested tuples.

Lists-with-length are nice in that they're easily coerced to lists, so
you can reuse a lot of functions that operate on plain lists.
Inductive vectors have the downside of requiring a lot of
dependently-typed pattern matching, depending on what you're doing
with them.

For most developments, I prefer the recursive tuple definition:
|*)

Definition Vec A : nat -> Type :=
  fix vec n := match n return Type with
               | O   => unit
               | S n => prod A (vec n)
               end.


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

(** * memoryImplement

Pierre Letouzey & Laurent Thery

Define how to perform the addition of an equation
*)

From Stalmarck Require Export state.
From Stalmarck Require Export restrictState.
From Stalmarck Require Export ltState.
From Stalmarck Require Export wfArray.
From Stalmarck Require Export addArray.

(** Definition of well formed array and some properties *)
Section Deval.

(** Ordered list for list on [rZ] *)
Definition OlistRz := Olist rZ rZlt.

(** Disjoint list for list on [rZ] *)
Definition DisjointRz := Disjoint rZ eqRz.

(** To be in a list for [rZ] with no sign consideration *)
Definition InRz := InEq rZ eqRz.

Variable Ar : rArray vM.
Hypothesis War : wellFormedArray Ar.

(** Given a rNat n returns the smaller rZ p such that +a = p *)
Definition evalN (v : rNat) : rZ :=
  match rArrayGet _ Ar v with
  | ref p => p
  | class _ => rZPlus v
  end.

(** Lift evalMnat to rZ *)
Definition evalZ (v : rZ) : rZ := samePolRz v (evalN (valRz v)).

Theorem EqrZComp : forall a b : rZ, a = b -> rZComp a = rZComp b.
Proof.
intros a b H'; rewrite H'; auto with stalmarck.
Qed.

#[local] Hint Resolve EqrZComp : stalmarck.

(** We can't be smaller than zero *)
Theorem notrltzero : forall r : rZ, ~ rVlt r zero.
Proof.
intros r; red in |- *; intros H'; absurd (rlt (valRz r) (valRz r)); auto with stalmarck.
apply rltTransRnext2 with (m := zero); auto with stalmarck.
Qed.

#[local] Hint Resolve notrltzero : stalmarck.

(** True evaluates to true *)
Theorem evalZTrue : evalZ rZTrue = rZTrue.
Proof.
simpl in |- *; unfold evalN in |- *.
generalize (fun s : rZ => wfPd _ War zero s); case (rArrayGet vM Ar zero);
 auto with stalmarck.
intros r H'; absurd (rVlt r zero); auto with stalmarck.
Qed.

(** False evaluates to false *)
Theorem evalZFalse : evalZ rZFalse = rZFalse.
Proof.
simpl in |- *; unfold evalN in |- *.
generalize (fun s : rZ => wfPd _ War zero s); case (rArrayGet vM Ar zero);
 auto with stalmarck.
intros r H'; absurd (rVlt r zero); auto with stalmarck.
Qed.

(** Evaluation is compatible with the complement *)
Theorem evalZComp : forall v : rZ, evalZ (rZComp v) = rZComp (evalZ v).
Proof.
intros v; case v; simpl in |- *; auto with stalmarck.
Qed.

(** Evaluate an element returns something smaller or equal *)
Theorem evalZltOr : forall v : rZ, evalZ v = v \/ rZlt (evalZ v) v.
Proof.
intros v; case v; simpl in |- *; auto with stalmarck; intros a; unfold evalN in |- *;
 generalize (fun s : rZ => wfPd _ War a s); case (rArrayGet _ Ar a);
 intros r H'; auto with stalmarck; right.
lapply (H' r); auto with stalmarck.
apply rZltEqComp with (a := r) (b := rZMinus a); auto with stalmarck.
lapply (H' r); auto with stalmarck.
Qed.

(** The result of an evaluation evaluates to itself *)
Theorem evalZInv : forall v : rZ, evalZ (evalZ v) = evalZ v.
Proof.
intros v; case v; intros a; simpl in |- *; unfold evalN in |- *;
 CaseEq (rArrayGet _ Ar a); simpl in |- *; auto with stalmarck.
intros r; case r; simpl in |- *; intros r0 H'; unfold evalN in |- *;
 CaseEq (rArrayGet _ Ar r0); auto with stalmarck; intros r1 H'1; Contradict H'1;
 apply wfPcr with (2 := H'); auto with stalmarck.
intros l H'; unfold evalN in |- *; rewrite H'; auto with stalmarck.
intros r; case r; simpl in |- *; intros r0 H'; unfold evalN in |- *;
 CaseEq (rArrayGet _ Ar r0); auto with stalmarck; intros r1 H'1; Contradict H'1;
 apply wfPcr with (2 := H'); auto with stalmarck.
intros l H'; unfold evalN in |- *; rewrite H'; auto with stalmarck.
Qed.

(** Every element smaller than the evaluation is not in the same equivalent class *)
Theorem evalZMin :
 forall (a : rNat) (b c : rZ), evalN a = b -> rZlt c b -> evalN a <> evalZ c.
Proof.
intros a b c H' H'0; Contradict H'0.
rewrite <- H'; rewrite H'0.
case (evalZltOr c); auto with stalmarck.
intros H'1; rewrite H'1; auto with stalmarck.
Qed.

End Deval.

(** Relation between Get and evalN *)
Theorem rArrayGetEvalN :
 forall Ar Ar' : rArray vM,
 (forall e : rNat, rArrayGet vM Ar' e = rArrayGet vM Ar e) ->
 forall e : rNat, evalN Ar e = evalN Ar' e.
Proof.
intros Ar Ar' H' e; unfold evalN in |- *.
rewrite (H' e); auto with stalmarck.
Qed.

(** relation between evalN and evanZ *)
Theorem evalNEvalZ :
 forall Ar Ar' : rArray vM,
 (forall e : rNat, evalN Ar e = evalN Ar' e) ->
 forall e : rZ, evalZ Ar e = evalZ Ar' e.
Proof.
intros Ar Ar' H' e; case e; simpl in |- *; auto with stalmarck.
intros r; rewrite H'; auto with stalmarck.
Qed.

(** relation between get and evalZ *)
Theorem rArrayGetEvalZ :
 forall Ar Ar' : rArray vM,
 (forall e : rNat, rArrayGet vM Ar' e = rArrayGet vM Ar e) ->
 forall e : rZ, evalZ Ar e = evalZ Ar' e.
Proof.
intros Ar Ar' H' e; apply evalNEvalZ; auto with stalmarck.
intros e'; apply rArrayGetEvalN; auto with stalmarck.
Qed.

Section Dprop.

Variable Ar : rArray vM.
Hypothesis War : wellFormedArray Ar.
Variable a b : rNat.
Variable pol : rZ.
Variable La Lb : list rZ.
Hypothesis rltab : rlt a b.
Hypothesis geta : rArrayGet _ Ar a = class La.
Hypothesis getb : rArrayGet _ Ar b = class Lb.
Variable S : State.
Hypothesis
  SisAr : forall c d : rZ, eqStateRz S c d <-> evalZ Ar c = evalZ Ar d.

(** We first need to prove some properties of update with respect to evalN and evalZ

First if before evalN was giving b, it now gives a,  samePolRz is used to ensure
that the rule of sign is followed *)

Theorem updateEvalNb :
 forall c : rNat,
 valRz (evalN Ar c) = b ->
 evalN (updateArray a b pol La Lb Ar) c =
 samePolRz (evalN Ar c) (samePolRz pol (rZPlus a)).
Proof.
intros c; unfold evalN in |- *.
CaseEq (rArrayGet vM Ar c); simpl in |- *.
intros r; case r; simpl in |- *.
intros r0 H' H'0; replace c with (valRz (rZPlus c)); auto with stalmarck.
rewrite (updateArrayInb a b pol La Lb Ar) with (c := rZPlus c); auto with stalmarck.
replace (rZPlus c) with (samePol (rZPlus r0) c); auto with stalmarck.
apply wfPcc2 with (Ar := Ar); auto with stalmarck.
rewrite H'0; auto with stalmarck.
intros r0 H' H'0; replace c with (valRz (rZMinus c)); auto with stalmarck.
rewrite (updateArrayInb a b pol La Lb Ar) with (c := rZMinus c); auto with stalmarck.
replace (rZMinus c) with (samePol (rZMinus r0) c); auto with stalmarck.
apply wfPcc2 with (Ar := Ar); auto with stalmarck.
rewrite H'0; auto with stalmarck.
intros l H' H'0; rewrite H'0.
rewrite (updateArrayb a b pol La Lb Ar); auto with stalmarck.
Qed.

(** If evalN is not b the value is not changed *)
Theorem updateEvalNO :
 forall c : rNat,
 valRz (evalN Ar c) <> b ->
 evalN (updateArray a b pol La Lb Ar) c = evalN Ar c.
Proof.
intros c; unfold evalN in |- *.
case (rNatDec c a); intros Eqa; auto with stalmarck.
rewrite Eqa; auto with stalmarck; rewrite (updateArraya a b pol La Lb Ar); rewrite geta;
 auto with stalmarck.
case (rNatDec c b); intros Eqb; auto with stalmarck.
rewrite Eqb; auto with stalmarck; rewrite (updateArrayb a b pol La Lb Ar); auto with stalmarck;
 rewrite getb; simpl in |- *; intros H'; Contradict H';
 auto with stalmarck.
case (InRzDec (rZPlus c) Lb); intros InRLb; auto with stalmarck.
case (InEqInv (rZPlus c) Lb); auto with stalmarck; intros InRLb'.
replace c with (valRz (rZPlus c)); auto with stalmarck;
 rewrite (wfPcc1 _ War b (rZPlus c) Lb); simpl in |- *;
 auto with stalmarck.
intros H'; case H'; auto with stalmarck.
replace c with (valRz (rZMinus c)); auto with stalmarck;
 rewrite (wfPcc1 _ War b (rZMinus c) Lb); simpl in |- *;
 auto with stalmarck.
intros H'; case H'; auto with stalmarck.
rewrite (updateArrayOtherwise a b pol La Lb Ar c); auto with stalmarck.
Qed.

(** Equations that were valid before are still valid *)
Theorem updateEvalN2 :
 forall c d : rNat,
 evalN Ar c = evalN Ar d ->
 evalN (updateArray a b pol La Lb Ar) c =
 evalN (updateArray a b pol La Lb Ar) d.
Proof.
intros c d; case (rNatDec (valRz (evalN Ar c)) b); intros Eqt.
rewrite updateEvalNb; auto with stalmarck.
case (rNatDec (valRz (evalN Ar d)) b); intros Eqt'.
rewrite updateEvalNb; auto with stalmarck.
intros H'; rewrite H'; auto with stalmarck.
intros H'; Contradict Eqt'; rewrite <- H'; auto with stalmarck.
rewrite updateEvalNO; auto with stalmarck.
case (rNatDec (valRz (evalN Ar d)) b); intros Eqt'.
intros H'; Contradict Eqt; rewrite H'; auto with stalmarck.
rewrite updateEvalNO; auto with stalmarck.
Qed.

(** Same as before but with complement *)
Theorem updateEvalN2Comp :
 forall c d : rNat,
 evalN Ar c = rZComp (evalN Ar d) ->
 evalN (updateArray a b pol La Lb Ar) c =
 rZComp (evalN (updateArray a b pol La Lb Ar) d).
Proof.
intros c d; case (rNatDec (valRz (evalN Ar c)) b); intros Eqt.
rewrite updateEvalNb; auto with stalmarck.
case (rNatDec (valRz (evalN Ar d)) b); intros Eqt'.
rewrite updateEvalNb; auto with stalmarck.
intros H'; rewrite H'; case (evalN Ar d); auto with stalmarck.
intros H'; Contradict Eqt'; rewrite <- Eqt; rewrite H'; case (evalN Ar d);
 auto with stalmarck.
rewrite updateEvalNO; auto with stalmarck.
case (rNatDec (valRz (evalN Ar d)) b); intros Eqt'.
intros H'; Contradict Eqt; rewrite <- Eqt'; rewrite H'; case (evalN Ar d);
 auto with stalmarck.
rewrite updateEvalNO; auto with stalmarck.
Qed.

(** If evalZ was given b, now it gives a *)
Theorem updateEvalZb :
 forall c : rZ,
 valRz (evalZ Ar c) = b ->
 evalZ (updateArray a b pol La Lb Ar) c =
 samePolRz (evalZ Ar c) (samePolRz pol (rZPlus a)).
Proof.
intros c; case c; simpl in |- *.
exact updateEvalNb.
intros r H'.
cut (forall p q : rZ, rZComp (samePolRz p q) = samePolRz (rZComp p) q);
 [ intros Eq1; rewrite <- Eq1
 | intros p q; case p; case q; simpl in |- *; auto with stalmarck ].
apply EqrZComp; auto with stalmarck.
apply updateEvalNb; auto with stalmarck.
rewrite <- H'; case (evalN Ar r); auto with stalmarck.
Qed.

(** If evalZ was not giving b, its value is unchanged *)
Theorem updateEvalZO :
 forall c : rZ,
 valRz (evalZ Ar c) <> b ->
 evalZ (updateArray a b pol La Lb Ar) c = evalZ Ar c.
Proof.
intros c; case c; simpl in |- *.
exact updateEvalNO.
intros r H'; apply EqrZComp; auto with stalmarck.
apply updateEvalNO; auto with stalmarck.
Contradict H'; rewrite <- H'; case (evalN Ar r); auto with stalmarck.
Qed.

(** Equations for evalZ are still valid *)
Theorem updateEvalZ2 :
 forall c d : rZ,
 evalZ Ar c = evalZ Ar d ->
 evalZ (updateArray a b pol La Lb Ar) c =
 evalZ (updateArray a b pol La Lb Ar) d.
Proof.
intros c d; case c; case d; simpl in |- *; intros; try apply EqrZComp;
 try apply updateEvalN2 || apply updateEvalN2Comp;
 auto with stalmarck.
apply sym_equal; apply updateEvalN2Comp; auto with stalmarck.
generalize H; case (evalN Ar r0); case (evalN Ar r); simpl in |- *;
 intros r1 r2 H'; inversion H'; auto with stalmarck.
Qed.

(** Same with complement *)
Theorem updateEvalZ2Comp :
 forall c d : rZ,
 evalZ Ar c = rZComp (evalZ Ar d) ->
 evalZ (updateArray a b pol La Lb Ar) c =
 rZComp (evalZ (updateArray a b pol La Lb Ar) d).
Proof.
intros c d; repeat rewrite <- evalZComp.
intros H'; apply updateEvalZ2; auto with stalmarck.
Qed.

(** evalN a = +/- evalN b  depending of the polarity *)
Theorem updateEvalNab :
 evalN (updateArray a b pol La Lb Ar) a =
 samePolRz pol (evalN (updateArray a b pol La Lb Ar) b).
Proof.
unfold evalN in |- *; rewrite (updateArraya a b pol La Lb Ar);
 rewrite (updateArrayb a b pol La Lb Ar); auto with stalmarck.
case pol; auto with stalmarck.
Qed.
(* evalZ a = +/- evalZ b depending of the polarity *)

Theorem updateEvalZab :
 evalZ (updateArray a b pol La Lb Ar) (rZPlus a) =
 samePolRz pol (evalZ (updateArray a b pol La Lb Ar) (rZPlus b)).
Proof.
simpl in |- *; auto with stalmarck.
exact updateEvalNab.
Qed.

(** update is correct *)
Theorem updateCorrect :
 forall c d : rZ,
 eqStateRz (addEq (rZPlus a, samePol pol b) S) c d <->
 evalZ (updateArray a b pol La Lb Ar) c =
 evalZ (updateArray a b pol La Lb Ar) d.
Proof.
intros c d; split.
cut (exists S' : _, S' = addEq (rZPlus a, samePol pol b) S).
intros H'; Elimc H'; intros S' E; rewrite <- E.
intros H'; generalize E; elim H'; auto with stalmarck.
intros a0 b0 S0 H'0 H'1; rewrite H'1 in H'0.
simpl in H'0; case H'0.
intros H'2; inversion H'2.
rewrite updateEvalZab.
case pol; auto with stalmarck.
intros H'2; apply updateEvalZ2.
case (SisAr a0 b0); auto with stalmarck.
intros a0 b0 S0 H'0 H'1 H'2; repeat rewrite evalZComp; apply EqrZComp; auto with stalmarck.
intros a0 b0 S0 H'0 H'1 H'2; apply sym_equal; auto with stalmarck.
intros a0 b0 c0 S0 H'0 H'1 H'2 H'3 H'4; rewrite H'1; auto with stalmarck.
intros a0 b0 c0 S0 H'0 H'1 H'2;
 absurd
  (evalZ (updateArray a b pol La Lb Ar) a0 =
   evalZ (updateArray a b pol La Lb Ar) (rZComp a0));
 auto with stalmarck.
rewrite evalZComp; auto with stalmarck.
exists (addEq (rZPlus a, samePol pol b) S); auto with stalmarck.
case (rNatDec (valRz (evalZ Ar c)) b); intros Eqt.
rewrite updateEvalZb; auto with stalmarck.
case (rNatDec (valRz (evalZ Ar d)) b); intros Eqt'.
rewrite updateEvalZb; auto with stalmarck.
intros tmp; apply eqStateaddEq2.
case (SisAr c d); intros H' H'0; apply H'0; auto with stalmarck.
generalize Eqt; rewrite <- Eqt'; generalize tmp; case (evalZ Ar c);
 case (evalZ Ar d); case pol; simpl in |- *; auto with stalmarck;
 intros r0 r1 r2 H0 H1; rewrite H1; try discriminate;
 auto with stalmarck.
rewrite updateEvalZO; auto with stalmarck.
intros H0; apply eqStateRzTrans with (b := samePolRz (evalZ Ar c) (rZPlus b)).
apply eqStateaddEq2.
case (SisAr c (samePolRz (evalZ Ar c) (rZPlus b))); intros H' H'0; apply H'0;
 auto with stalmarck.
rewrite <- Eqt; generalize (evalZInv Ar War c); case (evalZ Ar c);
 simpl in |- *; auto with stalmarck.
apply
 eqStateRzTrans with (b := samePolRz (evalZ Ar c) (samePolRz pol (rZPlus a))).
case (evalZ Ar c); case pol; simpl in |- *; auto with stalmarck; intros r1 r2;
 apply eqStateInvInv; simpl in |- *; auto with stalmarck.
apply eqStateaddEq2.
case (SisAr (samePolRz (evalZ Ar c) (samePolRz pol (rZPlus a))) d);
 intros H' H'0; apply H'0; auto with stalmarck.
rewrite <- H0; case pol; case (evalZ Ar c); simpl in |- *; intros r1 r2;
 unfold evalN in |- *; rewrite geta; auto with stalmarck.
rewrite updateEvalZO; auto with stalmarck.
case (rNatDec (valRz (evalZ Ar d)) b); intros Eqt'.
rewrite updateEvalZb; auto with stalmarck.
intros H0;
 apply
  eqStateRzTrans
   with (b := samePolRz (evalZ Ar d) (samePolRz pol (rZPlus a))).
apply eqStateaddEq2.
case (SisAr c (samePolRz (evalZ Ar d) (samePolRz pol (rZPlus a))));
 intros H' H'0; apply H'0; auto with stalmarck.
rewrite H0; case pol; case (evalZ Ar d); simpl in |- *; intros r1 r2;
 unfold evalN in |- *; rewrite geta; auto with stalmarck.
apply eqStateRzTrans with (b := samePolRz (evalZ Ar d) (rZPlus b)).
case (evalZ Ar d); case pol; simpl in |- *; auto with stalmarck.
apply eqStateaddEq2.
case (SisAr (samePolRz (evalZ Ar d) (rZPlus b)) d); intros H' H'0; apply H'0;
 auto with stalmarck.
rewrite <- Eqt'; generalize (evalZInv Ar War d); case (evalZ Ar d);
 simpl in |- *; auto with stalmarck.
rewrite updateEvalZO; auto with stalmarck.
intros H'; apply eqStateaddEq2.
case (SisAr c d); auto with stalmarck.
Qed.

End Dprop.

(** To be able to return a triple *)
Inductive Triple (A B C : Type) : Type :=
 triple : A -> B -> C -> Triple A B C.

(** Adding an equation returns 3 elements:

    - The new array
    - A boolean that says if a contradiction has been reached
    - The list of elements of the array whose values have changed
         (it is rZ not rNat to avoid reconstruction)
*)

Definition mbD := Triple (rArray vM) bool (list rZ).

Definition mbDOp := triple (rArray vM) bool (list rZ).

(** A let that is not simplified during extraction *)
Definition letP (A B : Type) (h : A) (u : A -> B) : B := u h.

(** Given a rNat n returns the equivalence class*)
Definition getClassN (Ar : rArray vM) (v : rNat) :
  list rZ := match rArrayGet _ Ar v with
             | ref _ => nil
             | class l => l
             end.

Theorem GetClassNProp :
 forall (Ar : rArray vM) (a : rZ),
 wellFormedArray Ar ->
 rArrayGet vM Ar (valRz (evalZ Ar a)) =
 class (getClassN Ar (valRz (evalZ Ar a))).
Proof.
intros Ar a War; case a; simpl in |- *; unfold evalN, getClassN in |- *;
 intros r; generalize (fun s => wfPcr _ War r s); CaseEq (rArrayGet vM Ar r);
 simpl in |- *.
intros r0 H' H'0; CaseEq (rArrayGet vM Ar (valRz r0)); auto with stalmarck.
intros r1 H'1; case (H'0 r0 r1); auto with stalmarck.
intros l H'; rewrite H'; auto with stalmarck.
intros r0 H' H'0; rewrite (valRzComp r0); CaseEq (rArrayGet vM Ar (valRz r0));
 auto with stalmarck.
intros r1 H'1; case (H'0 r0 r1); auto with stalmarck.
intros l H'; rewrite H'; auto with stalmarck.
Qed.

(** To add an equation, we find the minimal elements and
     compare them to build the proper call to update *)
Definition addEqMem : forall (Ar : rArray vM) (a b : rZ), mbD.
intros Ar a b.
apply letP with (1 := evalZ Ar a); intros a'.
apply letP with (1 := evalZ Ar b); intros b'.
case (rZltEDec a' b'); intros rLt; [ Casec rLt; intros rLt | idtac ].
apply letP with (1 := getClassN Ar (valRz a')); intros La'.
apply letP with (1 := getClassN Ar (valRz b')); intros Lb'.
exact
 (mbDOp (updateArray (valRz a') (valRz b') (samePolRz a' b') La' Lb' Ar)
    false (a' :: b' :: Lb')).
apply letP with (1 := getClassN Ar (valRz a')); intros La'.
apply letP with (1 := getClassN Ar (valRz b')); intros Lb'.
exact
 (mbDOp (updateArray (valRz b') (valRz a') (samePolRz b' a') Lb' La' Ar)
    false (b' :: a' :: La')).
case (rZDec a' b'); intros eqa'b'.
exact (mbDOp Ar false nil).
exact (mbDOp Ar true nil).
Defined.

From Stalmarck Require Import stateDec.

(** The property for an array to represent a state *)
Definition rArrayState (Ar : rArray vM) (S : State) :=
  forall c d : rZ, eqStateRz S c d <-> evalZ Ar c = evalZ Ar d.

Theorem rArrayStateDef1 :
 forall (Ar : rArray vM) (S : State) (c d : rZ),
 rArrayState Ar S -> eqStateRz S c d -> evalZ Ar c = evalZ Ar d.
Proof.
intros Ar S c d H' H'0; case (H' c d); auto with stalmarck.
Qed.

Theorem rArrayStateDef2 :
 forall (Ar : rArray vM) (S : State) (c d : rZ),
 rArrayState Ar S -> evalZ Ar c = evalZ Ar d -> eqStateRz S c d.
Proof.
intros Ar S c d H' H'0; case (H' c d); auto with stalmarck.
Qed.

Theorem rArrayStateGet :
 forall (Ar Ar' : rArray vM) (S : State),
 rArrayState Ar S ->
 (forall e : rNat, rArrayGet vM Ar' e = rArrayGet vM Ar e) ->
 rArrayState Ar' S.
Proof.
intros Ar Ar' S H' H'0.
red in |- *; split; repeat rewrite <- (rArrayGetEvalZ _ _ H'0); auto with stalmarck;
 case (H' c d); auto with stalmarck.
Qed.

(** rArrayState is compatible with equality *)
Theorem rArrayStateEqState :
 forall (Ar : rArray vM) (S S' : State),
 rArrayState Ar S -> eqState S S' -> rArrayState Ar S'.
intros Ar S S' H' H'0; red in |- *; split.
intros H'1.
apply rArrayStateDef1 with (S := S); auto with stalmarck.
apply eqStateEq with (S1 := S'); auto with stalmarck.
intros H'1.
apply eqStateEq with (S1 := S); auto with stalmarck.
apply rArrayStateDef2 with (Ar := Ar); auto with stalmarck.
Qed.

(** The empty array represents the empty state *)
Theorem initCorrect :
 rArrayState (rArrayInit _ (fun n : rNat => class nil)) nil.
Proof.
red in |- *; intros c d; split; intros H'.
cut (eqConstrState nil c d).
intros H'0; inversion H'0; auto with stalmarck.
apply eqStateRzPImpeqConstrState; auto with stalmarck.
generalize H'; case c; case d; simpl in |- *; unfold evalN in |- *;
 intros r r0; rewrite (rArrayDef vM r0 (fun _ : rNat => class nil));
 rewrite (rArrayDef vM r (fun _ : rNat => class nil));
 simpl in |- *; intros H'0; rewrite H'0 || rewrite <- H'0;
 auto with stalmarck.
Qed.

Theorem getClassOlist :
 forall (Ar : rArray vM) (a : rZ),
 wellFormedArray Ar ->
 OlistRz (evalZ Ar a :: getClassN Ar (valRz (evalZ Ar a))).
Proof.
intros Ar a War; case a; simpl in |- *.
intros r; unfold evalN, getClassN in |- *.
CaseEq (rArrayGet vM Ar r); simpl in |- *.
intros r0; CaseEq (rArrayGet vM Ar (valRz r0)); simpl in |- *.
intros r1 H' H'0; red in |- *; apply OlistOne; auto with stalmarck.
intros l; case l.
intros H' H'0; red in |- *; apply OlistOne; auto with stalmarck.
intros r1 l0 H' H'0; red in |- *; apply OlistCons; auto with stalmarck.
apply wfOl with (Ar := Ar) (r := valRz r0); auto with stalmarck.
cut (rVlt (samePol r1 (valRz r0)) (valRz r1)).
case r1; simpl in |- *; auto with stalmarck.
apply wfPd with (Ar := Ar); auto with stalmarck.
apply wfPcc1 with (Lr := r1 :: l0); simpl in |- *; auto with stalmarck.
intros l; case l.
intros H'; rewrite H'; red in |- *; apply OlistOne; auto with stalmarck.
intros r0 l0 H'; rewrite H'; red in |- *; apply OlistCons; auto with stalmarck.
apply wfOl with (Ar := Ar) (r := r); auto with stalmarck.
cut (rVlt (samePol r0 r) (valRz r0)).
case r0; simpl in |- *; auto with stalmarck.
apply wfPd with (Ar := Ar); auto with stalmarck.
apply wfPcc1 with (Lr := r0 :: l0); simpl in |- *; auto with stalmarck.
intros r; unfold evalN, getClassN in |- *.
CaseEq (rArrayGet vM Ar r); simpl in |- *.
intros r0; rewrite (valRzComp r0); CaseEq (rArrayGet vM Ar (valRz r0));
 simpl in |- *.
intros r1 H' H'0; red in |- *; apply OlistOne; auto with stalmarck.
intros l; case l.
intros H' H'0; red in |- *; apply OlistOne; auto with stalmarck.
intros r1 l0 H' H'0; red in |- *; apply OlistCons; auto with stalmarck.
apply wfOl with (Ar := Ar) (r := valRz r0); auto with stalmarck.
cut (rVlt (samePol r1 (valRz r0)) (valRz r1)).
case r0; case r1; simpl in |- *; auto with stalmarck.
apply wfPd with (Ar := Ar); auto with stalmarck.
apply wfPcc1 with (Lr := r1 :: l0); simpl in |- *; auto with stalmarck.
intros l; case l.
intros H'; rewrite H'; red in |- *; apply OlistOne; auto with stalmarck.
intros r0 l0 H'; rewrite H'; red in |- *; apply OlistCons; auto with stalmarck.
apply wfOl with (Ar := Ar) (r := r); auto with stalmarck.
cut (rVlt (samePol r0 r) (valRz r0)).
case r0; simpl in |- *; auto with stalmarck.
apply wfPd with (Ar := Ar); auto with stalmarck.
apply wfPcc1 with (Lr := r0 :: l0); simpl in |- *; auto with stalmarck.
Qed.

(** [addMem] is correct, i.e.,

   - If the boolean is true, we have reached a contradiction
   - If the boolean is false, the resulting array is well-formed and
     it represents the state plus the equation,
     and the diff list is ordered, and elements outside this list are unchanged *)
Theorem addEqMemCorrect :
 forall (Ar : rArray vM) (a b : rZ) (S : State),
 wellFormedArray Ar ->
 rArrayState Ar S ->
 match addEqMem Ar a b with
 | triple Ar' false L =>
     wellFormedArray Ar' /\
     rArrayState Ar' (addEq (a, b) S) /\
     OlistRz L /\
     (forall c : rNat,
      ~ InRz (rZPlus c) L -> rArrayGet _ Ar' c = rArrayGet _ Ar c)
 | triple Ar' true L => contradictory (addEq (a, b) S)
 end.
Proof.
intros Ar a b S War H'; unfold addEqMem, letP in |- *.
case (rZltEDec (evalZ Ar a) (evalZ Ar b)); simpl in |- *.
intros s; case s; simpl in |- *.
intros H'0; split.
apply updateWellFormed; auto with stalmarck.
apply GetClassNProp; auto with stalmarck.
apply GetClassNProp; auto with stalmarck.
split.
red in |- *; intros c d; repeat split; intros H0.
case
 (updateCorrect Ar War (valRz (evalZ Ar a)) (valRz (evalZ Ar b))
    (samePolRz (evalZ Ar a) (evalZ Ar b)) (getClassN Ar (valRz (evalZ Ar a)))
    (getClassN Ar (valRz (evalZ Ar b)))) with (S := S) (c := c) (d := d);
 auto with stalmarck; auto with stalmarck.
apply GetClassNProp; auto with stalmarck.
apply GetClassNProp; auto with stalmarck.
intros H'1 H'2; apply H'1; auto with stalmarck.
apply eqStateIncl with (2 := H0); auto with stalmarck.
apply inclStateIn; simpl in |- *; auto with stalmarck.
intros a0 b0 H'3; Elimc H'3; intros H'3.
inversion H'3; auto with stalmarck.
apply eqStateRzTrans with (b := evalZ Ar a0).
apply eqStateaddEq2.
apply rArrayStateDef2 with (Ar := Ar); auto with stalmarck.
rewrite evalZInv; auto with stalmarck.
apply eqStateRzTrans with (b := evalZ Ar b0).
case (evalZ Ar a0); case (evalZ Ar b0); simpl in |- *; auto with stalmarck.
apply eqStateaddEq2.
apply rArrayStateDef2 with (Ar := Ar); auto with stalmarck.
rewrite evalZInv; auto with stalmarck.
apply eqStateaddEq2; auto with stalmarck.
apply
 eqStateIncl
  with
    (addEq
       (rZPlus (valRz (evalZ Ar a)),
       samePol (samePolRz (evalZ Ar a) (evalZ Ar b)) (valRz (evalZ Ar b))) S);
 auto with stalmarck.
apply inclStateIn; simpl in |- *; auto with stalmarck.
intros a0 b0 H'1; Elimc H'1; intros H'1; auto with stalmarck.
inversion H'1; auto with stalmarck.
apply eqStateRzTrans with (b := samePolRz (evalZ Ar a) a).
apply eqStateaddEq2.
apply rArrayStateDef2 with (Ar := Ar); auto with stalmarck.
generalize (evalZInv Ar War a); CaseEq (evalZ Ar a); simpl in |- *; auto with stalmarck.
intros r H'2; rewrite H'2; auto with stalmarck.
intros r H'2 H'3; rewrite evalZComp; rewrite H'2; rewrite <- H'3;
 case (evalN Ar r); auto with stalmarck.
apply eqStateRzTrans with (b := samePolRz (evalZ Ar a) b); auto with stalmarck.
case (evalZ Ar a); simpl in |- *; auto with stalmarck.
apply eqStateaddEq2.
apply rArrayStateDef2 with (Ar := Ar); auto with stalmarck.
case (evalZ Ar a); simpl in |- *; auto with stalmarck.
generalize (evalZInv Ar War b); CaseEq (evalZ Ar b); simpl in |- *; auto with stalmarck.
generalize (evalZInv Ar War b); CaseEq (evalZ Ar b); simpl in |- *; auto with stalmarck.
intros r H'2 H'3; rewrite evalZComp; rewrite H'3; rewrite <- H'2; auto with stalmarck.
intros r H'2 H'3; rewrite evalZComp; rewrite H'2; rewrite <- H'3; auto with stalmarck.
case
 (updateCorrect Ar War (valRz (evalZ Ar a)) (valRz (evalZ Ar b))
    (samePolRz (evalZ Ar a) (evalZ Ar b)) (getClassN Ar (valRz (evalZ Ar a)))
    (getClassN Ar (valRz (evalZ Ar b)))) with (S := S) (c := c) (d := d);
 auto with stalmarck; auto with stalmarck.
apply GetClassNProp; auto with stalmarck.
apply GetClassNProp; auto with stalmarck.
split.
red in |- *; apply OlistCons; auto with stalmarck.
apply getClassOlist; auto with stalmarck.
intros c H'1.
apply updateArrayOtherwise; auto with stalmarck.
Contradict H'1; simpl in |- *; auto with stalmarck.
red in |- *; repeat apply InEqSkip; auto with stalmarck.
Contradict H'1; rewrite H'1; simpl in |- *; auto with stalmarck.
red in |- *; apply InEqHead; auto with stalmarck.
Contradict H'1; rewrite H'1; auto with stalmarck.
red in |- *; apply InEqSkip; apply InEqHead; auto with stalmarck.
intros H'0; split.
apply updateWellFormed; auto with stalmarck.
apply GetClassNProp; auto with stalmarck.
apply GetClassNProp; auto with stalmarck.
split.
red in |- *; intros c d; split; intros H0.
case
 (updateCorrect Ar War (valRz (evalZ Ar b)) (valRz (evalZ Ar a))
    (samePolRz (evalZ Ar b) (evalZ Ar a)) (getClassN Ar (valRz (evalZ Ar b)))
    (getClassN Ar (valRz (evalZ Ar a)))) with (S := S) (c := c) (d := d);
 auto with stalmarck.
apply GetClassNProp; auto with stalmarck.
apply GetClassNProp; auto with stalmarck.
intros H'1 H'2; apply H'1; auto with stalmarck.
apply eqStateIncl with (2 := H0); auto with stalmarck.
apply inclStateIn; simpl in |- *; auto with stalmarck.
intros a0 b0 H'3; Elimc H'3; intros H'3.
inversion H'3; auto with stalmarck.
apply eqStateRzTrans with (b := evalZ Ar a0).
apply eqStateaddEq2.
apply rArrayStateDef2 with (Ar := Ar); auto with stalmarck.
rewrite evalZInv; auto with stalmarck.
apply eqStateRzTrans with (b := evalZ Ar b0).
case (evalZ Ar a0); case (evalZ Ar b0); simpl in |- *; auto with stalmarck; intros r1 r2;
 apply eqStateInvInv; auto with stalmarck.
apply eqStateaddEq2.
apply rArrayStateDef2 with (Ar := Ar); auto with stalmarck.
rewrite evalZInv; auto with stalmarck.
apply eqStateaddEq2; auto with stalmarck.
apply
 eqStateIncl
  with
    (addEq
       (rZPlus (valRz (evalZ Ar a)),
       samePol (samePolRz (evalZ Ar a) (evalZ Ar b)) (valRz (evalZ Ar b))) S);
 auto with stalmarck.
apply inclStateIn; simpl in |- *; auto with stalmarck.
intros a0 b0 H'1; Elimc H'1; intros H'1.
inversion H'1; auto with stalmarck.
apply eqStateRzTrans with (b := samePolRz (evalZ Ar a) a).
apply eqStateaddEq2.
apply rArrayStateDef2 with (Ar := Ar); auto with stalmarck.
generalize (evalZInv Ar War a); CaseEq (evalZ Ar a); simpl in |- *; auto with stalmarck.
intros r H'2; rewrite H'2; auto with stalmarck.
intros r H'2 H'3; rewrite evalZComp; rewrite H'2; rewrite <- H'3;
 case (evalN Ar r); auto with stalmarck.
apply eqStateRzTrans with (b := samePolRz (evalZ Ar a) b); auto with stalmarck.
case (evalZ Ar a); simpl in |- *; auto with stalmarck.
apply eqStateaddEq2.
apply rArrayStateDef2 with (Ar := Ar); auto with stalmarck.
case (evalZ Ar a); simpl in |- *; auto with stalmarck.
generalize (evalZInv Ar War b); CaseEq (evalZ Ar b); simpl in |- *; auto with stalmarck.
generalize (evalZInv Ar War b); CaseEq (evalZ Ar b); simpl in |- *; auto with stalmarck.
intros r H'2 H'3; rewrite evalZComp; rewrite H'3; rewrite <- H'2; auto with stalmarck.
intros r H'2 H'3; rewrite evalZComp; rewrite H'2; rewrite <- H'3; auto with stalmarck.
apply eqStateRzIn; unfold addEq in |- *; auto with datatypes stalmarck.
apply
 eqStateIncl
  with
    (addEq
       (rZPlus (valRz (evalZ Ar b)),
       samePol (samePolRz (evalZ Ar b) (evalZ Ar a)) (valRz (evalZ Ar a))) S);
 auto with stalmarck.
apply inclStateIn; simpl in |- *; auto with stalmarck.
intros a0 b0 H'1; Elimc H'1; intros H'1; auto with stalmarck.
inversion H'1; auto with stalmarck.
case (evalZ Ar a); case (evalZ Ar b); simpl in |- *; auto with stalmarck; intros r1 r2;
 apply eqStateInvInv; auto with stalmarck.
case
 (updateCorrect Ar War (valRz (evalZ Ar b)) (valRz (evalZ Ar a))
    (samePolRz (evalZ Ar b) (evalZ Ar a)) (getClassN Ar (valRz (evalZ Ar b)))
    (getClassN Ar (valRz (evalZ Ar a)))) with (S := S) (c := c) (d := d);
 auto with stalmarck; auto with stalmarck.
apply GetClassNProp; auto with stalmarck.
apply GetClassNProp; auto with stalmarck.
split; auto with stalmarck.
red in |- *; apply OlistCons; auto with stalmarck.
apply getClassOlist; auto with stalmarck.
intros c H'1.
apply updateArrayOtherwise; auto with stalmarck.
Contradict H'1; simpl in |- *; auto with stalmarck.
red in |- *; repeat apply InEqSkip; auto with stalmarck.
Contradict H'1; rewrite H'1; simpl in |- *; auto with stalmarck.
red in |- *; apply InEqHead; auto with stalmarck.
Contradict H'1; rewrite H'1; auto with stalmarck.
red in |- *; apply InEqSkip; apply InEqHead; auto with stalmarck.
case (rZDec (evalZ Ar a) (evalZ Ar b)); simpl in |- *; auto with stalmarck.
intros H'0 H'1; split; auto with stalmarck.
split; auto with stalmarck.
red in |- *; intros c d; split; intros H'2.
apply rArrayStateDef1 with (S := S); auto with stalmarck.
apply eqStateIncl with (2 := H'2); auto with stalmarck.
apply inclStateIn; simpl in |- *; auto with stalmarck.
intros a0 b0 H'3; Elimc H'3; intros H'3; auto with stalmarck.
apply rArrayStateDef2 with (Ar := Ar); auto with stalmarck.
inversion H'3; auto with stalmarck.
rewrite <- H1; rewrite <- H0; auto with stalmarck.
apply eqStateaddEq2.
apply rArrayStateDef2 with (Ar := Ar); auto with stalmarck.
split; auto with stalmarck.
red in |- *; apply OlistNil; auto with stalmarck.
intros H'0 H'1; red in |- *; exists a.
apply eqStateRzTrans with (b := b); auto with stalmarck.
apply eqStateaddEq2; auto with stalmarck.
apply rArrayStateDef2 with (Ar := Ar); auto with stalmarck.
rewrite evalZComp; auto with stalmarck.
generalize H'0 H'1; case (evalZ Ar a); case (evalZ Ar b); unfold eqRz in |- *;
 simpl in |- *; intros r r0 H'4 H'5; rewrite H'5; auto with stalmarck;
 case H'4; rewrite H'5; auto with stalmarck.
Qed.

(** Same but adding a=b and c=d *)
Definition addEqMem2 : forall (Ar : rArray vM) (a b c d : rZ), mbD.
intros Ar a b c d.
case (addEqMem Ar a b).
intros Ar' b' L'; case b'.
exact (mbDOp Ar' b' L').
case (addEqMem Ar' c d).
intros Ar'' b'' L''.
exact (mbDOp Ar'' b'' (appendRz L' L'')).
Defined.

Theorem addEqMem2Correct :
 forall (Ar : rArray vM) (a b c d : rZ) (S : State),
 wellFormedArray Ar ->
 rArrayState Ar S ->
 match addEqMem2 Ar a b c d with
 | triple Ar' false L =>
     wellFormedArray Ar' /\
     rArrayState Ar' (addEq (c, d) (addEq (a, b) S)) /\
     OlistRz L /\
     (forall e : rNat,
      ~ InRz (rZPlus e) L -> rArrayGet _ Ar' e = rArrayGet _ Ar e)
 | triple Ar' true L => contradictory (addEq (c, d) (addEq (a, b) S))
 end.
Proof.
intros Ar a b c d S War H'; unfold addEqMem2 in |- *.
generalize (addEqMemCorrect Ar a b S War H').
case (addEqMem Ar a b); simpl in |- *.
intros Ar' b' L'; case b'; simpl in |- *.
intros H'0; red in |- *; inversion H'0.
exists x; auto with stalmarck.
intros H'0; Elimc H'0; intros H'0 H'1; Elimc H'1; intros H'1 H'2; Elimc H'2;
 intros H'2 H'3.
generalize (addEqMemCorrect Ar' c d (addEq (pair a b) S) H'0 H'1);
 case (addEqMem Ar' c d); simpl in |- *.
intros Ar'' b'' L''; case b''; simpl in |- *; auto with stalmarck.
intros H'4; Elimc H'4; intros H'4 H'5; Elimc H'5; intros H'5 H'6; Elimc H'6;
 intros H'6 H'7; repeat (split; auto with stalmarck).
red in |- *; unfold appendRz in |- *; apply appendfOlist; auto with stalmarck.
exact rZltEqComp.
intros e H'8.
rewrite H'7; auto with stalmarck.
apply H'3; auto with stalmarck.
Contradict H'8; auto with stalmarck.
cut (InclEq _ eqRz L' (appendf _ rZlt eqRz rZltEDec L' L'')).
intros H'9; inversion H'9; red in |- *; auto with stalmarck.
apply appendfInclEq1; auto with stalmarck.
Contradict H'8; auto with stalmarck.
cut (InclEq _ eqRz L'' (appendf _ rZlt eqRz rZltEDec L' L'')).
intros H'9; inversion H'9; red in |- *; auto with stalmarck.
apply appendfInclEq2; auto with stalmarck.
Qed.


(*
   練習問題 2.1
   Z の中で二つの整数値の平均を計算する
   関数 heikin : Z -> Z -> Z を定義せよ.
*)

Require Import ZArith.
Module Z.
  Definition heikin (x y : nat) := (x + y) / 2.
  Eval compute in heikin 10 20.
End Z.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C D X Bprimeprime Bprime Dprime : Universe, ((wd_ C O /\ (wd_ A O /\ (wd_ B O /\ (wd_ D O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ Eprime C /\ (wd_ Bprime O /\ (wd_ X O /\ (wd_ E Bprimeprime /\ (wd_ C Bprime /\ (wd_ B Bprimeprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O E D /\ (col_ O Eprime Bprimeprime /\ (col_ O Eprime Bprime /\ col_ O Eprime Dprime))))))))))))))))))) -> col_ O A C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import FunctionalExtensionality.

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

(** ** Notations *)

Reserved Notation "x >>= f" (at level 42, left associativity).
Reserved Notation "x >>- f" (at level 42, left associativity).

(** ** Definition of monad. *)
Section axioms.
Variable T : Type -> Type.
Variable val : forall X, X -> T X.
Variable bind : forall X Y, T X -> (X -> T Y) -> T Y.
Definition val_bind := forall A B f a, @bind A B (val a) f = f a.
Definition bind_val := forall A t, @bind A A t (@val A) = t.
Definition bind_bind := forall A B C t f g, @bind B C (@bind A B t f) g = bind t (fun x => bind (f x) g).
End axioms.

Record monadType := Monad {
  T :> Type -> Type;
  tval : forall X, X -> T X;
  tbind : forall X Y, T X -> (X -> T Y) -> T Y;
  taxiom0 : @val_bind T tval tbind;
  taxiom1 : @bind_val T tval tbind;
  taxiom2 : @bind_bind T tbind
}.

(*Implicit Arguments tval[X].
Implicit Arguments tbind[X Y].*)

Notation "x >>= f" := (@tbind _ _ _ x f).

Hint Rewrite taxiom0 taxiom1 taxiom2 : monad.
Hint Extern 1 (_ = _ : T _ _) => autorewrite with monad : monad.

Ltac monad := intros; autorewrite with monad; auto with monad.

Definition map (P : monadType) X Y
  (f : X -> Y) (x : P X) : P Y :=
  x >>= (fun x => tval P (f x)).

Notation "x >>- f" := (@map _ _ _ f x).
Notation "'return' m" := ((@tval m) _)
                            (at level 40, m ident, no associativity).

Notation "'do' X '<-' A ; B" := (@tbind _ _ _ A (fun X => B))
                 (at level 200, X ident, A at level 100, B at level 200).

Section monadFacts.
Variable P : monadType.

Lemma bind_congr : forall X Y (f g : X -> P Y) (x y : P X),
  x = y -> (forall a, f a = g a) -> x >>= f = y >>= g.
Proof.
intros.
assert (E : g = f)
  by (apply functional_extensionality; auto).
now subst y g.
Qed.

Lemma unit_bind_match : forall X
  (f : X -> P X) (x : P X),
  (forall a, f a = tval P a) -> x >>= f = x.
Proof.
intros. transitivity (x >>= @tval P X).
apply bind_congr; auto.
auto with monad.
Qed.

Hint Resolve bind_congr unit_bind_match : monad.
End monadFacts.

Definition Cont (R : Type) : monadType.
exists
  (fun X => (X -> R) -> R)
  (fun X => fun x c => c x)
  (fun X Y => fun t f => fun c => t (fun x => f x c)).
- now monad.
- now monad.
- now monad.
Defined.

Definition State (S : Type) : monadType.
exists
  (fun X => S -> X * S)
  (fun X => fun (x:X) (s:S) => (x, s))
  (fun X Y => fun t f =>
    fun s => let '(x1, s1) := t s in f x1 s1).
- unfold val_bind; intuition.
- unfold bind_val. intros A t.
  extensionality s. now destruct (t s).
- unfold bind_bind. intros A B C t f g.
  extensionality s. now destruct (t s).
Defined.

Definition StateT (S : Type) (M : monadType) : monadType.
exists
  (fun X => S -> M (X * S)%type)
  (fun X => fun x s => tval _ (x,s))
  (fun X Y => fun t f =>
     fun s =>
       do p <- (t s);
       let (v,s') := p : (X * S)%type in f v s').
- unfold val_bind. intros. extensionality s. now monad.
- unfold bind_val. intros. extensionality s.
  assert (H : forall X Y Z (f : X * Y -> Z),
                (fun p => let (x,y) := p : (X * Y)%type in f (x,y)) = f)
    by (intros; extensionality p; now destruct p).
  rewrite H. now monad.
- unfold bind_bind. intros. extensionality s.
  rewrite taxiom2. f_equal. extensionality p.
  now destruct p.
Defined.

Definition Error : monadType.
exists
  (fun X => Exc X)
  (fun X (x:X) => value x)
  (fun X Y t f =>
    match t with
      | error => error
      | value x => f x end).
- unfold val_bind; intuition.
- unfold bind_val. intros A t. now destruct t.
- unfold bind_bind. intros A B C t f g.
  destruct t; now try destruct (f a).
Defined.

Definition ErrorT (M : monadType) : monadType.
exists
  (fun X => M (Exc X))
  (fun X x => tval _ (value x))
  (fun X Y t f => t >>= fun t =>
    match t with
      | error => tval _ error
      | value x => f x end).
- unfold val_bind; intuition.
- unfold bind_val. intros A t. apply unit_bind_match.
  intros a. now destruct a.
- unfold bind_bind. intros A B C t f g. rewrite taxiom2.
  apply bind_congr; auto.
  now destruct a; monad.
Defined.

Definition Id : monadType.
exists
  (fun X => X)
  (fun X x => x)
  (fun X Y t f => f t); easy.
Defined.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal49.

From lfind Require Import LFind.
Require Import Arith.
Require Import Extraction.
Extract Inductive nat => nat [ "(O)" "S" ].
Extract Inductive list => list [ "Nil" "Cons" ].
Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal49_theorem0_158_eqb_refl/goal49_lfind_orig.ml"  adtind.goal49.sort Coq.Init.Datatypes.orb adtind.goal49.eqb adtind.goal49.mem.
Success.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal29.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons (Succ Zero) Nil).
Definition lfind_example_2  := ( Cons (Succ Zero) (Cons Zero (Cons Zero Nil))).
Definition lfind_example_3  := ( Cons Zero (Cons (Succ (Succ (Succ Zero))) (Cons Zero Nil))).
Definition lfind_example_4  := ( Cons Zero (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_5  := ( Cons Zero         (Cons Zero            (Cons (Succ Zero) (Cons Zero (Cons Zero (Cons Zero Nil)))))).
Definition lfind_example_6  := ( Cons Zero Nil).
Definition lfind_example_7  := ( Cons Zero (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_8  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_9  := ( Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) Nil)))).
Definition lfind_example_10  := ( Cons Zero Nil).
Definition lfind_example_11  := ( Cons (Succ Zero)         (Cons Zero (Cons (Succ (Succ (Succ (Succ Zero)))) Nil))).
Definition lfind_example_12  := ( Cons Zero Nil).
Definition lfind_example_13  := ( Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil))).
Definition lfind_example_14  := ( Cons (Succ Zero) (Cons Zero (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_15  := ( Cons Zero Nil).
Definition lfind_example_16  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_17  := ( Cons (Succ Zero) Nil).
Definition lfind_example_18  := ( Cons Zero Nil).
Definition lfind_example_19  := ( Cons (Succ Zero) Nil).
Definition lfind_example_20  := ( Cons (Succ Zero)         (Cons (Succ (Succ Zero))            (Cons Zero               (Cons (Succ (Succ (Succ (Succ Zero))))                  (Cons (Succ (Succ Zero)) Nil))))).
Definition lfind_example_21  := ( Cons (Succ (Succ (Succ Zero))) Nil).
Definition lfind_example_22  := ( Cons Zero Nil).
Definition lfind_example_23  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_24  := ( Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil))).
Definition lfind_example_25  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_26  := ( Cons (Succ (Succ Zero)) (Cons Zero Nil)).
Definition lfind_example_27  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_28  := ( Cons Zero (Cons Zero (Cons (Succ Zero) Nil))).
Definition lfind_example_29  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_30  := ( Cons (Succ (Succ Zero)) (Cons Zero Nil)).
Definition lfind_example_31  := ( Cons (Succ Zero)         (Cons (Succ (Succ (Succ Zero))) (Cons Zero (Cons (Succ Zero) Nil)))).
Definition lfind_example_32  := ( Cons (Succ Zero) (Cons Zero (Cons Zero Nil))).
Definition lfind_example_33  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_34  := ( Cons Zero Nil).
Definition lfind_example_35  := ( Cons (Succ Zero) Nil).
Definition lfind_example_36  := ( Cons Zero (Cons Zero (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_37  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_38  := ( Cons (Succ (Succ (Succ (Succ Zero)))) Nil).
Definition lfind_example_39  := ( Cons (Succ (Succ (Succ (Succ Zero)))) Nil).
Definition lfind_example_40  := ( Cons (Succ (Succ (Succ (Succ (Succ (Succ Zero)))))) Nil).
Definition lfind_example_41  := ( Cons Zero Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal29_append_rev_cons_50_append_assoc/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 lfind_example_17 lfind_example_18 lfind_example_19 lfind_example_20 lfind_example_21 lfind_example_22 lfind_example_23 lfind_example_24 lfind_example_25 lfind_example_26 lfind_example_27 lfind_example_28 lfind_example_29 lfind_example_30 lfind_example_31 lfind_example_32 lfind_example_33 lfind_example_34 lfind_example_35 lfind_example_36 lfind_example_37 lfind_example_38 lfind_example_39 lfind_example_40 lfind_example_41 .


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

- Sebastien Hinderer, 2004-02-09
- Frederic Blanqui, 2005-02-17

algebraic terms with fixed arity
*)

Set Implicit Arguments.

From Coq Require Export Vector.
From CoLoR Require Export ASignature.
From Coq Require Import Max.
From CoLoR Require Import ListUtil LogicUtil EqUtil BoolUtil NatUtil VecUtil
     VecMax ListMax.

Notation variables := (list variable) (only parsing).

Section S.

  Variable Sig : Signature.

(***********************************************************************)
(** terms *)

  (*COQ: we do not use the induction principle generated by Coq since it
     is not good because the argument of Fun is a vector *)

  Unset Elimination Schemes.

  Inductive term : Type :=
  | Var : variable -> term
  | Fun : forall f : Sig, vector term (arity f) -> term.

  Set Elimination Schemes.

  Notation terms := (vector term).

(***********************************************************************)
(** induction principles *)

  Section term_rect.

    Variables
      (P : term -> Type)
      (Q : forall n, terms n -> Type).

    Hypotheses
      (H1 : forall x, P (Var x))
      (H2 : forall f v, Q v -> P (Fun f v))
      (H3 : Q Vnil)
      (H4 : forall t n (v : terms n), P t -> Q v -> Q (Vcons t v)).

    Fixpoint term_rect t : P t :=
      match t as t return P t with
        | Var x => H1 x
        | Fun f v =>
          let fix terms_rect n (v : terms n) : Q v :=
            match v as v return Q v with
              | Vnil => H3
              | Vcons t' v' => H4 (term_rect t') (terms_rect _ v')
            end
	    in H2 f (terms_rect (arity f) v)
      end.

  End term_rect.

  Definition term_ind (P : term -> Prop) (Q : forall n, terms n -> Prop) :=
    term_rect P Q.

  Section term_ind_comb.

    Variables
      (Pt : term -> Prop)
      (Ps : forall n, terms n -> Prop).

    Hypotheses
      (Hvar : forall x, Pt (Var x))
      (Hfun : forall f ts, Ps ts -> Pt (Fun f ts))
      (Hnil : Ps Vnil)
      (Hcns : forall t n (ts : terms n), Pt t -> Ps ts -> Ps (Vcons t ts)).

    Lemma term_ind_comb : (forall t, Pt t) /\ (forall n (ts : terms n), Ps ts).

    Proof.
      split; [by apply term_ind with (Q := Ps) | intros n ts].
      induction ts; [exact Hnil | apply Hcns; [idtac | hyp]].
      by apply term_ind with (Q := Ps) .
    Qed.

  End term_ind_comb.

  Lemma term_ind_forall : forall (P : term -> Prop)
    (H1 : forall v, P (Var v))
    (H2 : forall f v, Vforall P v -> P (Fun f v)),
    forall t, P t.

  Proof.
    intros. apply term_ind with (Q := Vforall P). exact H1. exact H2.
    exact I. intros. simpl. split; hyp.
  Qed.

  Lemma term_ind_forall_cast : forall (P : term -> Prop)
    (Hvar : forall x, P (Var x))
    (Hfun : forall f n (ts : terms n) (h : n = arity f),
      Vforall P ts -> P (Fun f (Vcast ts h))),
    forall t, P t.

  Proof.
    intros. apply term_ind_forall. hyp. intros.
    rewrite <- (Vcast_refl v (eq_refl (arity f))). apply Hfun. hyp.
  Qed.

  Lemma term_ind_forall2 : forall (P : term -> Prop)
    (H1 : forall v, P (Var v))
    (H2 : forall f v, (forall t, Vin t v -> P t) -> P (Fun f v)),
    forall t, P t.

  Proof.
    intros. apply term_ind
    with (Q := fun n (ts : terms n) => forall t, Vin t ts -> P t).
    exact H1. exact H2. contr. simpl. intuition. subst t1. exact H.
  Qed.

(***********************************************************************)
(** equality *)

  Lemma var_eq : forall x x', x = x' -> Var x = Var x'.

  Proof. intros. rewrite H. refl. Qed.

  Lemma args_eq : forall f v v', v = v' -> Fun f v = Fun f v'.

  Proof. intros. rewrite H. refl. Qed.

  Lemma fun_eq : forall f v w, Fun f v = Fun f w -> v = w.

  Proof.
    intros. inversion H. apply (inj_existT (@eq_symb_dec _) H1).
  Qed.

  Lemma symb_eq : forall f us g vs, Fun f us = Fun g vs -> f = g.

  Proof.
    intros. inversion H. refl.
  Qed.

  Lemma fun_eq_cast : forall f g m (ts : terms m) n (us : terms n)
    (p : m = arity f) (q : n = arity g) (r : m=n), f = g ->
    us = Vcast ts r -> Fun f (Vcast ts p) = Fun g (Vcast us q).

  Proof.
    destruct ts; intros.
    (* Vnil *)
    subst g. apply args_eq. destruct n. 2: discr. VOtac. assert (p=q).
    apply eq_unique. subst q. apply Vcast_eq_intro. auto.
    (* Vcons *)
    subst g. apply args_eq. destruct n0. discr. rewrite H0, Vcast_cast.
    assert (trans_eq r q = p). apply eq_unique. rewrite H. refl.
  Qed.

  Lemma fun_eq_intro : forall f ts g us (h : f = g),
    us = Vcast ts (f_equal (@arity Sig) h) -> Fun f ts = Fun g us.

  Proof.
    intros. rewrite <- (Vcast_refl ts (eq_refl (arity f))),
            <- (Vcast_refl us (eq_refl (arity g))).
    eapply fun_eq_cast. hyp. apply H.
  Qed.

  Lemma symb_arg_eq :  forall f us g vs (h : f = g),
    Fun f us = Fun g vs -> vs = Vcast us (f_equal (@arity Sig) h).

  Proof.
    intros.
    assert (q' : arity f = arity g). rewrite h; auto.
    assert (H1 : (Vcast us q') = (Vcast us (f_equal (@arity Sig) h))).
    apply Vcast_pi.
    gen (fun_eq_intro us h H1). intro. rewrite H0 in H.
    gen (fun_eq H). intro T; rewrite <- T. apply Vcast_pi.
  Qed.

(***********************************************************************)
(** decidability of equality *)

  Fixpoint beq_term (t u : term) :=
    match t, u with
      | Var x, Var y => beq_nat x y
      | Fun f ts, Fun g us =>
        let fix beq_terms n (ts : terms n) p (us : terms p) :=
          match ts, us with
            | Vnil, Vnil => true
            | Vcons t ts', Vcons u us' =>
              beq_term t u && beq_terms _ ts' _ us'
            | _, _ => false
          end
          in beq_symb f g && beq_terms _ ts _ us
      | _, _ => false
    end.

  Lemma beq_terms : forall n (ts : terms n) p (us : terms p),
    (fix beq_terms n (ts : terms n) p (us : terms p) :=
      match ts, us with
        | Vnil, Vnil => true
        | Vcons t ts', Vcons u us' => beq_term t u && beq_terms _ ts' _ us'
        | _, _ => false
      end) _ ts _ us = beq_vec beq_term ts us.

  Proof.
    induction ts; destruct us; refl.
  Qed.

  Lemma beq_fun : forall f ts g us,
    beq_term (Fun f ts) (Fun g us) = beq_symb f g && beq_vec beq_term ts us.

  Proof. intros. rewrite <- beq_terms. refl. Qed.

  Lemma beq_term_ok : forall t u, beq_term t u = true <-> t = u.

  Proof.
    intro t. pattern t. apply term_ind_forall2; destruct u.
    simpl. rewrite beq_nat_ok. intuition. inversion H. refl.
    intuition; discr. intuition; discr.
    rewrite beq_fun. split; intro. destruct (andb_elim H0).
    rewrite beq_symb_ok in H1. subst f0. apply args_eq.
    ded (beq_vec_ok_in1 H H2). rewrite <- H1. rewrite Vcast_refl. refl.
    inversion H0 as [[h0 h1]]. clear h1. subst f0. simpl.
    apply andb_intro. apply (beq_refl (@beq_symb_ok Sig)).
    apply beq_vec_ok_in2. exact H. refl.
  Qed.

  Definition eq_term_dec := dec_beq beq_term_ok.

(* old version using Eqdep's axiom: *)

(*Lemma eq_term_dec : forall t u : term, {t=u}+{~t=u}.

Proof.
intro. pattern t. apply term_rect with
  (Q := fun n (ts : terms n) => forall u, {ts=u}+{~ts=u}); clear t.
(* var *)
intros. destruct u. case (eq_nat_dec x n); intro. subst n. auto.
right. unfold not. intro. injection H. auto.
right. unfold not. intro. discr.
(* fun *)
intros f ts H u. destruct u. right. unfold not. intro. discr.
case (eq_symbol_dec f f0); intro. subst f0. case (H v); intro. subst ts. auto.
right. intro. injection H0. intro. assert (ts=v).
(* FIXME: can be removed ? *) From CoLoR Require Import Eqdep.
apply (inj_pair2 Sig (fun f => terms (arity f))). hyp. auto.
right. unfold not. intro. injection H0. intros. auto.
(* nil *)
intro. VOtac. auto.
(* cons *)
intros. VSntac u. case (X (Vhead u)); intro. rewrite e.
case (X0 (Vtail u)); intro. rewrite e0. auto.
right. unfold not. intro. injection H0. intro. assert (v = Vtail u).
apply (inj_pair2 nat (fun n => terms n)). hyp. auto.
right. unfold not. intro. injection H0. intros. auto.
Defined.*)

(***********************************************************************)
(** maximal variable index in a term *)

  Fixpoint maxvar (t : term) : nat :=
    match t with
      | Var x => x
      | Fun f v => Vmax (Vmap maxvar v)
    end.

  Definition maxvars n (ts : terms n) := Vmax (Vmap maxvar ts).

  Lemma maxvars_cons : forall t n (ts : terms n),
    maxvars (Vcons t ts) = max (maxvar t) (maxvars ts).

  Proof. refl. Qed.

  Lemma maxvar_fun : forall f ts, maxvar (Fun f ts) = maxvars ts.

  Proof. refl. Qed.

  Lemma maxvar_var : forall k x, maxvar (Var x) <= k -> x <= k.

  Proof.
    intros. simpl. intuition.
  Qed.

  Definition maxvar_le k t := maxvar t <= k.

  Lemma maxvar_le_fun : forall m f ts,
    maxvar (Fun f ts) <= m -> Vforall (maxvar_le m) ts.

  Proof.
    intros until ts. rewrite maxvar_fun. intro. gen (Vmax_forall H).
    clear H. intro H. gen (Vforall_map_elim H). intuition.
  Qed.

  Lemma maxvar_le_arg : forall f ts m t,
    maxvar (Fun f ts) <= m -> Vin t ts -> maxvar t <= m.

  Proof.
    intros. assert (Vforall (maxvar_le m) ts). apply maxvar_le_fun. hyp.
    change (maxvar_le m t). eapply Vforall_in with (n := arity f). apply H1.
    hyp.
  Qed.

  Lemma maxvars_cast : forall n (ts : terms n) p (e : n=p),
    maxvars (Vcast ts e) = maxvars ts.

  Proof.
    induction ts; destruct p; intros; try lia.
    rewrite Vcast_refl. refl.
    rewrite Vcast_cons, !maxvars_cons, IHts. refl.
  Qed.

(***********************************************************************)
(** list of variables in a term:
a variable occurs in the list as much as it has occurrences in t *)

  Fixpoint vars (t : term) : variables :=
    match t with
      | Var x => x :: nil
      | Fun f v =>
        let fix vars_vec n (ts : terms n) : variables :=
          match ts with
            | Vnil => nil
            | Vcons t' ts' => vars t' ++ vars_vec _ ts'
          end
          in vars_vec (arity f) v
    end.

  Fixpoint vars_vec n (ts : terms n) : variables :=
    match ts with
      | Vnil => nil
      | Vcons t' ts' => vars t' ++ vars_vec ts'
    end.

  Lemma vars_fun : forall f ts, vars (Fun f ts) = vars_vec ts.

  Proof. auto. Qed.

  Lemma vars_vec_cast : forall n (ts : terms n) m (h : n=m),
    vars_vec (Vcast ts h) = vars_vec ts.

  Proof.
    induction ts; intros; destruct m; simpl; try discr.
    rewrite Vcast_refl. refl.
    rewrite Vcast_cons. apply (f_equal (fun l => vars h ++ l)). apply IHts.
  Qed.

  Lemma vars_vec_app : forall n1 (ts1 : terms n1) n2 (ts2 : terms n2),
    vars_vec (Vapp ts1 ts2) = vars_vec ts1 ++ vars_vec ts2.

  Proof.
    induction ts1; intros; simpl. refl. rewrite app_ass. f_equal. apply IHts1.
  Qed.

  Lemma vars_vec_cons : forall t n (ts : terms n),
    vars_vec (Vcons t ts) = vars t ++ vars_vec ts.

  Proof. refl. Qed.

  Lemma in_vars_vec_elim : forall x n (ts : terms n),
    In x (vars_vec ts) -> exists t, Vin t ts /\ In x (vars t).

  Proof.
    induction ts; simpl; intros. contr. gen (in_app_or H). intro.
    destruct H0. exists h. intuition. gen (IHts H0). intro.
    destruct H1 as [t].
    exists t. intuition.
  Qed.

  Lemma vars_vec_in : forall x t n (ts : terms n),
    In x (vars t) -> Vin t ts -> In x (vars_vec ts).

  Proof.
    induction ts; simpl; intros. contr. destruct H0. subst t.
    apply in_appl. hyp. apply in_appr. apply IHts; hyp.
  Qed.

  Lemma vars_max : forall x t, In x (vars t) -> x <= maxvar t.

  Proof.
    intros x t. pattern t. apply term_ind with (Q := fun n (ts : terms n) =>
    In x (vars_vec ts) -> x <= maxvars ts); clear t; intros.
    simpl in *. intuition. rewrite maxvar_fun. rewrite vars_fun in H0. auto.
    contr. simpl in *.
    destruct (in_app_or H1); unfold maxvars; simpl. apply le_max_intro_l. auto.
    apply le_max_intro_r. auto.
  Qed.

  Lemma maxvar_in : forall x t n (v : terms n),
    x <= maxvar t -> Vin t v -> x <= maxvars v.

  Proof.
    induction v; unfold maxvars; simpl; intros. contr. destruct H0.
    subst t. apply le_max_intro_l. hyp. apply le_max_intro_r. apply IHv; hyp.
  Qed.

  Lemma maxvar_lmax : forall t, maxvar t = lmax (vars t).

  Proof.
    intro t. pattern t.
    set (Q := fun n (ts : terms n) => maxvars ts = lmax (vars_vec ts)).
    apply term_ind with (Q := Q); clear t.
    intro. simpl. apply (sym_equal (max_l (le_O_n x))).
    intros f ts H. rewrite maxvar_fun, vars_fun. hyp.
    unfold Q. auto.
    intros t n ts H1 H2. unfold Q. simpl. rewrite lmax_app.
    unfold Q in H2. rewrite maxvars_cons, H1, H2. refl.
  Qed.

(***********************************************************************)
(** boolean function testing if a variable occurs in a term *)

  Section var_occurs_in.

    Variable x : variable.

    Fixpoint var_occurs_in t :=
      match t with
        | Var y => beq_nat x y
        | Fun f ts =>
          let fix var_occurs_in_terms n (ts : terms n) :=
            match ts with
              | Vnil => false
              | Vcons t ts' => var_occurs_in t || var_occurs_in_terms _ ts'
            end
            in var_occurs_in_terms _ ts
      end.

    Fixpoint var_occurs_in_terms n (ts : terms n) :=
      match ts with
        | Vnil => false
        | Vcons t ts' => var_occurs_in t || var_occurs_in_terms ts'
      end.

    Lemma var_occurs_in_fun :
      forall f ts, var_occurs_in (Fun f ts) = var_occurs_in_terms ts.

    Proof. auto. Qed.

    Lemma var_occurs_in_ok : forall t,
      var_occurs_in t = true <-> In x (vars t).

    Proof.
      apply term_ind_forall. intro n; simpl. rewrite (beq_nat_ok x n).
      intuition.
      intros f v Rfv. rewrite var_occurs_in_fun, vars_fun.
      induction v. simpl. intuition.
      simpl in Rfv. destruct Rfv as [Rfa Rfv]. simpl. rewrite orb_eq.
      split; intros H. apply in_or_app. rewrite <- Rfa, <- IHv; auto.
      rewrite Rfa, IHv; auto. apply in_app_or. auto.
    Qed.

  End var_occurs_in.

(***********************************************************************)
(** number of symbol occurrences in a term *)

  Fixpoint nb_symb_occs t :=
    match t with
      | Var x => 0
      | Fun f ts =>
        let fix nb_symb_occs_terms n (ts : terms n) :=
          match ts with
            | Vnil => 0
            | Vcons u us => nb_symb_occs u + nb_symb_occs_terms _ us
          end
          in 1 + nb_symb_occs_terms _ ts
    end.

  Fixpoint nb_symb_occs_terms n (ts : terms n) :=
    match ts with
      | Vnil => 0
      | Vcons u us => nb_symb_occs u + nb_symb_occs_terms us
    end.

  Lemma nb_symb_occs_fix : forall n (ts : terms n),
    (fix nb_symb_occs_terms n (ts : terms n) :=
      match ts with
        | Vnil => 0
        | Vcons u us => nb_symb_occs u + nb_symb_occs_terms _ us
      end) _ ts = nb_symb_occs_terms ts.

  Proof. induction ts; simpl; intros. refl. rewrite IHts. refl. Qed.

  Lemma nb_symb_occs_fun : forall f ts,
    nb_symb_occs (Fun f ts) = 1 + nb_symb_occs_terms ts.

  Proof. intros. simpl. rewrite nb_symb_occs_fix. refl. Qed.

  Lemma Vin_nb_symb_occs_terms_ge : forall n (ts : terms n) t,
    Vin t ts -> nb_symb_occs_terms ts >= nb_symb_occs t.

  Proof.
    induction ts; simpl; intros. contr. destruct H. subst h. lia.
    ded (IHts _ H). lia.
  Qed.

(***********************************************************************)
(** list of symbols occurring in a term *)

  Fixpoint symbs (t : term) : list Sig :=
    match t with
      | Var x => nil
      | Fun f v =>
        let fix symbs_vec n (ts : terms n) : list Sig :=
          match ts with
            | Vnil => nil
            | Vcons t' ts' => symbs t' ++ symbs_vec _ ts'
          end
          in f :: symbs_vec (arity f) v
    end.

  Fixpoint symbs_vec n (ts : terms n) : list Sig :=
    match ts with
      | Vnil => nil
      | Vcons t' ts' => symbs t' ++ symbs_vec ts'
    end.

  Lemma symbs_fun : forall f ts, symbs (Fun f ts) = f :: symbs_vec ts.

  Proof. auto. Qed.

  Lemma symbs_vec_cast : forall n (ts : terms n) m (h : n=m),
    symbs_vec (Vcast ts h) = symbs_vec ts.

  Proof.
    induction ts; intros; destruct m; simpl; try discr.
    rewrite Vcast_refl. refl.
    rewrite Vcast_cons. apply (f_equal (fun l => symbs h ++ l)). apply IHts.
  Qed.

  Lemma symbs_vec_app : forall n1 (ts1 : terms n1) n2 (ts2 : terms n2),
    symbs_vec (Vapp ts1 ts2) = symbs_vec ts1 ++ symbs_vec ts2.

  Proof.
    induction ts1; intros; simpl. refl. rewrite app_ass. f_equal. apply IHts1.
  Qed.

  Lemma symbs_vec_cons : forall t n (ts : terms n),
    symbs_vec (Vcons t ts) = symbs t ++ symbs_vec ts.

  Proof. refl. Qed.

  Lemma in_symbs_vec_elim : forall x n (ts : terms n),
    In x (symbs_vec ts) -> exists t, Vin t ts /\ In x (symbs t).

  Proof.
    induction ts; simpl; intros. contr. gen (in_app_or H). intro.
    destruct H0. exists h. intuition. gen (IHts H0). intro.
    destruct H1 as [t]. exists t. intuition.
  Qed.

  Lemma symbs_vec_in : forall x t n (ts : terms n),
    In x (symbs t) -> Vin t ts -> In x (symbs_vec ts).

  Proof.
    induction ts; simpl; intros. contr. destruct H0. subst t.
    apply in_appl. hyp. apply in_appr. apply IHts; hyp.
  Qed.

(***********************************************************************)
(** size of a term *)

  Fixpoint size t :=
    match t with
      | Var x => 1
      | Fun f ts =>
        let fix size_terms n (ts : terms n) :=
          match ts with
            | Vnil => 0
            | Vcons u us => size u + size_terms _ us
          end
          in 1 + size_terms _ ts
    end.

  Fixpoint size_terms n (ts : terms n) :=
    match ts with
      | Vnil => 0
      | Vcons u us => size u + size_terms us
    end.

  Lemma size_fix : forall n (ts : terms n),
    (fix size_terms n (ts : terms n) :=
      match ts with
        | Vnil => 0
        | Vcons u us => size u + size_terms _ us
      end) _ ts = size_terms ts.

  Proof. induction ts; simpl; intros. refl. rewrite IHts. refl. Qed.

  Lemma size_fun : forall f ts, size (Fun f ts) = 1 + size_terms ts.

  Proof. intros. simpl. rewrite size_fix. refl. Qed.

  Lemma size_non_zero : forall t, size t > 0.

  Proof.
    intro. pattern t. apply term_ind with (Q := fun n (ts : terms n) =>
    size_terms ts >= 0); clear t.
    intro. simpl. lia.
    intros. rewrite size_fun. lia.
    simpl. lia.
    intros. simpl. lia.
  Qed.

  Lemma Vin_size_terms_ge : forall n (ts : terms n) t,
    Vin t ts -> size_terms ts >= size t.

  Proof.
    induction ts; simpl; intros. contr. destruct H. subst h. lia.
    ded (IHts _ H). lia.
  Qed.

  Arguments Vin_size_terms_ge [n ts t] _.

  Lemma Vin_size_terms_gt : forall n (ts : terms n) t,
    Vin t ts -> n > 1 -> size_terms ts > size t.

  Proof.
    intro. destruct n. lia. destruct n. lia. intros.
    VSntac ts. rewrite H1 in H. VSntac (Vtail ts). rewrite H2 in H. simpl in *.
    ded (size_non_zero (Vhead ts)). ded (size_non_zero (Vhead (Vtail ts))).
    destruct H. subst t. lia. destruct H. subst t. lia.
    ded (Vin_size_terms_ge H). lia.
  Qed.

  Lemma size_terms_cast : forall n (ts : terms n) m (h : n=m),
    size_terms (Vcast ts h) = size_terms ts.

  Proof.
    induction ts; intro m.
    (* Vnil *)
    destruct m; intro h.
    rewrite Vcast_refl. refl.
    discr.
    (* Vcons *)
    destruct m; intro h0.
    discr.
    rewrite Vcast_cons. simpl. rewrite IHts. refl.
  Qed.

  Lemma size_terms_app : forall n (ts : terms n) m (us : terms m),
    size_terms (Vapp ts us) = size_terms ts + size_terms us.

  Proof. induction ts; simpl; intros. refl. rewrite IHts. lia. Qed.

  Lemma term_ind_size : forall (P : term -> Prop),
    (forall n, (forall t, size t <= n -> P t) -> forall t, size t <= S n -> P t)
    -> forall t, P t.

  Proof.
    intro P. set (Q := fun n => forall t, size t <= n -> P t).
    change ((forall n, Q n -> Q (S n)) -> forall t, P t). intro IH.
    cut (forall t, Q t). intros. unfold Q in H. eapply H. apply le_refl.
    induction t. unfold Q. destruct t; simpl; intros; lia.
    apply IH. hyp.
  Qed.

(***********************************************************************)
(** direct subterms of a term *)

  Definition direct_subterms (t : term) : list term :=
    match t with
      | Var x => nil
      | Fun f fs => list_of_vec fs
    end.

End S.

(***********************************************************************)
(** implicit arguments *)

Arguments Var [Sig] _.
Arguments maxvar_var [Sig k x] _.
Arguments maxvar_le_fun [Sig m f ts] _.
Arguments maxvar_le_arg [Sig f ts m t] _ _.
Arguments in_vars_vec_elim [Sig x n ts] _.
Arguments vars_vec_in [Sig x t0 n ts] _ _ : rename.
Arguments in_symbs_vec_elim [Sig x n ts] _.
Arguments symbs_vec_in [Sig x t0 n ts] _ _ : rename.
Arguments vars_max [Sig x t] _.
Arguments Vin_nb_symb_occs_terms_ge [Sig n ts t] _.
Arguments Vin_size_terms_ge [Sig n ts t] _.
Arguments Vin_size_terms_gt [Sig n ts t] _ _.

(***********************************************************************)
(** tactics *)

Ltac Funeqtac :=
  match goal with
    | H : @Fun _ ?f _ = @Fun _ ?f _ |- _ => ded (fun_eq H); clear H
    | H : @Fun _ ?f _ = @Fun _ ?g _ |- _ =>
      ded (symb_eq H); try ((subst g || subst f); ded (fun_eq H); clear H)
  end.