Require Import String.
Require Import List.      (* sequence *)
Require Import Multiset.  (* bag *)
Require Import ListSet.   (* set *)
Require Import PeanoNat.
Require Import EqNat.
Require Import core.EqDec.
Require Import core.utils.Utils.
Require Import core.Metamodel.
Require Import core.modeling.ModelingMetamodel.
Require Import core.Model.

Require Import Coq.Logic.Eqdep_dec.

(* Base types *)

Inductive
  Table : Set :=
  BuildTable :
    nat ->
    string -> Table.

Inductive
  Column : Set :=
  BuildColumn :
    nat ->
    string -> Column.

Inductive
  TableColumns : Set :=
  BuildTableColumns :  Table -> list Column -> TableColumns.

Inductive
  ColumnReference : Set :=
  BuildColumnReference : Column -> Table -> ColumnReference.

Definition maybeBuildColumnReference (c: Column) (t: option Table) : option ColumnReference :=
  match c, t with
  | c', Some t' => Some (BuildColumnReference c' t')
  | _, _ => None
  end.

Definition maybeBuildTableColumns (t: Table) (c: option (list Column)) : option TableColumns :=
  match t, c with
  | t', Some c' => Some (BuildTableColumns t' c')
  | _, _ => None
  end.

(* Accessors *)

Definition getTableId (t : Table) : nat :=
  match t with BuildTable id _ => id end.

Definition getTableName (t : Table) : string :=
  match t with BuildTable _ n => n end.

Definition getColumnId (c : Column) : nat :=
  match c with BuildColumn id _ => id end.

Definition getColumnName (c : Column) : string :=
  match c with BuildColumn _ n => n end.

Definition beq_Table (t1 : Table) (t2: Table) : bool :=
  beq_nat (getTableId t1) (getTableId t2) && beq_string (getTableName t1) (getTableName t2).

Definition beq_Column (c1 : Column) (c2 : Column) : bool :=
  beq_nat (getColumnId c1) (getColumnId c2) && beq_string (getColumnName c1) (getColumnName c2).

Lemma lem_beq_Table_id:
 forall (a1 a2: Table),
   beq_Table a1 a2 = true -> a1 = a2.
Proof.
intros.
unfold beq_Table in H.
unfold "&&" in H.
destruct (getTableId a1 =? getTableId a2) eqn: ca1.
- apply (lem_beq_string_eq2) in H.
  apply (beq_nat_true) in ca1.
  destruct a1,a2.
  simpl in ca1, H.
  rewrite ca1,H.
  auto.
- congruence.
Qed.

Lemma lem_beq_Table_refl:
 forall (a: Table),
   beq_Table a a = true.
Proof.
intros.
destruct a.
unfold beq_Table.
simpl.
assert (true = PeanoNat.Nat.eqb n n). { apply beq_nat_refl. }
rewrite <- H.
assert (beq_string s s = true). { apply lem_beq_string_id. }
rewrite H0.
simpl.
auto.
Qed.

Lemma lem_beq_Column_refl :
 forall (c: Column),
   beq_Column c c = true.
Proof.
intros.
destruct c.
unfold beq_Column.
simpl.
assert (beq_nat n n = true). {symmetry. apply beq_nat_refl. }
assert (beq_string s s = true). {apply lem_beq_string_id. }
rewrite H,H0.
simpl.
auto.
Qed.

Lemma lem_beq_Column_id:
 forall (a1 a2: Column),
   beq_Column a1 a2 = true -> a1 = a2.
Proof.
intros.
unfold beq_Column in H.
unfold "&&" in H.
destruct (getColumnId a1 =? getColumnId a2) eqn: ca1.
- apply (lem_beq_string_eq2) in H.
  apply (beq_nat_true) in ca1.
  destruct a1,a2.
  simpl in ca1, H.
  rewrite ca1,H.
  auto.
- congruence.
Qed.

(* Meta-types *)

Inductive RelationalMetamodel_Class : Set :=
  TableClass | ColumnClass.

Definition RelationalMetamodel_getTypeByClass (type : RelationalMetamodel_Class) : Set :=
  match type with
  | TableClass => Table
  | ColumnClass => Column
  end.

Inductive RelationalMetamodel_Reference : Set :=
  TableColumnsReference | ColumnReferenceReference.

Definition RelationalMetamodel_getTypeByReference (type : RelationalMetamodel_Reference) : Set :=
  match type with
  | TableColumnsReference => TableColumns
  | ColumnReferenceReference => ColumnReference
  end.

(* Generic types *)

Inductive RelationalMetamodel_Object : Set :=
| RelationalMetamodel_BuildObject : forall (c:RelationalMetamodel_Class), (RelationalMetamodel_getTypeByClass c) -> RelationalMetamodel_Object.

Definition beq_RelationalMetamodel_Object (c1 : RelationalMetamodel_Object) (c2 : RelationalMetamodel_Object) : bool :=
  match c1, c2 with
  | RelationalMetamodel_BuildObject TableClass o1, RelationalMetamodel_BuildObject TableClass o2 => beq_Table o1 o2
  | RelationalMetamodel_BuildObject ColumnClass o1, RelationalMetamodel_BuildObject ColumnClass o2 => beq_Column o1 o2
  | _, _ => false
  end.

Inductive RelationalMetamodel_Link : Set :=
| RelationalMetamodel_BuildLink : forall (c:RelationalMetamodel_Reference), (RelationalMetamodel_getTypeByReference c) -> RelationalMetamodel_Link.

(* Reflective functions *)

Lemma RelationalMetamodel_eqClass_dec : forall (c1:RelationalMetamodel_Class) (c2:RelationalMetamodel_Class), { c1 = c2 } + { c1 <> c2 }.
Proof. repeat decide equality. Defined.

Lemma RelationalMetamodel_eqReference_dec : forall (c1:RelationalMetamodel_Reference) (c2:RelationalMetamodel_Reference), { c1 = c2 } + { c1 <> c2 }.
Proof. repeat decide equality. Defined.

Definition RelationalMetamodel_getClass (c : RelationalMetamodel_Object) : RelationalMetamodel_Class :=
  match c with
  | (RelationalMetamodel_BuildObject t _) => t
  end.

Definition RelationalMetamodel_getReference (c : RelationalMetamodel_Link) : RelationalMetamodel_Reference :=
  match c with
  | (RelationalMetamodel_BuildLink t _) => t
  end.

Definition RelationalMetamodel_instanceOfClass (cmc: RelationalMetamodel_Class) (c : RelationalMetamodel_Object): bool :=
  if RelationalMetamodel_eqClass_dec (RelationalMetamodel_getClass c) cmc then true else false.

Definition RelationalMetamodel_instanceOfReference (cmr: RelationalMetamodel_Reference) (c : RelationalMetamodel_Link): bool :=
  if RelationalMetamodel_eqReference_dec (RelationalMetamodel_getReference c) cmr then true else false.

Definition RelationalMetamodel_ClassAttributeTypes (c: RelationalMetamodel_Class): Set :=
  match c with
  | TableClass => (nat * string)
  | ColumnClass => (nat * string)
  end.

Definition BuildRelationalMetamodel_ClassElement (t : RelationalMetamodel_Class) : (RelationalMetamodel_ClassAttributeTypes t) -> RelationalMetamodel_Object :=
  match t with
  | TableClass => (fun (p: nat * string) => (RelationalMetamodel_BuildObject TableClass (BuildTable (fst p) (snd p))))
  | ColumnClass => (fun (p: nat * string) => (RelationalMetamodel_BuildObject ColumnClass (BuildColumn (fst p) (snd p))))
  end.

Definition RelationalMetamodel_ReferenceRoleTypes (c: RelationalMetamodel_Reference): Set :=
  match c with
  | TableColumnsReference => (Table * list Column)
  | ColumnReferenceReference => (Column * Table)
  end.

Definition BuildRelationalMetamodel_ReferenceLink (t : RelationalMetamodel_Reference) : (RelationalMetamodel_ReferenceRoleTypes t) -> RelationalMetamodel_Link :=
  match t with
  | TableColumnsReference => (fun (p: Table * list Column) => (RelationalMetamodel_BuildLink TableColumnsReference (BuildTableColumns (fst p) (snd p))))
  | ColumnReferenceReference => (fun (p: Column * Table) => (RelationalMetamodel_BuildLink ColumnReferenceReference (BuildColumnReference (fst p) (snd p))))
  end.

Definition toRelationalMetamodel_Class (t : RelationalMetamodel_Class) (c : RelationalMetamodel_Object) : option (RelationalMetamodel_getTypeByClass t) :=
  match c with
| RelationalMetamodel_BuildObject c0 d =>
    let s := RelationalMetamodel_eqClass_dec c0 t in
    match s with
    | left e => match e with
                     eq_refl => Some d
               end
    | right _ => None
    end
  end.

(*Proof.
  destruct c.
  destruct (RelationalMetamodel_eqClass_dec t r).
  - rewrite <- e in d.
    exact (Some d).
  - exact None.
Defined.*)

Theorem toRelationalMetamodel_Class_inv :
  forall (t : RelationalMetamodel_Class) (c : RelationalMetamodel_Object) (c': RelationalMetamodel_getTypeByClass t),
    toRelationalMetamodel_Class t c = Some c' ->
    c = (RelationalMetamodel_BuildObject t c').
Proof.
  intros.
  destruct c.
  simpl in H.
  destruct (RelationalMetamodel_eqClass_dec c t).
  - destruct e. inversion H. reflexivity.
  - inversion H.
Qed.

Definition toRelationalMetamodel_Reference (t : RelationalMetamodel_Reference) (c : RelationalMetamodel_Link) : option (RelationalMetamodel_getTypeByReference t).
Proof.
  destruct c.
  destruct (RelationalMetamodel_eqReference_dec t c).
  - rewrite <- e in r.
    exact (Some r).
  - exact None.
Defined.

(* Generic functions *)

Definition RelationalMetamodel_toObjectFromTable (t :Table) : RelationalMetamodel_Object :=
  (RelationalMetamodel_BuildObject TableClass t).

Definition RelationalMetamodel_toObjectFromColumn (c :Column) : RelationalMetamodel_Object :=
  (RelationalMetamodel_BuildObject ColumnClass c).

Definition RelationalMetamodel_toObject (t: RelationalMetamodel_Class) (e: RelationalMetamodel_getTypeByClass t) : RelationalMetamodel_Object:=
  (RelationalMetamodel_BuildObject t e).

Definition RelationalMetamodel_toLink (t: RelationalMetamodel_Reference) (e: RelationalMetamodel_getTypeByReference t) : RelationalMetamodel_Link :=
  (RelationalMetamodel_BuildLink t e).

Definition RelationalMetamodel_getId (r : RelationalMetamodel_Object) : nat :=
  match r with
  | (RelationalMetamodel_BuildObject TableClass c) => getTableId c
  | (RelationalMetamodel_BuildObject ColumnClass a) => getColumnId a
  end.

Definition RelationalMetamodel_getName (r : RelationalMetamodel_Object) : string :=
  match r with
  | (RelationalMetamodel_BuildObject TableClass c) => getTableName c
  | (RelationalMetamodel_BuildObject ColumnClass a) => getColumnName a
  end.

(*Definition allTables (m : RelationalModel) : list Table :=
  match m with BuildRelationalModel l _  => optionList2List (map (toRelationalMetamodel_Class TableClass) l) end.

Definition allColumns (m : RelationalModel) : list Column :=
  match m with BuildRelationalModel l _  => optionList2List (map (toRelationalMetamodel_Class ColumnClass) l) end.*)

Fixpoint getTableColumnsOnLinks (t : Table) (l : list RelationalMetamodel_Link) : option (list Column) :=
  match l with
  | (RelationalMetamodel_BuildLink TableColumnsReference (BuildTableColumns tab c)) :: l1 => if beq_Table tab t then Some c else getTableColumnsOnLinks t l1
  | _ :: l1 => getTableColumnsOnLinks t l1
  | nil => None
  end.

Definition getTableColumns (t : Table) (m : Model RelationalMetamodel_Object RelationalMetamodel_Link) : option (list Column) :=
getTableColumnsOnLinks t (allModelLinks m).

Fixpoint getColumnReferenceOnLinks (c : Column) (l : list RelationalMetamodel_Link) : option Table :=
  match l with
  | (RelationalMetamodel_BuildLink ColumnReferenceReference (BuildColumnReference col t)) :: l1 => if beq_Column col c then Some t else getColumnReferenceOnLinks c l1
  | _ :: l1 => getColumnReferenceOnLinks c l1
  | nil => None
  end.

Definition getColumnReference (c : Column) (m : Model RelationalMetamodel_Object RelationalMetamodel_Link) : option Table := getColumnReferenceOnLinks c (allModelLinks m).

Definition bottomRelationalMetamodel_Class (c: RelationalMetamodel_Class) : (RelationalMetamodel_getTypeByClass c) :=
  match c with
  | TableClass => (BuildTable 0 "")
  | ColumnClass => (BuildColumn 0 "")
  end.

Lemma rel_invert :
  forall (t: RelationalMetamodel_Class) (t1 t2: RelationalMetamodel_getTypeByClass t), RelationalMetamodel_BuildObject t t1 = RelationalMetamodel_BuildObject t t2 -> t1 = t2.
Proof.
intros.
inversion H.
apply inj_pair2_eq_dec in H1.
exact H1.
apply RelationalMetamodel_eqClass_dec.
Qed.

Lemma rel_elink_invert :
  forall (t: RelationalMetamodel_Reference) (t1 t2: RelationalMetamodel_getTypeByReference t), RelationalMetamodel_BuildLink t t1 = RelationalMetamodel_BuildLink t t2 -> t1 = t2.
Proof.
intros.
inversion H.
apply inj_pair2_eq_dec in H1.
exact H1.
apply RelationalMetamodel_eqReference_dec.
Qed.

  #[export]
  Instance RelationalElementSum : Sum RelationalMetamodel_Object RelationalMetamodel_Class :=
  {
    denoteSubType := RelationalMetamodel_getTypeByClass;
    toSubType := toRelationalMetamodel_Class;
    toSumType := RelationalMetamodel_toObject;
  }.

  (* TODO *)
  Definition beq_RelationalMetamodel_Link (c1 : RelationalMetamodel_Link) (c2 : RelationalMetamodel_Link) : bool := true.

  #[export]
  Instance RelationalMetamodel_EqDec : EqDec RelationalMetamodel_Object := {
    eq_b := beq_RelationalMetamodel_Object;
  }.

  #[export]
  Instance RelationalLinkSum : Sum RelationalMetamodel_Link RelationalMetamodel_Reference :=
  {
    denoteSubType := RelationalMetamodel_getTypeByReference;
    toSubType := toRelationalMetamodel_Reference;
    toSumType := RelationalMetamodel_toLink;
  }.

  #[export]
  Instance RelationalM : Metamodel :=
  {
    ModelElement := RelationalMetamodel_Object;
    ModelLink := RelationalMetamodel_Link;
  }.

  #[export]
  Instance RelationalMetamodel : ModelingMetamodel RelationalM :=
  {
      elements := RelationalElementSum;
      links := RelationalLinkSum;
  }.

Definition RelationalModel := Model RelationalMetamodel_Object RelationalMetamodel_Link.


(** * Equivalence induction *)
Require Import Basics.Overture Basics.Equivalences Basics.Tactics.
Require Import Types.Equiv Types.Prod Types.Forall Types.Sigma Types.Universe.

(** We define typeclasses and tactics for doing equivalence induction. *)

Local Open Scope equiv_scope.

Class RespectsEquivalenceL@{i j k s0 s1} (A : Type@{i}) (P : forall (B : Type@{j}), (A <~> B) -> Type@{k})
  := respects_equivalenceL : sig@{s0 s1} (fun e' : forall B (e : A <~> B), P A (equiv_idmap A) <~> P B e => Funext -> equiv_idmap _ = e' A (equiv_idmap _) ).
Class RespectsEquivalenceR@{i j k s0 s1} (A : Type@{i}) (P : forall (B : Type@{j}), (B <~> A) -> Type@{k})
  := respects_equivalenceR : sig@{s0 s1} (fun e' : forall B (e : B <~> A), P A (equiv_idmap A) <~> P B e => Funext -> equiv_idmap _ = e' A (equiv_idmap _) ).
(** We use a sigma type rather than a record for two reasons:

    1. In the dependent cases, where one equivalence-respectfulness proof will show up in the body of another goal, it might be the case that using sigma types allows us to reuse the respectfulness lemmas of sigma types, rather than writing new ones for this type.

    2. We expect it to be significantly useful to see the type of the fields than the type of the record, because we expect this type to show up as a goal infrequently.  Sigma types have more informative notations than record type names; the user can run hnf to see what is left to do in the side conditions. *)

Global Arguments RespectsEquivalenceL : clear implicits.
Global Arguments RespectsEquivalenceR : clear implicits.

(** When doing equivalence induction, typeclass inference will either fully solve the respectfulness side-conditions, or not make any progress.  We would like to progress as far as we can on the side-conditions, so that we leave the user with as little to prove as possible.  To do this, we create a "database", implemented using typeclasses, to look up the refinement lemma, keyed on the head of the term we want to respect equivalence. *)
Class respects_equivalence_db {KT VT} (Key : KT) {lem : VT} := make_respects_equivalence_db : Unit.
Definition get_lem' {KT VT} Key {lem} `{@respects_equivalence_db KT VT Key lem} : VT := lem.
Notation get_lem key := ltac:(let res := constr:(get_lem' key) in let res' := (eval unfold get_lem' in res) in exact res') (only parsing).

Section const.
  Context {A : Type} {T : Type}.
  Global Instance const_respects_equivalenceL
  : RespectsEquivalenceL A (fun _ _ => T).
  Proof.
    refine (fun _ _ => equiv_idmap T; fun _ => _).
    exact idpath.
  Defined.
  Global Instance const_respects_equivalenceR
  : RespectsEquivalenceR A (fun _ _ => T).
  Proof.
    refine (fun _ _ => equiv_idmap _; fun _ => _).
    exact idpath.
  Defined.
End const.

Global Instance: forall {T}, @respects_equivalence_db _ _ T (fun A => @const_respects_equivalenceL A T) := fun _ => tt.

Section id.
  Context {A : Type}.
  Global Instance idmap_respects_equivalenceL
  : RespectsEquivalenceL A (fun B _ => B).
  Proof.
    refine (fun B e => e; fun _ => _).
    exact idpath.
  Defined.
  Global Instance idmap_respects_equivalenceR
  : RespectsEquivalenceR A (fun B _ => B).
  Proof.
    refine (fun B e => equiv_inverse e; fun _ => path_equiv _).
    apply path_forall; intro; reflexivity.
  Defined.
End id.

Section unit.
  Context {A : Type}.
  Definition unit_respects_equivalenceL
  : RespectsEquivalenceL A (fun _ _ => Unit)
    := @const_respects_equivalenceL A Unit.
  Definition unit_respects_equivalenceR
  : RespectsEquivalenceR A (fun _ _ => Unit)
    := @const_respects_equivalenceR A Unit.
End unit.

Section prod.
  Global Instance prod_respects_equivalenceL {A} {P Q : forall B, (A <~> B) -> Type}
         `{RespectsEquivalenceL A P, RespectsEquivalenceL A Q}
  : RespectsEquivalenceL A (fun B e => P B e * Q B e).
  Proof.
    refine ((fun B e => equiv_functor_prod' (respects_equivalenceL.1 B e) (respects_equivalenceL.1 B e)); _).
    exact (fun fs =>
             transport
               (fun e' => _ = equiv_functor_prod' e' _) (respects_equivalenceL.2 _)
               (transport
                  (fun e' => _ = equiv_functor_prod' _ e') (respects_equivalenceL.2 _)
                  idpath)).
  Defined.

  Global Instance prod_respects_equivalenceR {A} {P Q : forall B, (B <~> A) -> Type}
         `{RespectsEquivalenceR A P, RespectsEquivalenceR A Q}
  : RespectsEquivalenceR A (fun B e => P B e * Q B e).
  Proof.
    refine ((fun B e => equiv_functor_prod' (respects_equivalenceR.1 B e) (respects_equivalenceR.1 B e)); _).
    exact (fun fs =>
             transport
               (fun e' => _ = equiv_functor_prod' e' _) (respects_equivalenceR.2 _)
               (transport
                  (fun e' => _ = equiv_functor_prod' _ e') (respects_equivalenceR.2 _)
                  idpath)).
  Defined.

  Global Instance: @respects_equivalence_db _ _ (@prod) (@prod_respects_equivalenceL) := tt.
End prod.

(** A tactic to solve the identity-preservation part of equivalence-respectfulness. *)
Local Ltac t_step :=
  idtac;
  match goal with
    | [ |- _ = _ :> (_ <~> _) ] => apply path_equiv
    | _ => reflexivity
    | _ => assumption
    | _ => intro
    | [ |- _ = _ :> (forall _, _) ] => apply path_forall
    | _ => progress unfold functor_forall, functor_sigma
    | _ => progress cbn in *
    | [ |- context[?x.1] ] => let H := fresh in destruct x as [? H]; try destruct H
    | [ H : _ = _ |- _ ] => destruct H
    | [ H : ?A -> ?B, H' : ?A |- _ ] => specialize (H H')
    | [ H : ?A -> ?B, H' : ?A |- _ ] => generalize dependent (H H'); clear H
    | _ => progress rewrite ?eisretr, ?eissect
  end.
Local Ltac t :=
  repeat t_step.

Section pi.
  Global Instance forall_respects_equivalenceL `{Funext} {A} {P : forall B, (A <~> B) -> Type} {Q : forall B e, P B e -> Type}
         `{HP : RespectsEquivalenceL A P}
         `{HQ : forall a : P A (equiv_idmap A), RespectsEquivalenceL A (fun B e => Q B e (respects_equivalenceL.1 B e a))}
  : RespectsEquivalenceL A (fun B e => forall x : P B e, Q B e x).
  Proof.
    simple refine (fun B e => _; _).
    { refine (equiv_functor_forall'
                (equiv_inverse ((@respects_equivalenceL _ _ HP).1 B e))
                (fun b => _)).
      refine (equiv_compose'
                (equiv_path _ _ (ap (Q B e) (eisretr _ _)))
                (equiv_compose'
                   ((HQ (equiv_inverse ((@respects_equivalenceL _ _ HP).1 B e) b)).1 B e)
                   (equiv_path _ _ (ap (Q A (equiv_idmap _)) _)))).
      refine (ap10 (ap equiv_fun (respects_equivalenceL.2 _)) _). }
    { t. }
  Defined.

  Global Instance forall_respects_equivalenceR `{Funext} {A} {P : forall B, (B <~> A) -> Type} {Q : forall B e, P B e -> Type}
         `{HP : RespectsEquivalenceR A P}
         `{HQ : forall a : P A (equiv_idmap A), RespectsEquivalenceR A (fun B e => Q B e (respects_equivalenceR.1 B e a))}
  : RespectsEquivalenceR A (fun B e => forall x : P B e, Q B e x).
  Proof.
    simple refine (fun B e => _; _).
    { refine (equiv_functor_forall'
                (equiv_inverse ((@respects_equivalenceR _ _ HP).1 B e))
                (fun b => _)).
      refine (equiv_compose'
                (equiv_path _ _ (ap (Q B e) (eisretr _ _)))
                (equiv_compose'
                   ((HQ (equiv_inverse ((@respects_equivalenceR _ _ HP).1 B e) b)).1 B e)
                   (equiv_path _ _ (ap (Q A (equiv_idmap _)) _)))).
      refine (ap10 (ap equiv_fun (respects_equivalenceR.2 _)) _). }
    { t. }
  Defined.
End pi.

Section sigma.
  Global Instance sigma_respects_equivalenceL `{Funext} {A} {P : forall B, (A <~> B) -> Type} {Q : forall B e, P B e -> Type}
         `{HP : RespectsEquivalenceL A P}
         `{HQ : forall a : P A (equiv_idmap A), RespectsEquivalenceL A (fun B e => Q B e (respects_equivalenceL.1 B e a))}
  : RespectsEquivalenceL A (fun B e => sig (Q B e)).
  Proof.
    simple refine ((fun B e => equiv_functor_sigma' (respects_equivalenceL.1 B e) (fun b => _));
            _).
    { refine (equiv_compose'
                ((HQ b).1 B e)
                (equiv_path _ _ (ap (Q A (equiv_idmap _)) _))).
      refine (ap10 (ap equiv_fun (respects_equivalenceL.2 _)) _). }
    { t. }
  Defined.

  Global Instance sigma_respects_equivalenceR `{Funext} {A} {P : forall B, (B <~> A) -> Type} {Q : forall B e, P B e -> Type}
         `{HP : RespectsEquivalenceR A P}
         `{HQ : forall a : P A (equiv_idmap A), RespectsEquivalenceR A (fun B e => Q B e (respects_equivalenceR.1 B e a))}
  : RespectsEquivalenceR A (fun B e => sig (Q B e)).
  Proof.
    simple refine ((fun B e => equiv_functor_sigma' (respects_equivalenceR.1 B e) (fun b => _));
            _).
    { refine (equiv_compose'
                ((HQ b).1 B e)
                (equiv_path _ _ (ap (Q A (equiv_idmap _)) _))).
      refine (ap10 (ap equiv_fun (respects_equivalenceR.2 _)) _). }
    { t. }
  Defined.

  Global Instance: @respects_equivalence_db _ _ (@sig) (@sigma_respects_equivalenceL) := tt.
End sigma.

Section equiv_transfer.
  Definition respects_equivalenceL_equiv {A A'} {P : forall B, (A <~> B) -> Type} {P' : forall B, A' <~> B -> Type}
             (eA : A <~> A')
             (eP : forall B e, P B (equiv_compose' e eA) <~> P' B e)
             `{HP : RespectsEquivalenceL A P}
  : RespectsEquivalenceL A' P'.
  Proof.
    simple refine ((fun B e => _); _).
    { refine (equiv_compose'
                (eP _ _)
                (equiv_compose'
                   (equiv_compose'
                      (HP.1 _ _)
                      (equiv_inverse (HP.1 _ _)))
                   (equiv_inverse (eP _ _)))). }
    { t. }
  Defined.

  Definition respects_equivalenceR_equiv {A A'} {P : forall B, (B <~> A) -> Type} {P' : forall B, B <~> A' -> Type}
             (eA : A' <~> A)
             (eP : forall B e, P B (equiv_compose' eA e) <~> P' B e)
             `{HP : RespectsEquivalenceR A P}
  : RespectsEquivalenceR A' P'.
  Proof.
    simple refine ((fun B e => _); _).
    { refine (equiv_compose'
                (eP _ _)
                (equiv_compose'
                   (equiv_compose'
                      (HP.1 _ _)
                      (equiv_inverse (HP.1 _ _)))
                   (equiv_inverse (eP _ _)))). }
    { t. }
  Defined.

  Definition respects_equivalenceL_equiv' {A} {P P' : forall B, (A <~> B) -> Type}
             (eP : forall B e, P B e <~> P' B e)
             `{HP : RespectsEquivalenceL A P}
  : RespectsEquivalenceL A P'.
  Proof.
    simple refine ((fun B e => _); _).
    { refine (equiv_compose'
                (eP _ _)
                (equiv_compose'
                   (equiv_compose'
                      (HP.1 _ _)
                      (equiv_inverse (HP.1 _ _)))
                   (equiv_inverse (eP _ _)))). }
    { t. }
  Defined.

  Definition respects_equivalenceR_equiv' {A} {P P' : forall B, (B <~> A) -> Type}
             (eP : forall B e, P B e <~> P' B e)
             `{HP : RespectsEquivalenceR A P}
  : RespectsEquivalenceR A P'.
  Proof.
    simple refine ((fun B e => _); _).
    { refine (equiv_compose'
                (eP _ _)
                (equiv_compose'
                   (equiv_compose'
                      (HP.1 _ _)
                      (equiv_inverse (HP.1 _ _)))
                   (equiv_inverse (eP _ _)))). }
    { t. }
  Defined.
End equiv_transfer.

Section equiv.
  Global Instance equiv_respects_equivalenceL `{Funext} {A} {P Q : forall B, (A <~> B) -> Type}
         `{HP : RespectsEquivalenceL A P}
         `{HQ : RespectsEquivalenceL A Q}
  : RespectsEquivalenceL A (fun B e => P B e <~> Q B e).
  Proof.
    simple refine (fun B e => _; fun _ => _).
    { refine (equiv_functor_equiv _ _);
      apply respects_equivalenceL.1. }
    { t. }
  Defined.

  Global Instance equiv_respects_equivalenceR `{Funext} {A} {P Q : forall B, (B <~> A) -> Type}
         `{HP : RespectsEquivalenceR A P}
         `{HQ : RespectsEquivalenceR A Q}
  : RespectsEquivalenceR A (fun B e => P B e <~> Q B e).
  Proof.
    simple refine (fun B e => _; fun _ => _).
    { refine (equiv_functor_equiv _ _);
      apply respects_equivalenceR.1. }
    { t. }
  Defined.

  Global Instance: @respects_equivalence_db _ _ (@Equiv) (@equiv_respects_equivalenceL) := tt.
End equiv.

Section ap.
  Global Instance equiv_ap_respects_equivalenceL {A} {P Q : forall B, (A <~> B) -> A}
         `{HP : RespectsEquivalenceL A (fun B (e : A <~> B) => P B e = Q B e)}
  : RespectsEquivalenceL A (fun (B : Type) (e : A <~> B) => e (P B e) = e (Q B e)).
  Proof.
    simple refine (fun B e => _; fun _ => _).
    { refine (equiv_ap' _ _ _ oE _); simpl.
      refine (respects_equivalenceL.1 B e). }
    { t. }
  Defined.

  Global Instance equiv_ap_inv_respects_equivalenceL {A} {P Q : forall B, (A <~> B) -> B}
         `{HP : RespectsEquivalenceL A (fun B (e : A <~> B) => P B e = Q B e)}
  : RespectsEquivalenceL A (fun (B : Type) (e : A <~> B) => e^-1 (P B e) = e^-1 (Q B e)).
  Proof.
    simple refine (fun B e => _; fun _ => _).
    { refine (equiv_ap' _ _ _ oE _); simpl.
      refine (respects_equivalenceL.1 B e). }
    { t. }
  Defined.

  Global Instance equiv_ap_respects_equivalenceR {A} {P Q : forall B, (B <~> A) -> B}
         `{HP : RespectsEquivalenceR A (fun B (e : B <~> A) => P B e = Q B e)}
  : RespectsEquivalenceR A (fun (B : Type) (e : B <~> A) => e (P B e) = e (Q B e)).
  Proof.
    simple refine (fun B e => _; fun _ => _).
    { refine (equiv_ap' _ _ _ oE _); simpl.
      refine (respects_equivalenceR.1 B e). }
    { t. }
  Defined.

  Global Instance equiv_ap_inv_respects_equivalenceR {A} {P Q : forall B, (B <~> A) -> A}
         `{HP : RespectsEquivalenceR A (fun B (e : B <~> A) => P B e = Q B e)}
  : RespectsEquivalenceR A (fun (B : Type) (e : B <~> A) => e^-1 (P B e) = e^-1 (Q B e)).
  Proof.
    simple refine (fun B e => _; fun _ => _).
    { refine (equiv_ap' _ _ _ oE _); simpl.
      refine (respects_equivalenceR.1 B e). }
    { t. }
  Defined.
End ap.

(** We now write the tactic that partially solves the respectfulness side-condition.  We include cases for generic typeclass resolution, keys (heads) with zero, one, two, and three arguments, and a few cases that cannot be easily keyed (where the head is one of the arguments, or [forall]), or the head is [paths], for which we have only ad-hoc solutions at the moment. *)
Ltac step_respects_equiv :=
  idtac;
  match goal with
    | _ => progress intros
    | _ => assumption
    | _ => progress unfold respects_equivalenceL
    | _ => progress cbn
    | _ => exact _ (* case for fully solving the side-condition, when possible *)
    | [ |- RespectsEquivalenceL _ (fun _ _ => ?T) ] => rapply (get_lem T)
    | [ |- RespectsEquivalenceL _ (fun _ _ => ?T _) ] => rapply (get_lem T)
    | [ |- RespectsEquivalenceL _ (fun _ _ => ?T _ _) ] => rapply (get_lem T)
    | [ |- RespectsEquivalenceL _ (fun _ _ => ?T _ _ _) ] => rapply (get_lem T)
    | [ |- RespectsEquivalenceL _ (fun B e => equiv_fun e _ = equiv_fun e _) ] => refine equiv_ap_respects_equivalenceL
    | [ |- RespectsEquivalenceL _ (fun B e => equiv_inv e _ = equiv_inv e _) ] => refine equiv_ap_inv_respects_equivalenceL
    | [ |- RespectsEquivalenceL _ (fun B _ => B) ] => refine idmap_respects_equivalenceL
    | [ |- RespectsEquivalenceL _ (fun _ _ => forall _, _) ] => refine forall_respects_equivalenceL
  end.

Ltac equiv_induction p :=
  generalize dependent p;
  let p' := fresh in
  intro p';
    let y := match type of p' with ?x <~> ?y => constr:(y) end in
    move p' at top;
      generalize dependent y;
      let P := match goal with |- forall y p, @?P y p => constr:(P) end in
      (* We use [(fun x => x) _] to block automatic typeclass resolution in the hole for the equivalence respectful proof. *)
      refine ((fun g H B e => (@respects_equivalenceL _ P H).1 B e g) _ (_ : (fun x => x) _));
        [ intros | repeat step_respects_equiv ].

Goal forall `{Funext} A B (e : A <~> B), A -> { y : B & forall Q, Contr Q -> ((e^-1 y = e^-1 y) <~> (y = y)) * Q }.
  intros ? ? ? ? a.
  equiv_induction e.
  - simpl.
    exists a.
    intros Q q.
    exact (1, center _).
Abort.


(* 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                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************)
(*           The Calculus of Inductive Constructions            *)
(*                       COQ v5.10                              *)
(*                                                              *)
(* Laurent Arditi.  Laboratoire I3S. CNRS ura 1376.             *)
(* Universite de Nice - Sophia Antipolis                        *)
(* arditi@unice.fr, http://wwwi3s.unice.fr/~arditi/lolo.html    *)
(*                                                              *)
(* date: may 1995                                               *)
(* file: Lists_field.v                                          *)
(* contents: trunc, strip, sublist and elemlist for polymorphic *)
(* lists.                                                       *)
(****************************************************************)

Require Import Arith_compl.
Require Export Minus.
Require Export Lists_compl.

Section Lists_field.
Variable A : Set.

Fixpoint trunc (v : list A) : nat -> list A :=
  fun n : nat =>
  match v return (list A) with
  | nil => nil
  | b :: w =>
      match n return (list A) with
      | O => nil
      | S p => b :: trunc w p
      end
  end.

Definition strip (v : list A) (n : nat) :=
  rev A (trunc (rev A v) (length v - n)).

(* Selection d'une sous liste commencant a la position start, de
   longueur lengt *)
Definition sublist (v : list A) (start lengt : nat) :=
  trunc (strip v start) lengt.

(* Selection de la liste contenant le i-eme element d'une liste *)
Definition elemlist (v : list A) (i : nat) := trunc (strip v i) 1.

(****************************************************************)
(* lemmes sur trunc *)

Lemma length_trunc :
 forall (v : list A) (i : nat),
 (*****************)
 i <= length v -> length (trunc v i) = i.
simple induction v. simpl in |- *. auto with arith.
intros b b0 H. simple induction i. simpl in |- *. trivial with arith.
simpl in |- *. intros. apply eq_S. apply H. apply le_S_n. exact H1.
Qed.

Lemma trunc_inv :
 forall (v : list A) (i : nat) (b : A),
 (**************)
 b :: trunc v i = trunc (b :: v) (S i).
simpl in |- *. trivial with arith.
Qed.

Lemma trunc_all : forall v : list A, trunc v (length v) = v.
(**************)
simple induction v. simpl in |- *. trivial with arith.
intros. rewrite length_eq2. simpl in |- *. rewrite H. trivial with arith.
Qed. Hint Resolve trunc_all.

Lemma trunc_max :
 forall (v : list A) (i : nat),
 (**************)
 length v <= i -> trunc v i = v.
simple induction v. simpl in |- *. trivial with arith.
intros. inversion H0. rewrite trunc_all. trivial with arith.
simpl in |- *. rewrite H. trivial with arith.
apply le_Sn_le. generalize H1. simpl in |- *. trivial with arith.
Qed.

Lemma trunc_O : forall v : list A, trunc v 0 = nil.
(************)
simple induction v; auto with arith.
Qed. Hint Resolve trunc_O.

Lemma le_length_trunc :
 forall (v : list A) (i : nat), length (trunc v i) <= i.
(********************)
simple induction v. simpl in |- *. auto with arith.
intros. case i. rewrite trunc_O. auto with arith.
intro. simpl in |- *. apply le_n_S. apply H.
Qed. Hint Resolve le_length_trunc.

Lemma trunc_app :
 forall (v1 v2 : list A) (i : nat),
 (**************)
 trunc (v1 ++ v2) i = trunc v1 i ++ trunc v2 (i - length v1).
simple induction v1. simpl in |- *. auto with arith.
intros. rewrite app_eq2.
rewrite length_eq2. elim i. simpl in |- *. rewrite trunc_O. trivial with arith.
intros. simpl in |- *. rewrite H. trivial with arith.
Qed. Hint Resolve trunc_app.

Lemma app_v_trunc :
 forall (v1 v2 : list A) (i : nat),
 (****************)
 v1 ++ trunc v2 i = trunc (v1 ++ v2) (length v1 + i).
intros. rewrite trunc_app. rewrite (trunc_max v1 (length v1 + i)).
replace (length v1 + i - length v1) with i. trivial with arith. auto with arith.
auto with arith.
Qed.

Lemma trunc_eq :
 forall (v1 v2 : list A) (i : nat), v1 = v2 -> trunc v1 i = trunc v2 i.
(*************)
intros. rewrite H. trivial with arith.
Qed. Hint Resolve trunc_eq.

Lemma trunc_sym :
 forall (v : list A) (i j : nat),
 (**************)
 trunc (trunc v i) j = trunc (trunc v j) i.
simple induction v. simpl in |- *. trivial with arith.
simple induction i; simple induction j. trivial with arith.
repeat rewrite trunc_O. simpl in |- *. trivial with arith.
repeat rewrite trunc_O. simpl in |- *. trivial with arith.
intros. simpl in |- *. rewrite H. trivial with arith.
Qed.

Lemma trunc_trunc1 :
 forall (v : list A) (i : nat),
 (*****************)
 trunc (trunc v i) i = trunc v i.
simple induction v. simpl in |- *. trivial with arith.
simple induction i. repeat rewrite trunc_O. trivial with arith.
intros. simpl in |- *. rewrite H. trivial with arith.
Qed. Hint Resolve trunc_trunc1.

Lemma trunc_trunc2 :
 forall (v : list A) (i j : nat),
 (*****************)
 i <= j -> trunc (trunc v i) j = trunc v i.
intros. rewrite (trunc_max (trunc v i) j). trivial with arith.
apply le_trans with i. apply le_length_trunc. exact H.
Qed.

Lemma trunc_trunc3 :
 forall (v : list A) (i j : nat),
 (*****************)
 j <= i -> trunc (trunc v i) j = trunc v j.
intros. rewrite <- (trunc_max (trunc v j) i). rewrite trunc_sym. trivial with arith.
apply le_trans with j. apply le_length_trunc.
exact H.
Qed.

Lemma trunc_plus_petit :
 forall (v1 v2 : list A) (i j : nat),
 (*********************)
 j <= i -> trunc v1 i = v2 -> trunc v1 j = trunc v2 j.
intros. rewrite <- H0. rewrite trunc_trunc3. trivial with arith. exact H.
Qed.

(****************************************************************)
(* lemmes sur strip *)

Lemma strip_nil : forall i : nat, strip nil i = nil.
(**************)
intro. auto with arith.
Qed. Hint Resolve strip_nil.

Lemma strip_cons_S :
 forall (v : list A) (i : nat) (b : A),
 (*****************)
 strip (b :: v) (S i) = strip v i.
unfold strip in |- *. simple induction i. simpl in |- *.
elim minus_n_O. intro. replace (length v) with (length (rev A v)).
rewrite trunc_all. rewrite trunc_app. rewrite trunc_all.
elim minus_n_n. rewrite trunc_O. rewrite app_v_nil. trivial with arith.
apply length_rev.
intros. apply rev_eq. simpl in |- *.
rewrite trunc_app. rewrite length_rev. rewrite minus_minus_lem1.
rewrite trunc_O. rewrite app_v_nil. trivial with arith.
Qed. Hint Resolve strip_cons_S.

Lemma length_strip :
 forall (v : list A) (i : nat),
 (*****************)
 i <= length v -> length (strip v i) = length v - i.
unfold strip in |- *. intros. rewrite length_rev. rewrite length_trunc. trivial with arith.
rewrite length_rev. apply minus_le_lem2.
Qed.

Lemma le_length_strip :
 forall (v : list A) (i : nat),
 (********************)
 length (strip v i) <= length v - i.
unfold strip in |- *. intros. rewrite length_rev. apply le_length_trunc.
Qed.

Lemma strip_inv :
 forall (v : list A) (i : nat),
 (***************)
 rev A (trunc (rev A v) (length v - i)) = strip v i.
unfold strip in |- *. trivial with arith.
Qed.

Lemma strip_all : forall v : list A, strip v (length v) = nil.
(**************)
unfold strip in |- *. intro. rewrite <- minus_n_n. rewrite trunc_O. auto with arith.
Qed. Hint Resolve strip_all.

Lemma strip_max :
 forall (v : list A) (i : nat),
 (**************)
 length v <= i -> strip v i = nil.
unfold strip in |- *. intros. rewrite <- rev_eq1.
apply rev_eq. rewrite <- length_rev. rewrite minus_le_O. auto with arith.
rewrite length_rev. exact H.
Qed.

Lemma strip_O : forall v : list A, strip v 0 = v.
(************)
intro. unfold strip in |- *. rewrite <- minus_n_O. rewrite <- length_rev.
rewrite trunc_all. rewrite rev_rev. trivial with arith.
Qed. Hint Resolve strip_O.

Lemma strip_app :
 forall (v1 v2 : list A) (i : nat),
 (**************)
 strip (v1 ++ v2) i = strip v1 i ++ strip v2 (i - length v1).
simple induction v1. simpl in |- *. intros. elim minus_n_O. trivial with arith.
simple induction v2. intro. simpl in |- *.
rewrite strip_nil. rewrite app_v_nil. rewrite app_v_nil. trivial with arith.
simple induction i.
rewrite strip_O. simpl in |- *. rewrite strip_O. rewrite strip_O. auto with arith.
intros. rewrite app_eq2. rewrite strip_cons_S.
rewrite strip_cons_S. rewrite length_eq2. simpl in |- *. apply H.
Qed.

Lemma strip_strip_S :
 forall (v : list A) (i j : nat),
 (******************)
 strip (strip v (S i)) j = strip (strip v i) (S j).
simple induction v. intros. rewrite strip_nil. rewrite strip_nil. trivial with arith.
simple induction i. intros. rewrite strip_O.
do 2 rewrite strip_cons_S. rewrite strip_O. trivial with arith.
simple induction j. rewrite strip_O.
repeat rewrite strip_cons_S. elim n. rewrite strip_O. trivial with arith.
intros. rewrite <- H. rewrite strip_O. trivial with arith.
intros. do 2 rewrite strip_cons_S. apply H.
Qed.

Lemma strip_sym :
 forall (v : list A) (i j : nat),
 (**************)
 strip (strip v i) j = strip (strip v j) i.
simple induction v. intros. rewrite strip_nil. rewrite strip_nil. trivial with arith.
simple induction i. intro. rewrite strip_O. rewrite strip_O. trivial with arith.
simple induction j. rewrite strip_O. rewrite strip_O. try trivial with arith.
intros. rewrite strip_cons_S. rewrite strip_cons_S.
replace (strip (strip l n) (S n0)) with (strip (strip l (S n)) n0).
apply H. apply strip_strip_S.
Qed.

Lemma strip_eq :
 forall (v1 v2 : list A) (i : nat), v1 = v2 -> strip v1 i = strip v2 i.
(*************)
intros. rewrite H. trivial with arith.
Qed. Hint Resolve strip_eq.

Lemma strip_strip :
 forall (v : list A) (i j : nat),
 (****************)
 strip (strip v i) j = strip v (i + j).
simple induction v. intros. rewrite strip_nil. rewrite strip_nil. trivial with arith.
simple induction i. intro. simpl in |- *. rewrite strip_O. trivial with arith.
simple induction j. rewrite strip_O. elim plus_n_O. trivial with arith.
intros. rewrite strip_cons_S. simpl in |- *. rewrite strip_cons_S. apply H.
Qed. Hint Resolve strip_strip.

(****************************************************************)
(* lemmes sur trunc et strip ensembles *)

Lemma app_trunc_strip :
 forall (v : list A) (i : nat),
 (********************)
 trunc v i ++ strip v i = v.
simple induction v. unfold strip in |- *. simpl in |- *. trivial with arith.
intros. elim i. rewrite trunc_O. rewrite strip_O. simpl in |- *. trivial with arith.
intros. unfold strip in |- *. simpl in |- *.
rewrite trunc_app. rewrite rev_app. rewrite length_rev.
case n. rewrite <- minus_n_O.
rewrite <- minus_n_n. rewrite trunc_O. rewrite trunc_O. simpl in |- *.
rewrite <- length_rev. rewrite trunc_all. rewrite rev_rev. trivial with arith.
intro. replace (length l - S n0 - length l) with 0.
rewrite trunc_O. simpl in |- *.
replace (rev A (trunc (rev A l) (length l - S n0))) with (strip l (S n0)).
rewrite H. trivial with arith.
unfold strip in |- *. trivial with arith.
rewrite minus_minus_lem1. trivial with arith.
Qed.

Lemma strip_trunc_i :
 forall (v : list A) (i : nat), strip (trunc v i) i = nil.
(******************)
simple induction v. auto with arith.
simple induction i. auto with arith.
intros. simpl in |- *. rewrite strip_cons_S. apply H.
Qed. Hint Resolve strip_trunc_i.

Lemma strip_trunc :
 forall (v : list A) (i j : nat),
 (****************)
 strip (trunc v i) j = trunc (strip v j) (i - j).
simple induction v. simpl in |- *. unfold strip in |- *. simpl in |- *. trivial with arith.
simple induction i; simple induction j.
simpl in |- *. rewrite strip_O. rewrite trunc_O. trivial with arith.
rewrite trunc_O.
simpl in |- *. intros. unfold strip in |- *. simpl in |- *. rewrite trunc_O. trivial with arith.
rewrite strip_O. rewrite strip_O. elim minus_n_O. trivial with arith.
intros. rewrite strip_cons_S. simpl in |- *. rewrite strip_cons_S. apply H.
Qed.

Lemma trunc_strip :
 forall (v : list A) (i j : nat),
 (****************)
 trunc (strip v i) j = strip (trunc v (i + j)) i.
simple induction v. unfold strip in |- *. simpl in |- *. trivial with arith.
simple induction i; simple induction j. rewrite trunc_O. rewrite strip_O. auto with arith.
intros. rewrite strip_O. rewrite strip_O. auto with arith.
rewrite trunc_O. elim plus_n_O. rewrite strip_trunc_i. trivial with arith.
intros.
rewrite strip_cons_S. replace (S n + S n0) with (S (n + S n0)).
simpl in |- *. rewrite strip_cons_S. apply H.
auto with arith.
Qed.

(****************************************************************)
(* lemmes sur elemlist et sublist *)

Lemma elemlist_is_sublist :
 forall (v : list A) (i : nat),
 (************************)
 elemlist v i = sublist v i 1.
unfold elemlist, sublist in |- *. trivial with arith.
Qed.

Lemma elemlist_cons_S :
 forall (v : list A) (i : nat) (b : A),
 (********************)
 elemlist (b :: v) (S i) = elemlist v i.
unfold elemlist in |- *. intros. rewrite strip_cons_S. trivial with arith.
Qed.

Lemma elemlist_cons_O :
 forall (v : list A) (b : A),
 (********************)
 elemlist (b :: v) 0 = b :: nil.
intros.
unfold elemlist in |- *. rewrite strip_O. simpl in |- *. rewrite trunc_O. trivial with arith.
Qed.

Lemma elemlist_inv :
 forall (l : list A) (i : nat),
 (*****************)
 trunc (strip l i) 1 = elemlist l i.
unfold elemlist in |- *. trivial with arith.
Qed.

Lemma app_trunc_elemlist :
 forall (v : list A) (i : nat),
 (***********************)
 S i <= length v -> trunc v i ++ elemlist v i = trunc v (S i).
simple induction v. unfold elemlist in |- *. simpl in |- *. trivial with arith.
simple induction i. simpl in |- *. unfold elemlist in |- *. rewrite trunc_O.
rewrite strip_O. simpl in |- *. rewrite trunc_O. trivial with arith.
intros. simpl in |- *. unfold elemlist in |- *.
rewrite strip_cons_S. unfold elemlist in H. rewrite H. trivial with arith.
generalize H1. simpl in |- *. auto with arith.
Qed.

Lemma length_elemlist :
 forall (l : list A) (i : nat),
 (********************)
 i < length l -> length (elemlist l i) = 1.
intros. unfold elemlist in |- *. rewrite length_trunc. trivial with arith.
rewrite length_strip. inversion H. rewrite <- minus_Sn_m. auto with arith. auto with arith.
rewrite <- minus_Sn_m. auto with arith. apply le_Sn_le. exact H1. apply lt_le_weak. exact H.
Qed.

End Lists_field.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.

(* Why3 assumption *)
Inductive list (a:Type) :=
  | Nil : list a
  | Cons : a -> (list a) -> list a.
Implicit Arguments Nil [[a]].
Implicit Arguments Cons [[a]].

Parameter map : forall (a:Type) (b:Type), Type.

Parameter get: forall {a:Type} {b:Type}, (map a b) -> a -> b.

Parameter set: forall {a:Type} {b:Type}, (map a b) -> a -> b -> (map a b).

Axiom Select_eq : forall {a:Type} {b:Type}, forall (m:(map a b)),
  forall (a1:a) (a2:a), forall (b1:b), (a1 = a2) -> ((get (set m a1 b1)
  a2) = b1).

Axiom Select_neq : forall {a:Type} {b:Type}, forall (m:(map a b)),
  forall (a1:a) (a2:a), forall (b1:b), (~ (a1 = a2)) -> ((get (set m a1 b1)
  a2) = (get m a2)).

Parameter const: forall {a:Type} {b:Type}, b -> (map a b).

Axiom Const : forall {a:Type} {b:Type}, forall (b1:b) (a1:a),
  ((get (const b1:(map a b)) a1) = b1).

(* Why3 assumption *)
Inductive datatype  :=
  | TYunit : datatype
  | TYint : datatype
  | TYbool : datatype .

(* Why3 assumption *)
Inductive value  :=
  | Vvoid : value
  | Vint : Z -> value
  | Vbool : bool -> value .

(* Why3 assumption *)
Inductive operator  :=
  | Oplus : operator
  | Ominus : operator
  | Omult : operator
  | Ole : operator .

Parameter mident : Type.

Parameter ident : Type.

Parameter result: ident.

(* Why3 assumption *)
Inductive term  :=
  | Tvalue : value -> term
  | Tvar : ident -> term
  | Tderef : mident -> term
  | Tbin : term -> operator -> term -> term .

(* Why3 assumption *)
Inductive fmla  :=
  | Fterm : term -> fmla
  | Fand : fmla -> fmla -> fmla
  | Fnot : fmla -> fmla
  | Fimplies : fmla -> fmla -> fmla
  | Flet : ident -> term -> fmla -> fmla
  | Fforall : ident -> datatype -> fmla -> fmla .

(* Why3 assumption *)
Inductive expr  :=
  | Evalue : value -> expr
  | Ebin : expr -> operator -> expr -> expr
  | Evar : ident -> expr
  | Ederef : mident -> expr
  | Eassign : mident -> expr -> expr
  | Eseq : expr -> expr -> expr
  | Elet : ident -> expr -> expr -> expr
  | Eif : expr -> expr -> expr -> expr
  | Eassert : fmla -> expr
  | Ewhile : expr -> fmla -> expr -> expr .

(* Why3 assumption *)
Definition type_value(v:value): datatype :=
  match v with
  | Vvoid => TYunit
  | (Vint int1) => TYint
  | (Vbool bool1) => TYbool
  end.

(* Why3 assumption *)
Inductive type_operator : operator -> datatype -> datatype
  -> datatype -> Prop :=
  | Type_plus : (type_operator Oplus TYint TYint TYint)
  | Type_minus : (type_operator Ominus TYint TYint TYint)
  | Type_mult : (type_operator Omult TYint TYint TYint)
  | Type_le : (type_operator Ole TYint TYint TYbool).

(* Why3 assumption *)
Definition type_stack  := (list (ident* datatype)%type).

Parameter get_vartype: ident -> (list (ident* datatype)%type) -> datatype.

Axiom get_vartype_def : forall (i:ident) (pi:(list (ident* datatype)%type)),
  match pi with
  | Nil => ((get_vartype i pi) = TYunit)
  | (Cons (x, ty) r) => ((x = i) -> ((get_vartype i pi) = ty)) /\
      ((~ (x = i)) -> ((get_vartype i pi) = (get_vartype i r)))
  end.

(* Why3 assumption *)
Definition type_env  := (map mident datatype).

(* Why3 assumption *)
Inductive type_term : (map mident datatype) -> (list (ident* datatype)%type)
  -> term -> datatype -> Prop :=
  | Type_value : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:value), (type_term sigma pi (Tvalue v)
      (type_value v))
  | Type_var : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:ident) (ty:datatype), ((get_vartype v pi) = ty) ->
      (type_term sigma pi (Tvar v) ty)
  | Type_deref : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:mident) (ty:datatype), ((get sigma v) = ty) ->
      (type_term sigma pi (Tderef v) ty)
  | Type_bin : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (t1:term) (t2:term) (op:operator) (ty1:datatype)
      (ty2:datatype) (ty:datatype), (type_term sigma pi t1 ty1) ->
      ((type_term sigma pi t2 ty2) -> ((type_operator op ty1 ty2 ty) ->
      (type_term sigma pi (Tbin t1 op t2) ty))).

(* Why3 assumption *)
Inductive type_fmla : (map mident datatype) -> (list (ident* datatype)%type)
  -> fmla -> Prop :=
  | Type_term : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (t:term), (type_term sigma pi t TYbool) ->
      (type_fmla sigma pi (Fterm t))
  | Type_conj : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (f1:fmla) (f2:fmla), (type_fmla sigma pi f1) ->
      ((type_fmla sigma pi f2) -> (type_fmla sigma pi (Fand f1 f2)))
  | Type_neg : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (f:fmla), (type_fmla sigma pi f) -> (type_fmla sigma
      pi (Fnot f))
  | Type_implies : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (f1:fmla) (f2:fmla), (type_fmla sigma pi f1) ->
      ((type_fmla sigma pi f2) -> (type_fmla sigma pi (Fimplies f1 f2)))
  | Type_let : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:ident) (t:term) (f:fmla) (ty:datatype),
      (type_term sigma pi t ty) -> ((type_fmla sigma (Cons (x, ty) pi) f) ->
      (type_fmla sigma pi (Flet x t f)))
  | Type_forall1 : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:ident) (f:fmla), (type_fmla sigma (Cons (x, TYint)
      pi) f) -> (type_fmla sigma pi (Fforall x TYint f))
  | Type_forall2 : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:ident) (f:fmla), (type_fmla sigma (Cons (x, TYbool)
      pi) f) -> (type_fmla sigma pi (Fforall x TYbool f))
  | Type_forall3 : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:ident) (f:fmla), (type_fmla sigma (Cons (x, TYunit)
      pi) f) -> (type_fmla sigma pi (Fforall x TYunit f)).

(* Why3 assumption *)
Inductive type_expr : (map mident datatype) -> (list (ident* datatype)%type)
  -> expr -> datatype -> Prop :=
  | Type_evalue : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:value), (type_expr sigma pi (Evalue v)
      (type_value v))
  | Type_evar : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:ident) (ty:datatype), ((get_vartype v pi) = ty) ->
      (type_expr sigma pi (Evar v) ty)
  | Type_ederef : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:mident) (ty:datatype), ((get sigma v) = ty) ->
      (type_expr sigma pi (Ederef v) ty)
  | Type_ebin : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (e1:expr) (e2:expr) (op:operator) (ty1:datatype)
      (ty2:datatype) (ty:datatype), (type_expr sigma pi e1 ty1) ->
      ((type_expr sigma pi e2 ty2) -> ((type_operator op ty1 ty2 ty) ->
      (type_expr sigma pi (Ebin e1 op e2) ty)))
  | Type_eseq : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (e1:expr) (e2:expr) (ty:datatype), (type_expr sigma pi
      e1 TYunit) -> ((type_expr sigma pi e2 ty) -> (type_expr sigma pi
      (Eseq e1 e2) ty))
  | Type_eassigns : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:mident) (e:expr) (ty:datatype), ((get sigma
      x) = ty) -> ((type_expr sigma pi e ty) -> (type_expr sigma pi
      (Eassign x e) TYunit))
  | Type_elet : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:ident) (e1:expr) (e2:expr) (ty1:datatype)
      (ty2:datatype), (type_expr sigma pi e1 ty1) -> ((type_expr sigma
      (Cons (x, ty2) pi) e2 ty2) -> (type_expr sigma pi (Elet x e1 e2) ty2))
  | Type_eif : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (e1:expr) (e2:expr) (e3:expr) (ty:datatype),
      (type_expr sigma pi e1 TYbool) -> ((type_expr sigma pi e2 ty) ->
      ((type_expr sigma pi e3 ty) -> (type_expr sigma pi (Eif e1 e2 e3) ty)))
  | Type_eassert : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (p:fmla), (type_fmla sigma pi p) -> (type_expr sigma
      pi (Eassert p) TYbool)
  | Type_ewhile : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (guard:expr) (body:expr) (inv:fmla), (type_fmla sigma
      pi inv) -> ((type_expr sigma pi guard TYbool) -> ((type_expr sigma pi
      body TYunit) -> (type_expr sigma pi (Ewhile guard inv body) TYunit))).

(* Why3 assumption *)
Definition env  := (map mident value).

(* Why3 assumption *)
Definition stack  := (list (ident* value)%type).

Parameter get_stack: ident -> (list (ident* value)%type) -> value.

Axiom get_stack_def : forall (i:ident) (pi:(list (ident* value)%type)),
  match pi with
  | Nil => ((get_stack i pi) = Vvoid)
  | (Cons (x, v) r) => ((x = i) -> ((get_stack i pi) = v)) /\ ((~ (x = i)) ->
      ((get_stack i pi) = (get_stack i r)))
  end.

Axiom get_stack_eq : forall (x:ident) (v:value) (r:(list (ident*
  value)%type)), ((get_stack x (Cons (x, v) r)) = v).

Axiom get_stack_neq : forall (x:ident) (i:ident) (v:value) (r:(list (ident*
  value)%type)), (~ (x = i)) -> ((get_stack i (Cons (x, v) r)) = (get_stack i
  r)).

Parameter eval_bin: value -> operator -> value -> value.

Axiom eval_bin_def : forall (x:value) (op:operator) (y:value), match (x,
  y) with
  | ((Vint x1), (Vint y1)) =>
      match op with
      | Oplus => ((eval_bin x op y) = (Vint (x1 + y1)%Z))
      | Ominus => ((eval_bin x op y) = (Vint (x1 - y1)%Z))
      | Omult => ((eval_bin x op y) = (Vint (x1 * y1)%Z))
      | Ole => ((x1 <= y1)%Z -> ((eval_bin x op y) = (Vbool true))) /\
          ((~ (x1 <= y1)%Z) -> ((eval_bin x op y) = (Vbool false)))
      end
  | (_, _) => ((eval_bin x op y) = Vvoid)
  end.

(* Why3 assumption *)
Fixpoint eval_term(sigma:(map mident value)) (pi:(list (ident* value)%type))
  (t:term) {struct t}: value :=
  match t with
  | (Tvalue v) => v
  | (Tvar id) => (get_stack id pi)
  | (Tderef id) => (get sigma id)
  | (Tbin t1 op t2) => (eval_bin (eval_term sigma pi t1) op (eval_term sigma
      pi t2))
  end.

(* Why3 assumption *)
Fixpoint eval_fmla(sigma:(map mident value)) (pi:(list (ident* value)%type))
  (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm t) => ((eval_term sigma pi t) = (Vbool true))
  | (Fand f1 f2) => (eval_fmla sigma pi f1) /\ (eval_fmla sigma pi f2)
  | (Fnot f1) => ~ (eval_fmla sigma pi f1)
  | (Fimplies f1 f2) => (eval_fmla sigma pi f1) -> (eval_fmla sigma pi f2)
  | (Flet x t f1) => (eval_fmla sigma (Cons (x, (eval_term sigma pi t)) pi)
      f1)
  | (Fforall x TYint f1) => forall (n:Z), (eval_fmla sigma (Cons (x,
      (Vint n)) pi) f1)
  | (Fforall x TYbool f1) => forall (b:bool), (eval_fmla sigma (Cons (x,
      (Vbool b)) pi) f1)
  | (Fforall x TYunit f1) => (eval_fmla sigma (Cons (x, Vvoid) pi) f1)
  end.

Parameter msubst_term: term -> mident -> ident -> term.

Axiom msubst_term_def : forall (e:term) (r:mident) (v:ident),
  match e with
  | ((Tvalue _)|(Tvar _)) => ((msubst_term e r v) = e)
  | (Tderef x) => ((r = x) -> ((msubst_term e r v) = (Tvar v))) /\
      ((~ (r = x)) -> ((msubst_term e r v) = e))
  | (Tbin e1 op e2) => ((msubst_term e r v) = (Tbin (msubst_term e1 r v) op
      (msubst_term e2 r v)))
  end.

Parameter subst_term: term -> ident -> ident -> term.

Axiom subst_term_def : forall (e:term) (r:ident) (v:ident),
  match e with
  | ((Tvalue _)|(Tderef _)) => ((subst_term e r v) = e)
  | (Tvar x) => ((r = x) -> ((subst_term e r v) = (Tvar v))) /\
      ((~ (r = x)) -> ((subst_term e r v) = e))
  | (Tbin e1 op e2) => ((subst_term e r v) = (Tbin (subst_term e1 r v) op
      (subst_term e2 r v)))
  end.

(* Why3 assumption *)
Fixpoint fresh_in_term(id:ident) (t:term) {struct t}: Prop :=
  match t with
  | (Tvalue _) => True
  | (Tvar v) => ~ (id = v)
  | (Tderef _) => True
  | (Tbin t1 _ t2) => (fresh_in_term id t1) /\ (fresh_in_term id t2)
  end.

Axiom eval_msubst_term : forall (sigma:(map mident value)) (pi:(list (ident*
  value)%type)) (e:term) (x:mident) (v:ident), (fresh_in_term v e) ->
  ((eval_term sigma pi (msubst_term e x v)) = (eval_term (set sigma x
  (get_stack v pi)) pi e)).

Axiom eval_subst_term : forall (sigma:(map mident value)) (pi:(list (ident*
  value)%type)) (e:term) (x:ident) (v:ident), (fresh_in_term v e) ->
  ((eval_term sigma pi (subst_term e x v)) = (eval_term sigma (Cons (x,
  (get_stack v pi)) pi) e)).

Axiom eval_term_change_free : forall (t:term) (sigma:(map mident value))
  (pi:(list (ident* value)%type)) (id:ident) (v:value), (fresh_in_term id
  t) -> ((eval_term sigma (Cons (id, v) pi) t) = (eval_term sigma pi t)).

(* Why3 assumption *)
Fixpoint fresh_in_fmla(id:ident) (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm e) => (fresh_in_term id e)
  | ((Fand f1 f2)|(Fimplies f1 f2)) => (fresh_in_fmla id f1) /\
      (fresh_in_fmla id f2)
  | (Fnot f1) => (fresh_in_fmla id f1)
  | (Flet y t f1) => (~ (id = y)) /\ ((fresh_in_term id t) /\
      (fresh_in_fmla id f1))
  | (Fforall y ty f1) => (~ (id = y)) /\ (fresh_in_fmla id f1)
  end.

(* Why3 assumption *)
Fixpoint subst(f:fmla) (x:ident) (v:ident) {struct f}: fmla :=
  match f with
  | (Fterm e) => (Fterm (subst_term e x v))
  | (Fand f1 f2) => (Fand (subst f1 x v) (subst f2 x v))
  | (Fnot f1) => (Fnot (subst f1 x v))
  | (Fimplies f1 f2) => (Fimplies (subst f1 x v) (subst f2 x v))
  | (Flet y t f1) => (Flet y (subst_term t x v) (subst f1 x v))
  | (Fforall y ty f1) => (Fforall y ty (subst f1 x v))
  end.

(* Why3 assumption *)
Fixpoint msubst(f:fmla) (x:mident) (v:ident) {struct f}: fmla :=
  match f with
  | (Fterm e) => (Fterm (msubst_term e x v))
  | (Fand f1 f2) => (Fand (msubst f1 x v) (msubst f2 x v))
  | (Fnot f1) => (Fnot (msubst f1 x v))
  | (Fimplies f1 f2) => (Fimplies (msubst f1 x v) (msubst f2 x v))
  | (Flet y t f1) => (Flet y (msubst_term t x v) (msubst f1 x v))
  | (Fforall y ty f1) => (Fforall y ty (msubst f1 x v))
  end.

Axiom subst_fresh : forall (f:fmla) (x:ident) (v:ident), (fresh_in_fmla x
  f) -> ((subst f x v) = f).

Axiom let_subst : forall (t:term) (f:fmla) (x:ident) (id':ident) (id:mident),
  ((msubst (Flet x t f) id id') = (Flet x (msubst_term t id id') (msubst f id
  id'))).

Axiom eval_msubst : forall (f:fmla) (sigma:(map mident value)) (pi:(list
  (ident* value)%type)) (x:mident) (v:ident), (fresh_in_fmla v f) ->
  ((eval_fmla sigma pi (msubst f x v)) <-> (eval_fmla (set sigma x
  (get_stack v pi)) pi f)).

Axiom eval_subst : forall (f:fmla) (sigma:(map mident value)) (pi:(list
  (ident* value)%type)) (x:ident) (v:ident), (fresh_in_fmla v f) ->
  ((eval_fmla sigma pi (subst f x v)) <-> (eval_fmla sigma (Cons (x,
  (get_stack v pi)) pi) f)).

Axiom eval_swap : forall (f:fmla) (sigma:(map mident value)) (pi:(list
  (ident* value)%type)) (id1:ident) (id2:ident) (v1:value) (v2:value),
  (~ (id1 = id2)) -> ((eval_fmla sigma (Cons (id1, v1) (Cons (id2, v2) pi))
  f) <-> (eval_fmla sigma (Cons (id2, v2) (Cons (id1, v1) pi)) f)).

Axiom eval_same_var : forall (f:fmla) (sigma:(map mident value)) (pi:(list
  (ident* value)%type)) (id:ident) (v1:value) (v2:value), (eval_fmla sigma
  (Cons (id, v1) (Cons (id, v2) pi)) f) <-> (eval_fmla sigma (Cons (id, v1)
  pi) f).

Axiom eval_change_free : forall (f:fmla) (sigma:(map mident value)) (pi:(list
  (ident* value)%type)) (id:ident) (v:value), (fresh_in_fmla id f) ->
  ((eval_fmla sigma (Cons (id, v) pi) f) <-> (eval_fmla sigma pi f)).

(* Why3 assumption *)
Definition valid_fmla(p:fmla): Prop := forall (sigma:(map mident value))
  (pi:(list (ident* value)%type)), (eval_fmla sigma pi p).

Axiom let_equiv : forall (id:ident) (id':ident) (t:term) (f:fmla),
  forall (sigma:(map mident value)) (pi:(list (ident* value)%type)),
  (fresh_in_fmla id' f) -> ((eval_fmla sigma pi (Flet id' t (subst f id
  id'))) -> (eval_fmla sigma pi (Flet id t f))).

Axiom let_equiv2 : forall (id:ident) (id':ident) (t:term) (f:fmla),
  forall (sigma:(map mident value)) (pi:(list (ident* value)%type)),
  (fresh_in_fmla id' f) -> ((eval_fmla sigma pi (Flet id' t (subst f id
  id'))) -> (eval_fmla sigma pi (Flet id t f))).

Axiom let_implies : forall (id:ident) (t:term) (p:fmla) (q:fmla),
  (valid_fmla (Fimplies p q)) -> (valid_fmla (Fimplies (Flet id t p) (Flet id
  t q))).

(* Why3 assumption *)
Fixpoint fresh_in_expr(id:ident) (e:expr) {struct e}: Prop :=
  match e with
  | (Evalue _) => True
  | ((Eseq e1 e2)|(Ebin e1 _ e2)) => (fresh_in_expr id e1) /\
      (fresh_in_expr id e2)
  | (Evar v) => ~ (id = v)
  | (Ederef _) => True
  | (Eassign _ e1) => (fresh_in_expr id e1)
  | (Elet v e1 e2) => (~ (id = v)) /\ ((fresh_in_expr id e1) /\
      (fresh_in_expr id e2))
  | (Eif e1 e2 e3) => (fresh_in_expr id e1) /\ ((fresh_in_expr id e2) /\
      (fresh_in_expr id e3))
  | (Eassert f) => (fresh_in_fmla id f)
  | (Ewhile cond inv body) => (fresh_in_expr id cond) /\ ((fresh_in_fmla id
      inv) /\ (fresh_in_expr id body))
  end.

(* Why3 assumption *)
Inductive one_step : (map mident value) -> (list (ident* value)%type) -> expr
  -> (map mident value) -> (list (ident* value)%type) -> expr -> Prop :=
  | one_step_var : forall (sigma:(map mident value)) (pi:(list (ident*
      value)%type)) (v:ident), (one_step sigma pi (Evar v) sigma pi
      (Evalue (get_stack v pi)))
  | one_step_deref : forall (sigma:(map mident value)) (pi:(list (ident*
      value)%type)) (v:mident), (one_step sigma pi (Ederef v) sigma pi
      (Evalue (get sigma v)))
  | one_step_bin_ctxt1 : forall (sigma:(map mident value)) (sigma':(map
      mident value)) (pi:(list (ident* value)%type)) (pi':(list (ident*
      value)%type)) (op:operator) (e1:expr) (e1':expr) (e2:expr),
      (one_step sigma pi e1 sigma' pi' e1') -> (one_step sigma pi (Ebin e1 op
      e2) sigma' pi' (Ebin e1' op e2))
  | one_step_bin_ctxt2 : forall (sigma:(map mident value)) (sigma':(map
      mident value)) (pi:(list (ident* value)%type)) (pi':(list (ident*
      value)%type)) (op:operator) (v1:value) (e2:expr) (e2':expr),
      (one_step sigma pi e2 sigma' pi' e2') -> (one_step sigma pi
      (Ebin (Evalue v1) op e2) sigma' pi' (Ebin (Evalue v1) op e2'))
  | one_step_bin_value : forall (sigma:(map mident value)) (sigma':(map
      mident value)) (pi:(list (ident* value)%type)) (pi':(list (ident*
      value)%type)) (op:operator) (v1:value) (v2:value), (one_step sigma pi
      (Ebin (Evalue v1) op (Evalue v2)) sigma' pi' (Evalue (eval_bin v1 op
      v2)))
  | one_step_assign_ctxt : forall (sigma:(map mident value)) (sigma':(map
      mident value)) (pi:(list (ident* value)%type)) (pi':(list (ident*
      value)%type)) (x:mident) (e:expr) (e':expr), (one_step sigma pi e
      sigma' pi' e') -> (one_step sigma pi (Eassign x e) sigma' pi'
      (Eassign x e'))
  | one_step_assign_value : forall (sigma:(map mident value)) (pi:(list
      (ident* value)%type)) (x:mident) (v:value), (one_step sigma pi
      (Eassign x (Evalue v)) (set sigma x v) pi (Evalue Vvoid))
  | one_step_seq_ctxt : forall (sigma:(map mident value)) (sigma':(map mident
      value)) (pi:(list (ident* value)%type)) (pi':(list (ident*
      value)%type)) (e1:expr) (e1':expr) (e2:expr), (one_step sigma pi e1
      sigma' pi' e1') -> (one_step sigma pi (Eseq e1 e2) sigma' pi' (Eseq e1'
      e2))
  | one_step_seq_value : forall (sigma:(map mident value)) (pi:(list (ident*
      value)%type)) (e:expr), (one_step sigma pi (Eseq (Evalue Vvoid) e)
      sigma pi e)
  | one_step_let_ctxt : forall (sigma:(map mident value)) (sigma':(map mident
      value)) (pi:(list (ident* value)%type)) (pi':(list (ident*
      value)%type)) (id:ident) (e1:expr) (e1':expr) (e2:expr),
      (one_step sigma pi e1 sigma' pi' e1') -> (one_step sigma pi (Elet id e1
      e2) sigma' pi' (Elet id e1' e2))
  | one_step_let_value : forall (sigma:(map mident value)) (pi:(list (ident*
      value)%type)) (id:ident) (v:value) (e:expr), (one_step sigma pi
      (Elet id (Evalue v) e) sigma (Cons (id, v) pi) e)
  | one_step_if_ctxt : forall (sigma:(map mident value)) (sigma':(map mident
      value)) (pi:(list (ident* value)%type)) (pi':(list (ident*
      value)%type)) (e1:expr) (e1':expr) (e2:expr) (e3:expr), (one_step sigma
      pi e1 sigma' pi' e1') -> (one_step sigma pi (Eif e1 e2 e3) sigma' pi'
      (Eif e1' e2 e3))
  | one_step_if_true : forall (sigma:(map mident value)) (pi:(list (ident*
      value)%type)) (e1:expr) (e2:expr), (one_step sigma pi
      (Eif (Evalue (Vbool true)) e1 e2) sigma pi e1)
  | one_step_if_false : forall (sigma:(map mident value)) (pi:(list (ident*
      value)%type)) (e1:expr) (e2:expr), (one_step sigma pi
      (Eif (Evalue (Vbool false)) e1 e2) sigma pi e2)
  | one_step_assert : forall (sigma:(map mident value)) (pi:(list (ident*
      value)%type)) (f:fmla), (eval_fmla sigma pi f) -> (one_step sigma pi
      (Eassert f) sigma pi (Evalue Vvoid))
  | one_step_while : forall (sigma:(map mident value)) (pi:(list (ident*
      value)%type)) (cond:expr) (inv:fmla) (body:expr), (eval_fmla sigma pi
      inv) -> (one_step sigma pi (Ewhile cond inv body) sigma pi (Eif cond
      (Eseq body (Ewhile cond inv body)) (Evalue Vvoid))).

(* Why3 assumption *)
Inductive many_steps : (map mident value) -> (list (ident* value)%type)
  -> expr -> (map mident value) -> (list (ident* value)%type) -> expr
  -> Z -> Prop :=
  | many_steps_refl : forall (sigma:(map mident value)) (pi:(list (ident*
      value)%type)) (e:expr), (many_steps sigma pi e sigma pi e 0%Z)
  | many_steps_trans : forall (sigma1:(map mident value)) (sigma2:(map mident
      value)) (sigma3:(map mident value)) (pi1:(list (ident* value)%type))
      (pi2:(list (ident* value)%type)) (pi3:(list (ident* value)%type))
      (e1:expr) (e2:expr) (e3:expr) (n:Z), (one_step sigma1 pi1 e1 sigma2 pi2
      e2) -> ((many_steps sigma2 pi2 e2 sigma3 pi3 e3 n) ->
      (many_steps sigma1 pi1 e1 sigma3 pi3 e3 (n + 1%Z)%Z)).

Axiom steps_non_neg : forall (sigma1:(map mident value)) (sigma2:(map mident
  value)) (pi1:(list (ident* value)%type)) (pi2:(list (ident* value)%type))
  (e1:expr) (e2:expr) (n:Z), (many_steps sigma1 pi1 e1 sigma2 pi2 e2 n) ->
  (0%Z <= n)%Z.

Axiom many_steps_seq : forall (sigma1:(map mident value)) (sigma3:(map mident
  value)) (pi1:(list (ident* value)%type)) (pi3:(list (ident* value)%type))
  (e1:expr) (e2:expr) (n:Z), (many_steps sigma1 pi1 (Eseq e1 e2) sigma3 pi3
  (Evalue Vvoid) n) -> exists sigma2:(map mident value), exists pi2:(list
  (ident* value)%type), exists n1:Z, exists n2:Z, (many_steps sigma1 pi1 e1
  sigma2 pi2 (Evalue Vvoid) n1) /\ ((many_steps sigma2 pi2 e2 sigma3 pi3
  (Evalue Vvoid) n2) /\ (n = ((1%Z + n1)%Z + n2)%Z)).

Axiom many_steps_let : forall (sigma1:(map mident value)) (sigma3:(map mident
  value)) (pi1:(list (ident* value)%type)) (pi3:(list (ident* value)%type))
  (id:ident) (e1:expr) (e2:expr) (v2:value) (n:Z), (many_steps sigma1 pi1
  (Elet id e1 e2) sigma3 pi3 (Evalue v2) n) -> exists sigma2:(map mident
  value), exists pi2:(list (ident* value)%type), exists v1:value,
  exists n1:Z, exists n2:Z, (many_steps sigma1 pi1 e1 sigma2 pi2 (Evalue v1)
  n1) /\ ((many_steps sigma2 (Cons (id, v1) pi2) e2 sigma3 pi3 (Evalue v2)
  n2) /\ (n = ((1%Z + n1)%Z + n2)%Z)).

Axiom one_step_change_free : forall (e:expr) (e':expr) (sigma:(map mident
  value)) (sigma':(map mident value)) (pi:(list (ident* value)%type))
  (pi':(list (ident* value)%type)) (id:ident) (v:value), (fresh_in_expr id
  e) -> ((one_step sigma (Cons (id, v) pi) e sigma' pi' e') ->
  (one_step sigma pi e sigma' pi' e')).

(* Why3 assumption *)
Definition valid_triple(p:fmla) (e:expr) (q:fmla): Prop := forall (sigma:(map
  mident value)) (pi:(list (ident* value)%type)), (eval_fmla sigma pi p) ->
  forall (sigma':(map mident value)) (pi':(list (ident* value)%type))
  (v:value) (n:Z), (many_steps sigma pi e sigma' pi' (Evalue v) n) ->
  (eval_fmla sigma' (Cons (result, v) pi') q).

(* Why3 assumption *)
Definition total_valid_triple(p:fmla) (e:expr) (q:fmla): Prop :=
  forall (sigma:(map mident value)) (pi:(list (ident* value)%type)),
  (eval_fmla sigma pi p) -> exists sigma':(map mident value),
  exists pi':(list (ident* value)%type), exists v:value, exists n:Z,
  (many_steps sigma pi e sigma' pi' (Evalue v) n) /\ (eval_fmla sigma'
  (Cons (result, v) pi') q).

Parameter set1 : forall (a:Type), Type.

Parameter mem: forall {a:Type}, a -> (set1 a) -> Prop.

(* Why3 assumption *)
Definition infix_eqeq {a:Type}(s1:(set1 a)) (s2:(set1 a)): Prop :=
  forall (x:a), (mem x s1) <-> (mem x s2).

Axiom extensionality : forall {a:Type}, forall (s1:(set1 a)) (s2:(set1 a)),
  (infix_eqeq s1 s2) -> (s1 = s2).

(* Why3 assumption *)
Definition subset {a:Type}(s1:(set1 a)) (s2:(set1 a)): Prop := forall (x:a),
  (mem x s1) -> (mem x s2).

Axiom subset_trans : forall {a:Type}, forall (s1:(set1 a)) (s2:(set1 a))
  (s3:(set1 a)), (subset s1 s2) -> ((subset s2 s3) -> (subset s1 s3)).

Parameter empty: forall {a:Type}, (set1 a).

(* Why3 assumption *)
Definition is_empty {a:Type}(s:(set1 a)): Prop := forall (x:a), ~ (mem x s).

Axiom empty_def1 : forall {a:Type}, (is_empty (empty :(set1 a))).

Parameter add: forall {a:Type}, a -> (set1 a) -> (set1 a).

Axiom add_def1 : forall {a:Type}, forall (x:a) (y:a), forall (s:(set1 a)),
  (mem x (add y s)) <-> ((x = y) \/ (mem x s)).

Parameter remove: forall {a:Type}, a -> (set1 a) -> (set1 a).

Axiom remove_def1 : forall {a:Type}, forall (x:a) (y:a) (s:(set1 a)), (mem x
  (remove y s)) <-> ((~ (x = y)) /\ (mem x s)).

Axiom subset_remove : forall {a:Type}, forall (x:a) (s:(set1 a)),
  (subset (remove x s) s).

Parameter union: forall {a:Type}, (set1 a) -> (set1 a) -> (set1 a).

Axiom union_def1 : forall {a:Type}, forall (s1:(set1 a)) (s2:(set1 a)) (x:a),
  (mem x (union s1 s2)) <-> ((mem x s1) \/ (mem x s2)).

Parameter inter: forall {a:Type}, (set1 a) -> (set1 a) -> (set1 a).

Axiom inter_def1 : forall {a:Type}, forall (s1:(set1 a)) (s2:(set1 a)) (x:a),
  (mem x (inter s1 s2)) <-> ((mem x s1) /\ (mem x s2)).

Parameter diff: forall {a:Type}, (set1 a) -> (set1 a) -> (set1 a).

Axiom diff_def1 : forall {a:Type}, forall (s1:(set1 a)) (s2:(set1 a)) (x:a),
  (mem x (diff s1 s2)) <-> ((mem x s1) /\ ~ (mem x s2)).

Axiom subset_diff : forall {a:Type}, forall (s1:(set1 a)) (s2:(set1 a)),
  (subset (diff s1 s2) s1).

Parameter choose: forall {a:Type}, (set1 a) -> a.

Axiom choose_def : forall {a:Type}, forall (s:(set1 a)), (~ (is_empty s)) ->
  (mem (choose s) s).

Parameter all: forall {a:Type}, (set1 a).

Axiom all_def : forall {a:Type}, forall (x:a), (mem x (all :(set1 a))).

(* Why3 assumption *)
Definition assigns(sigma:(map mident value)) (a:(set1 mident)) (sigma':(map
  mident value)): Prop := forall (i:mident), (~ (mem i a)) -> ((get sigma
  i) = (get sigma' i)).

Axiom assigns_refl : forall (sigma:(map mident value)) (a:(set1 mident)),
  (assigns sigma a sigma).

Axiom assigns_trans : forall (sigma1:(map mident value)) (sigma2:(map mident
  value)) (sigma3:(map mident value)) (a:(set1 mident)), ((assigns sigma1 a
  sigma2) /\ (assigns sigma2 a sigma3)) -> (assigns sigma1 a sigma3).

Axiom assigns_union_left : forall (sigma:(map mident value)) (sigma':(map
  mident value)) (s1:(set1 mident)) (s2:(set1 mident)), (assigns sigma s1
  sigma') -> (assigns sigma (union s1 s2) sigma').

Axiom assigns_union_right : forall (sigma:(map mident value)) (sigma':(map
  mident value)) (s1:(set1 mident)) (s2:(set1 mident)), (assigns sigma s2
  sigma') -> (assigns sigma (union s1 s2) sigma').

(* Why3 assumption *)
Fixpoint expr_writes(e:expr) (w:(set1 mident)) {struct e}: Prop :=
  match e with
  | ((Evalue _)|((Evar _)|((Ederef _)|(Eassert _)))) => True
  | (Ebin e1 _ e2) => (expr_writes e1 w) /\ (expr_writes e2 w)
  | (Eassign id _) => (mem id w)
  | (Eseq e1 e2) => (expr_writes e1 w) /\ (expr_writes e2 w)
  | (Elet id e1 e2) => (expr_writes e1 w) /\ (expr_writes e2 w)
  | (Eif e1 e2 e3) => (expr_writes e1 w) /\ ((expr_writes e2 w) /\
      (expr_writes e3 w))
  | (Ewhile cond _ body) => (expr_writes cond w) /\ (expr_writes body w)
  end.

Parameter fresh_from: fmla -> expr -> ident.

Axiom fresh_from_fmla : forall (e:expr) (f:fmla),
  (fresh_in_fmla (fresh_from f e) f).

Axiom fresh_from_expr : forall (e:expr) (f:fmla),
  (fresh_in_expr (fresh_from f e) e).

Parameter abstract_effects: expr -> fmla -> fmla.

(* Why3 assumption *)
Fixpoint wp(e:expr) (q:fmla) {struct e}: fmla :=
  match e with
  | (Evalue v) => (Flet result (Tvalue v) q)
  | (Evar v) => (Flet result (Tvar v) q)
  | (Ederef x) => (Flet result (Tderef x) q)
  | (Eassert f) => (Fand f (Fimplies f (Flet result (Tvalue Vvoid) q)))
  | (Eseq e1 e2) => (wp e1 (wp e2 q))
  | (Elet id e1 e2) => (wp e1 (Flet id (Tvar result) (wp e2 q)))
  | (Ebin e1 op e2) => let t1 := (fresh_from q e) in let t2 :=
      (fresh_from (Fand (Fterm (Tvar t1)) q) e) in let q' := (Flet result
      (Tbin (Tvar t1) op (Tvar t2)) q) in let f := (wp e2 (Flet t2
      (Tvar result) q')) in (wp e1 (Flet t1 (Tvar result) f))
  | (Eassign x e1) => let id := (fresh_from q e1) in let q' := (Flet result
      (Tvalue Vvoid) q) in (wp e1 (Flet id (Tvar result) (msubst q' x id)))
  | (Eif e1 e2 e3) => let f := (Fand (Fimplies (Fterm (Tvar result)) (wp e2
      q)) (Fimplies (Fnot (Fterm (Tvar result))) (wp e3 q))) in (wp e1 f)
  | (Ewhile cond inv body) => (Fand inv (abstract_effects body (wp cond
      (Fand (Fimplies (Fand (Fterm (Tvar result)) inv) (wp body inv))
      (Fimplies (Fand (Fnot (Fterm (Tvar result))) inv) q)))))
  end.

Axiom result_always_fresh_in_wp : forall (e:expr) (q:fmla),
  (fresh_in_fmla result (wp e q)).

Axiom distrib_conj : forall (sigma:(map mident value)) (pi:(list (ident*
  value)%type)) (e:expr) (p:fmla) (q:fmla), (eval_fmla sigma pi (wp e (Fand p
  q))) <-> ((eval_fmla sigma pi (wp e p)) /\ (eval_fmla sigma pi (wp e q))).

Axiom monotonicity : forall (e:expr) (p:fmla) (q:fmla),
  (valid_fmla (Fimplies p q)) -> (valid_fmla (Fimplies (wp e p) (wp e q))).

(* Why3 goal *)
Theorem wp_reduction : forall (sigma:(map mident value)) (sigma':(map mident
  value)) (pi:(list (ident* value)%type)) (pi':(list (ident* value)%type))
  (e:expr) (e':expr), (one_step sigma pi e sigma' pi' e') -> forall (q:fmla),
  (eval_fmla sigma pi (wp e q)) -> (eval_fmla sigma' pi' (wp e' q)).
induction 1.
(* case 1/16: var *)
auto.
(* case 2/16: deref *)
auto.
(* case 3/16: e_1 bin_op e_2 *)
intros q.
simpl in *.
pose (t1 := fresh_from q (Ebin e1 op e2)).
fold t1.
pose (t1' := fresh_from q (Ebin e1' op e2)).
fold t1'.
pose (t2 := fresh_from (Fand (Fterm (Tvar t1)) q) (Ebin e1 op e2)).
fold t2.
pose (t2' := fresh_from (Fand (Fterm (Tvar t1')) q) (Ebin e1' op e2)).
fold t2'.
intros h.
apply IHone_step.
apply monotonicity with (2:=h).
intros sigma'' pi''.
intro.
apply let_equiv with (id':=t1).
admit.
admit.
(*rewrite wp_subst.
rewrite let_subst.
rewrite let_subst.
rewrite subst_fresh.
rewrite (subst_term_def (Tbin (Tvar t1') op (Tvar t2'))).
rewrite (subst_term_def (Tvar t1') t1' t1).
rewrite (subst_term_def (Tvar t2') t1' t1).
rewrite (subst_term_def (Tvar result) t1' t1).

admit. (* needs lemmas on fresh_from *)
admit.*)
(* case 4/16: v_1 bin_op e_2 *)
intros q h.
admit.

(* case 5/16: v_1 bin_op v_2 *)
intros q h.
admit.

(* case 6/16: x := e -> x := e' *)
intros.
admit.

(* case 7/16: x := v -> void *)
simpl; intros.
apply eval_msubst in H.
rewrite get_stack_neq in H.
rewrite get_stack_eq in H.
rewrite get_stack_eq in H.
rewrite (msubst_term_def (Tvalue Vvoid)) in H.
simpl in H.
rewrite eval_swap in H.
rewrite eval_change_free in H.
rewrite eval_same_var in H; auto.
admit.
admit.
admit.
admit.

(* case 8/16: Eseq e_1 e_2 *)
admit.

(* case 9/16: Eseq void e_2 *)
admit.

(* case 10/16: Elet id e_1 e_2 *)
admit.

(* case 11/16: Elet id v_1 e_2 *)
admit.

(* case 12/16: Eif e_1 e_2 e_3*)
admit.

(* case 13/16: Eif true e_1 e_2 *)
simpl.
rewrite get_stack_eq.
intros q (h & _ ).
rewrite <- eval_change_free.
apply h; auto.
apply result_always_fresh_in_wp.

(* case 14/16: Eif false e_1 e_2 *)
simpl.
rewrite get_stack_eq.
intros q (_ & h ).
rewrite <- eval_change_free.
apply h.
discriminate.
apply result_always_fresh_in_wp.

(* case 15/16: Eassert f *)
simpl.
intros q (h1 & h2).
apply (h2 h1).

(* case 16/16: Ewhile cond inv body *)
admit.

Qed.