(* Copyright © 1998-2008
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Cezary Kaliszyk
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(** printing != %\ensuremath{\mathrel\#}% *)
(** printing == %\ensuremath{\equiv}% #≡# *)
(** printing [=] %\ensuremath{\equiv}% #≡# *)
(** printing [~=] %\ensuremath{\mathrel{\not\equiv}}% #≠# *)
(** printing [#] %\ensuremath{\mathrel\#}% *)
(** printing ex_unq %\ensuremath{\exists^1}% #∃1# *)
(** printing [o] %\ensuremath\circ% #⋅# *)
(** printing [-C-] %\ensuremath\diamond% *)

(**
* Setoids
Definition of a constructive setoid with apartness,
i.e.%\% a set with an equivalence relation and an apartness relation compatible with it.
*)

Require Import CoRN.tactics.CornTac.
Require Export CoRN.logic.CLogic.
Require Export CoRN.tactics.Step.
Require Export CoRN.algebra.RSetoid.

Delimit Scope corn_scope with corn.
Open Scope corn_scope.

Definition Relation := Trelation.

Arguments Treflexive [A].
Arguments Creflexive [A].

Arguments Tsymmetric [A].
Arguments Csymmetric [A].
Arguments Ttransitive [A].
Arguments Ctransitive [A].

(* begin hide *)
Set Implicit Arguments.
Unset Strict Implicit.
(* end hide *)

(**
** Relations necessary for Setoids
%\begin{convention}% Let [A:Type].
%\end{convention}%

Notice that their type depends on the main logical connective.
*)

Section Properties_of_relations.
Variable A : Type.

Definition irreflexive (R : Crelation A) : Prop := forall x : A, Not (R x x).

Definition cotransitive (R : Crelation A) : CProp := forall x y : A,
 R x y -> forall z : A, R x z or R z y.

Definition tight_apart (eq : Relation A) (ap : Crelation A) : Prop := forall x y : A,
 Not (ap x y) <-> eq x y.

Definition antisymmetric (R : Crelation A) : Prop := forall x y : A,
 R x y -> Not (R y x).

End Properties_of_relations.
(* begin hide *)
Set Strict Implicit.
Unset Implicit Arguments.
(* end hide *)

(**
** Definition of Setoid

Apartness, being the main relation, needs to be [CProp]-valued.  Equality,
as it is characterized by a negative statement, lives in [Prop]. *)

Record is_CSetoid (A : Type) (eq : Relation A) (ap : Crelation A) : CProp :=
  {ax_ap_irreflexive  : irreflexive ap;
   ax_ap_symmetric    : Csymmetric ap;
   ax_ap_cotransitive : cotransitive ap;
   ax_ap_tight        : tight_apart eq ap}.

Record CSetoid : Type := makeCSetoid
  {cs_crr   :> RSetoid;
   cs_ap    :  Crelation cs_crr;
   cs_proof :  is_CSetoid cs_crr (@st_eq cs_crr) cs_ap}.

Notation cs_eq := st_eq (only parsing).
Arguments cs_ap [c].

Infix "[=]" := cs_eq (at level 70, no associativity).
Infix "[#]" := cs_ap (at level 70, no associativity).

(* End_SpecReals *)

Definition cs_neq (S : CSetoid) : Relation S := fun x y : S => ~ x [=] y.

Arguments cs_neq [S].

Infix "[~=]" := cs_neq (at level 70, no associativity).

(**
%\begin{nameconvention}%
In the names of lemmas, we refer to [ [=] ] by [eq], [ [~=] ] by
[neq], and [ [#] ] by [ap].
%\end{nameconvention}%

** Setoid axioms
We want concrete lemmas that state the axiomatic properties of a setoid.
%\begin{convention}%
Let [S] be a setoid.
%\end{convention}%
*)

(* Begin_SpecReals *)

Section CSetoid_axioms.
Variable S : CSetoid.

Lemma CSetoid_is_CSetoid : is_CSetoid S (cs_eq (r:=S)) (cs_ap (c:=S)).
Proof cs_proof S.

Lemma ap_irreflexive : irreflexive (cs_ap (c:=S)).
Proof.
 elim CSetoid_is_CSetoid; auto.
Qed.

Lemma ap_symmetric : Csymmetric (cs_ap (c:=S)).
Proof.
 elim CSetoid_is_CSetoid; auto.
Qed.

Lemma ap_cotransitive : cotransitive (cs_ap (c:=S)).
Proof.
 elim CSetoid_is_CSetoid; auto.
Qed.

Lemma ap_tight : tight_apart (cs_eq (r:=S)) (cs_ap (c:=S)).
Proof.
 elim CSetoid_is_CSetoid; auto.
Qed.

End CSetoid_axioms.

(**
** Setoid basics%\label{section:setoid-basics}%
%\begin{convention}% Let [S] be a setoid.
%\end{convention}%
*)

Lemma is_CSetoid_Setoid : forall S eq ap, is_CSetoid S eq ap -> Setoid_Theory S eq.
Proof.
 intros S eq ap p.
 destruct p.
 split.
   firstorder.
  intros a b. red in ax_ap_tight0 .
  repeat rewrite <- ax_ap_tight0.
  firstorder.
 intros a b c. red in ax_ap_tight0 .
 repeat rewrite <- ax_ap_tight0.
 intros H H0 H1.
 destruct (ax_ap_cotransitive0 _ _ H1 b); auto.
Qed.

Definition Build_CSetoid (X:Type) (eq:Relation X) (ap:Crelation X) (p:is_CSetoid X eq ap) : CSetoid.
Proof.
 exists (Build_RSetoid (is_CSetoid_Setoid _ _ _ p)) ap.
 assumption.
Defined.

Section CSetoid_basics.
Variable S : CSetoid.

(* End_SpecReals *)

(**
In `there exists a unique [a:S] such that %\ldots%#...#', we now mean unique with respect to the setoid equality. We use [ex_unq] to denote unique existence.
*)

Definition ex_unq (P : S -> CProp) := {x : S | forall y : S, P y -> x [=] y | P x}.

Lemma eq_reflexive : Treflexive (cs_eq (r:=S)).
Proof.
 intro x.
 reflexivity.
Qed.

Lemma eq_symmetric : Tsymmetric (cs_eq (r:=S)).
Proof.
 intro x; intros y H.
 symmetry; assumption.
Qed.

Lemma eq_transitive : Ttransitive (cs_eq (r:=S)).
Proof.
 intro x; intros y z H H0.
 transitivity y; assumption.
Qed.

(**
%\begin{shortcoming}%
The lemma [eq_reflexive] above is convertible to
[eq_reflexive_unfolded] below. We need the second version too,
because the first cannot be applied when an instance of reflexivity is needed.
(``I have complained bitterly about this.'' RP)
%\end{shortcoming}%
tes
%\begin{nameconvention}%
If lemma [a] is just an unfolding of lemma [b], the name of [a] is the name
[b] with the suffix ``[_unfolded]''.
%\end{nameconvention}%
*)

Lemma eq_reflexive_unfolded : forall x : S, x [=] x.
Proof eq_reflexive.

Lemma eq_symmetric_unfolded : forall x y : S, x [=] y -> y [=] x.
Proof eq_symmetric.

Lemma eq_transitive_unfolded : forall x y z : S, x [=] y -> y [=] z -> x [=] z.
Proof eq_transitive.

Lemma eq_wdl : forall x y z : S, x [=] y -> x [=] z -> z [=] y.
Proof.
 intros. now apply (eq_transitive _ x);[apply: eq_symmetric|].
Qed.

Lemma ap_irreflexive_unfolded : forall x : S, Not (x [#] x).
Proof ap_irreflexive S.

Lemma ap_cotransitive_unfolded : forall a b : S, a [#] b -> forall c : S, a [#] c or c [#] b.
Proof.
 intros a b H c.
 exact (ap_cotransitive _ _ _ H c).
Qed.

Lemma ap_symmetric_unfolded : forall x y : S, x [#] y -> y [#] x.
Proof ap_symmetric S.

(**
We would like to write
[[
Lemma eq_equiv_not_ap : forall (x y:S), (x [=] y) iff Not (x [#] y).
]]
In Coq, however, this lemma cannot be easily applied.
Therefore we have to split the lemma into the following two lemmas [eq_imp_not_ap] and [not_ap_imp_eq].
For this we should fix the Prop CProp problem.
*)

Lemma eq_imp_not_ap : forall x y : S, x [=] y -> Not (x [#] y).
Proof.
 intros x y.
 elim (ap_tight S x y).
 intros H1 H2.
 assumption.
Qed.

Lemma not_ap_imp_eq : forall x y : S, Not (x [#] y) -> x [=] y.
Proof.
 intros x y.
 elim (ap_tight S x y).
 intros H1 H2.
 assumption.
Qed.

Lemma neq_imp_notnot_ap : forall x y : S, x [~=] y -> ~ Not (x [#] y).
Proof.
 intros x y H H0.
 now apply: H; apply: not_ap_imp_eq.
Qed.

Lemma notnot_ap_imp_neq : forall x y : S, ~ Not (x [#] y) -> x [~=] y.
Proof.
 intros x y H H0.
 now apply H; apply eq_imp_not_ap.
Qed.

Lemma ap_imp_neq : forall x y : S, x [#] y -> x [~=] y.
Proof.
 intros x y H H1.
 now apply (eq_imp_not_ap _ _ H1).
Qed.

Lemma not_neq_imp_eq : forall x y : S, ~ x [~=] y -> x [=] y.
Proof.
 intros x y H.
 apply: not_ap_imp_eq.
 intros H0.
 apply: H. now apply: ap_imp_neq.
Qed.

Lemma eq_imp_not_neq : forall x y : S, x [=] y -> ~ x [~=] y.
Proof.
 intros x y H H0. easy.
Qed.

End CSetoid_basics.

Section product_csetoid.
(**
** The product of setoids *)

Definition prod_ap (A B : CSetoid) (c d : prodT A B) : CProp.
Proof.
 destruct c as [a b], d as [a0 b0].
 exact (cs_ap (c:=A) a a0 or cs_ap (c:=B) b b0).
Defined.

Definition prod_eq (A B : CSetoid) (c d : prodT A B) : Prop.
Proof.
 destruct c as [a b], d as [a0 b0].
 exact (a [=] a0 /\ b [=] b0).
Defined.

Lemma prodcsetoid_is_CSetoid : forall A B : CSetoid,
 is_CSetoid (prodT A B) (prod_eq A B) (prod_ap A B).
Proof.
 (* Can be shortened *)
 intros A B.
 apply (Build_is_CSetoid _ (prod_eq A B) (prod_ap A B)).
    intros x. case x. intros c c0 H.
    elim H.
     intros H1.
     now apply: (ap_irreflexive A _ H1).
    apply (ap_irreflexive B _ ).
   intros x y. case x. case y.
   intros c c0 c1 c2 H.
   elim H.
    intros.
    left.
    now apply ap_symmetric.
   intros.
   right.
   now apply ap_symmetric.
  intros x y. case x. case y.
  intros c c0 c1 c2 H z. case z.
  intros c3 c4.
  generalize H.
  intros.
  elim H.
   intros.
   cut (c1 [#] c3 or c3 [#] c).
    intros [H1|H2].
     left.
     now left.
    intros.
    right.
    now left.
   now apply: ap_cotransitive.
  intros.
  cut (c2 [#] c4 or c4 [#] c0).
   intros [H1|H2].
    left; now right.
   now right;right.
  now apply: ap_cotransitive.
 intros x y. case x. case y.
 intros c c0 c1 c2.
 split.
  intros.
  split.
   apply not_ap_imp_eq.
   intros H1. now cut (c1 [#] c or c2 [#] c0);[|left].
   apply not_ap_imp_eq. intros H1. now cut (c1 [#] c or c2 [#] c0);[|right].
  intros.
 elim H.
 intros H0 H1 H2.
 now elim H2;apply eq_imp_not_ap.
Qed.

Definition ProdCSetoid (A B : CSetoid) : CSetoid := Build_CSetoid
 (prodT A B) (prod_eq A B) (prod_ap A B) (prodcsetoid_is_CSetoid A B).

End product_csetoid.
Arguments ex_unq [S].

#[global]
Hint Resolve eq_reflexive_unfolded ap_irreflexive_unfolded: algebra_r.
#[global]
Hint Resolve eq_symmetric_unfolded ap_symmetric_unfolded: algebra_s.
#[global]
Hint Resolve eq_transitive_unfolded ap_cotransitive_unfolded: algebra_c.

Declare Left Step eq_wdl.
Declare Right Step eq_transitive_unfolded.

(**
** Relations and predicates
Here we define the notions of well-definedness and strong extensionality
on predicates and relations.

%\begin{convention}% Let [S] be a setoid.
%\end{convention}%

%\begin{nameconvention}%
- ``well-defined'' is abbreviated to [well_def] (or [wd]).
- ``strongly extensional'' is abbreviated to [strong_ext] (or [strext]).

%\end{nameconvention}%
*)

Section CSetoid_relations_and_predicates.
Variable S : CSetoid.

(**
*** Predicates

At this stage, we consider [CProp]- and [Prop]-valued predicates on setoids.

%\begin{convention}% Let [P] be a predicate on (the carrier of) [S].
%\end{convention}%
*)

Section CSetoidPredicates.
Variable P : S -> CProp.

Definition pred_strong_ext : CProp := forall x y : S, P x -> P y or x [#] y.

Definition pred_wd : CProp := forall x y : S, P x -> x [=] y -> P y.

End CSetoidPredicates.

Record wd_pred : Type :=
  {wdp_pred     :> S -> CProp;
   wdp_well_def :  pred_wd wdp_pred}.

Record CSetoid_predicate : Type :=
 {csp_pred   :> S -> CProp;
  csp_strext :  pred_strong_ext csp_pred}.

Lemma csp_wd : forall P : CSetoid_predicate, pred_wd P.
Proof.
 intro P.
 intro x; intros y H H0.
 elim (csp_strext P x y H).
  auto.
 set (eq_imp_not_ap _ _ _ H0); contradiction.
Qed.

(** Similar, with [Prop] instead of [CProp]. *)

Section CSetoidPPredicates.
Variable P : S -> Prop.

Definition pred_strong_ext' : CProp := forall x y : S, P x -> P y or x [#] y.

Definition pred_wd' : Prop := forall x y : S, P x -> x [=] y -> P y.

End CSetoidPPredicates.

(**
*** Definition of a setoid predicate *)

Record CSetoid_predicate' : Type :=
 {csp'_pred   :> S -> Prop;
  csp'_strext :  pred_strong_ext' csp'_pred}.

Lemma csp'_wd : forall P : CSetoid_predicate', pred_wd' P.
Proof.
 intro P.
 intro x; intros y H H0.
 elim (csp'_strext P x y H).
  auto.
 set (eq_imp_not_ap _ _ _ H0); contradiction.
Qed.

(**
*** Relations
%\begin{convention}%
Let [R] be a relation on (the carrier of) [S].
%\end{convention}% *)

Section CsetoidRelations.
Variable R : S -> S -> Prop.

Definition rel_wdr : Prop := forall x y z : S, R x y -> y [=] z -> R x z.

Definition rel_wdl : Prop := forall x y z : S, R x y -> x [=] z -> R z y.

Definition rel_strext : CProp := forall x1 x2 y1 y2 : S,
 R x1 y1 -> (x1 [#] x2 or y1 [#] y2) or R x2 y2.

Definition rel_strext_lft : CProp := forall x1 x2 y : S, R x1 y -> x1 [#] x2 or R x2 y.

Definition rel_strext_rht : CProp := forall x y1 y2 : S, R x y1 -> y1 [#] y2 or R x y2.

Lemma rel_strext_imp_lftarg : rel_strext -> rel_strext_lft.
Proof.
 intros H x1 x2 y H0.
 generalize (H x1 x2 y y).
 intros H1.
 elim (H1 H0);[|auto].
 intros [H2|H3];[auto|].
 elim (ap_irreflexive S _ H3).
Qed.

Lemma rel_strext_imp_rhtarg : rel_strext -> rel_strext_rht.
Proof.
 intros H x y1 y2 H0.
 generalize (H x x y1 y2 H0). intros [[H1|H2]|H3]; auto.
 elim (ap_irreflexive _ _ H1).
Qed.

Lemma rel_strextarg_imp_strext :
 rel_strext_rht -> rel_strext_lft -> rel_strext.
Proof.
 intros H H0 x1 x2 y1 y2 H1.
 elim (H x1 y1 y2 H1); intro H2;[|elim (H0 x1 x2 y2 H2)];auto.

Qed.

End CsetoidRelations.

(**
*** Definition of a setoid relation
The type of relations over a setoid.  *)

Record CSetoid_relation : Type :=
  {csr_rel    :> S -> S -> Prop;
   csr_wdr    :  rel_wdr csr_rel;
   csr_wdl    :  rel_wdl csr_rel;
   csr_strext :  rel_strext csr_rel}.

(**
*** [CProp] Relations
%\begin{convention}%
Let [R] be a relation on (the carrier of) [S].
%\end{convention}%
*)

Section CCsetoidRelations.

Variable R : S -> S -> CProp.

Definition Crel_wdr : CProp := forall x y z : S, R x y -> y [=] z -> R x z.

Definition Crel_wdl : CProp := forall x y z : S, R x y -> x [=] z -> R z y.

Definition Crel_strext : CProp := forall x1 x2 y1 y2 : S,
 R x1 y1 -> R x2 y2 or x1 [#] x2 or y1 [#] y2.

Definition Crel_strext_lft : CProp := forall x1 x2 y : S, R x1 y -> R x2 y or x1 [#] x2.

Definition Crel_strext_rht : CProp := forall x y1 y2 : S, R x y1 -> R x y2 or y1 [#] y2.

Lemma Crel_strext_imp_lftarg : Crel_strext -> Crel_strext_lft.
Proof.
 intros H x1 x2 y H0. generalize (H x1 x2 y y).
 intros [H1|H2];auto.
 case H2. auto. intro H3. elim (ap_irreflexive _ _ H3).
Qed.

Lemma Crel_strext_imp_rhtarg : Crel_strext -> Crel_strext_rht.
Proof.
 intros H x y1 y2 H0.
 generalize (H x x y1 y2 H0). intros [H1|H2];auto.
 case H2; auto. intro H3. elim (ap_irreflexive _ _ H3).
Qed.

Lemma Crel_strextarg_imp_strext :
 Crel_strext_rht -> Crel_strext_lft -> Crel_strext.
Proof.
 intros H H0 x1 x2 y1 y2 H1.
 elim (H x1 y1 y2 H1); auto.
 intro H2.
 elim (H0 x1 x2 y2 H2); auto.
Qed.

End CCsetoidRelations.

(**
*** Definition of a [CProp] setoid relation

The type of relations over a setoid.  *)

Record CCSetoid_relation : Type :=
 {Ccsr_rel    :> S -> S -> CProp;
  Ccsr_strext :  Crel_strext Ccsr_rel}.

Lemma Ccsr_wdr : forall R : CCSetoid_relation, Crel_wdr R.
Proof.
 intro R.
 intros x y z H H0.
 elim (Ccsr_strext R x x y z H);auto.
 intros [H1|H2]. elim (ap_irreflexive _ _ H1).
  set (eq_imp_not_ap _ _ _ H0). contradiction.
Qed.

Lemma Ccsr_wdl : forall R : CCSetoid_relation, Crel_wdl R.
Proof.
 intros R x y z H H0.
 elim (Ccsr_strext R x z y y H);auto.
 intros [H1|H2]; [set (eq_imp_not_ap _ _ _ H0); contradiction| elim (ap_irreflexive _ _ H2)].
Qed.

Lemma ap_wdr : Crel_wdr (cs_ap (c:=S)).
Proof.
 intros x y z H H0.
 generalize (eq_imp_not_ap _ _ _ H0); intro H1.
 elim (ap_cotransitive _ _ _ H z); intro H2.
  assumption.
 elim H1.
 now apply: ap_symmetric.
Qed.

Lemma ap_wdl : Crel_wdl (cs_ap (c:=S)).
Proof.
 intros x y z H H0.
 generalize (ap_wdr y x z); intro H1.
 apply ap_symmetric.
 now apply H1;[apply ap_symmetric|].
Qed.

Lemma ap_wdr_unfolded : forall x y z : S, x [#] y -> y [=] z -> x [#] z.
Proof ap_wdr.

Lemma ap_wdl_unfolded : forall x y z : S, x [#] y -> x [=] z -> z [#] y.
Proof ap_wdl.

Lemma ap_strext : Crel_strext (cs_ap (c:=S)).
Proof.
 intros x1 x2 y1 y2 H.
 case (ap_cotransitive _ _ _ H x2); intro H0;auto.
 case (ap_cotransitive _ _ _ H0 y2); intro H1;auto.
 right; right.
 now apply ap_symmetric.
Qed.

Definition predS_well_def (P : S -> CProp) : CProp := forall x y : S,
 P x -> x [=] y -> P y.

End CSetoid_relations_and_predicates.

Declare Left Step ap_wdl_unfolded.
Declare Right Step ap_wdr_unfolded.

(**
** Functions between setoids
Such functions must preserve the setoid equality
and be strongly extensional w.r.t.%\% the apartness, i.e.%\%
if [f(x,y) [#] f(x1,y1)], then  [x [#] x1 + y [#] y1].
For every arity this has to be defined separately.
%\begin{convention}%
Let [S1], [S2] and [S3] be setoids.
%\end{convention}%

First we consider unary functions.  *)

Section CSetoid_functions.
Variables S1 S2 S3 : CSetoid.

Section unary_functions.

(**
In the following two definitions,
[f] is a function from (the carrier of) [S1] to
(the carrier of) [S2].  *)

Variable f : S1 -> S2.

Definition fun_wd : Prop := forall x y : S1, x [=] y -> f x [=] f y.

Definition fun_strext : CProp := forall x y : S1, f x [#] f y -> x [#] y.

Lemma fun_strext_imp_wd : fun_strext -> fun_wd.
Proof.
 intros H x y H0.
 apply not_ap_imp_eq.
 intro H1.
 generalize (H _ _ H1); intro H2.
 now generalize (eq_imp_not_ap _ _ _ H0).
Qed.

End unary_functions.

Record CSetoid_fun : Type :=
  {csf_fun    :> S1 -> S2;
   csf_strext :  fun_strext csf_fun}.

Lemma csf_wd : forall f : CSetoid_fun, fun_wd f.
Proof.
 intro f.
 apply fun_strext_imp_wd.
 apply csf_strext.
Qed.

Lemma csf_wd_unfolded: forall (f : CSetoid_fun) (x y : S1), x[=]y -> f x[=]f y.
Proof csf_wd.

Definition Const_CSetoid_fun : S2 -> CSetoid_fun.
Proof.
 intro c; apply (Build_CSetoid_fun (fun x : S1 => c)); intros x y H.
 elim (ap_irreflexive _ _ H).
Defined.

Section binary_functions.

(**
Now we consider binary functions.
In the following two definitions,
[f] is a function from [S1] and [S2] to [S3].
*)
Variable f : S1 -> S2 -> S3.

Definition bin_fun_wd : Prop := forall x1 x2 y1 y2,
 x1 [=] x2 -> y1 [=] y2 -> f x1 y1 [=] f x2 y2.

Definition bin_fun_strext : CProp := forall x1 x2 y1 y2,
 f x1 y1 [#] f x2 y2 -> x1 [#] x2 or y1 [#] y2.

Lemma bin_fun_strext_imp_wd : bin_fun_strext -> bin_fun_wd.
Proof.
 intros H x1 x2 y1 y2 H0 H1.
 apply not_ap_imp_eq.
 intro H2.
 generalize (H _ _ _ _ H2); intro H3.
 elim H3; intro H4.
  now set (eq_imp_not_ap _ _ _ H0).
 now set (eq_imp_not_ap _ _ _ H1).
Qed.

End binary_functions.

Record CSetoid_bin_fun : Type :=
 {csbf_fun    :> S1 -> S2 -> S3;
  csbf_strext :  bin_fun_strext csbf_fun}.

Lemma csbf_wd : forall f : CSetoid_bin_fun, bin_fun_wd f.
Proof.
 intro f. apply: bin_fun_strext_imp_wd.
 apply csbf_strext.
Qed.

Lemma csbf_wd_unfolded : forall (f : CSetoid_bin_fun) (x x' : S1) (y y' : S2),
 x [=] x' -> y [=] y' -> f x y [=] f x' y'.
Proof csbf_wd.

Lemma csf_strext_unfolded : forall (f : CSetoid_fun) (x y : S1), f x [#] f y -> x [#] y.
Proof csf_strext.

End CSetoid_functions.

Lemma bin_fun_is_wd_fun_lft : forall S1 S2 S3 (f : CSetoid_bin_fun S1 S2 S3) (c : S2),
 fun_wd _ _ (fun x : S1 => f x c).
Proof.
 intros S1 S2 S3 f c x y H.
 now apply csbf_wd; [|apply eq_reflexive].
Qed.

Lemma bin_fun_is_wd_fun_rht : forall S1 S2 S3 (f : CSetoid_bin_fun S1 S2 S3) (c : S1),
 fun_wd _ _ (fun x : S2 => f c x).
Proof.
 intros S1 S2 S3 f c x y H. now apply csbf_wd; [apply eq_reflexive|].
Qed.

Lemma bin_fun_is_strext_fun_lft : forall S1 S2 S3 (f : CSetoid_bin_fun S1 S2 S3) (c : S2),
 fun_strext _ _ (fun x : S1 => f x c).
Proof.
 intros S1 S2 S3 f c x y H. cut (x [#] y or c [#] c). intros [H1|H2];auto.
 now set (ap_irreflexive _ c H2).
 eapply csbf_strext. apply H.
Defined.

Lemma bin_fun_is_strext_fun_rht : forall S1 S2 S3 (f : CSetoid_bin_fun S1 S2 S3) (c : S1),
 fun_strext _ _ (fun x : S2 => f c x).
Proof.
 intros S1 S2 S3 op c x y H. cut (c [#] c or x [#] y). intro Hv. elim Hv. intro Hf.
 generalize (ap_irreflexive _ c Hf). tauto. auto.
   eapply csbf_strext. apply H.
Defined.

Definition bin_fun2fun_rht (S1 S2 S3:CSetoid) (f : CSetoid_bin_fun S1 S2 S3) (c : S1) : CSetoid_fun S2 S3 :=
  Build_CSetoid_fun _ _ (fun x : S2 => f c x) (bin_fun_is_strext_fun_rht _ _ _ f c).

Definition bin_fun2fun_lft (S1 S2 S3:CSetoid) (f : CSetoid_bin_fun S1 S2 S3) (c : S2) : CSetoid_fun S1 S3 :=
  Build_CSetoid_fun _ _ (fun x : S1 => f x c) (bin_fun_is_strext_fun_lft _ _ _ f c).

#[global]
Hint Resolve csf_wd_unfolded csbf_wd_unfolded csf_strext_unfolded: algebra_c.

Arguments fun_wd [S1 S2].
Arguments fun_strext [S1 S2].

(**
** The unary and binary (inner) operations on a csetoid
An operation is a function with domain(s) and co-domain equal.

%\begin{nameconvention}%
The word ``unary operation'' is abbreviated to [un_op];
``binary operation'' is abbreviated to [bin_op].
%\end{nameconvention}%

%\begin{convention}%
Let [S] be a setoid.
%\end{convention}%
*)

Section csetoid_inner_ops.
Variable S : CSetoid.

(** Properties of binary operations *)

Definition commutes (f : S -> S -> S) : Prop := forall x y : S, f x y [=] f y x.

Definition associative (f : S -> S -> S) : Prop := forall x y z : S,
 f x (f y z) [=] f (f x y) z.

(** Well-defined unary operations on a setoid.  *)

Definition un_op_wd := fun_wd (S1:=S) (S2:=S).

Definition un_op_strext := fun_strext (S1:=S) (S2:=S).

Definition CSetoid_un_op  := CSetoid_fun S S.

Definition Build_CSetoid_un_op := Build_CSetoid_fun S S.

Lemma id_strext : un_op_strext (fun x : S => x).
Proof. now repeat intro. Qed.

Lemma id_pres_eq : un_op_wd (fun x : S => x).
Proof. now repeat intro. Qed.

Definition id_un_op := Build_CSetoid_un_op (fun x : S => x) id_strext.

(* begin hide *)
Identity Coercion un_op_fun : CSetoid_un_op >-> CSetoid_fun.
(* end hide *)

Definition cs_un_op_strext := csf_strext S S.

(** Well-defined binary operations on a setoid.  *)

Definition bin_op_wd := bin_fun_wd S S S.
Definition bin_op_strext := bin_fun_strext S S S.

Definition CSetoid_bin_op : Type := CSetoid_bin_fun S S S.
Definition Build_CSetoid_bin_op := Build_CSetoid_bin_fun S S S.

Definition cs_bin_op_wd := csbf_wd S S S.
Definition cs_bin_op_strext := csbf_strext S S S.

(* begin hide *)
Identity Coercion bin_op_bin_fun : CSetoid_bin_op >-> CSetoid_bin_fun.
(* end hide *)

Lemma bin_op_is_wd_un_op_lft : forall (op : CSetoid_bin_op) (c : S),
 un_op_wd (fun x : S => op x c).
Proof.
 apply bin_fun_is_wd_fun_lft.
Qed.

Lemma bin_op_is_wd_un_op_rht : forall (op : CSetoid_bin_op) (c : S),
 un_op_wd (fun x : S => op c x).
Proof.
 apply bin_fun_is_wd_fun_rht.
Qed.

Lemma bin_op_is_strext_un_op_lft : forall (op : CSetoid_bin_op) (c : S),
 un_op_strext (fun x : S => op x c).
Proof. apply bin_fun_is_strext_fun_lft. Defined.

Lemma bin_op_is_strext_un_op_rht : forall (op : CSetoid_bin_op) (c : S),
 un_op_strext (fun x : S => op c x).
Proof. apply bin_fun_is_strext_fun_rht. Defined.

Definition bin_op2un_op_rht (op : CSetoid_bin_op) (c : S) : CSetoid_un_op :=
  bin_fun2fun_rht _ _ _ op c.

Definition bin_op2un_op_lft (op : CSetoid_bin_op) (c : S) : CSetoid_un_op :=
  bin_fun2fun_lft _ _ _ op c.

Lemma un_op_wd_unfolded : forall (op : CSetoid_un_op) (x y : S),
 x [=] y -> op x [=] op y.
Proof csf_wd S S.

Lemma un_op_strext_unfolded : forall (op : CSetoid_un_op) (x y : S),
 op x [#] op y -> x [#] y.
Proof cs_un_op_strext.

Lemma bin_op_wd_unfolded : forall (op : CSetoid_bin_op) (x1 x2 y1 y2 : S),
 x1 [=] x2 -> y1 [=] y2 -> op x1 y1 [=] op x2 y2.
Proof cs_bin_op_wd.

Lemma bin_op_strext_unfolded : forall (op : CSetoid_bin_op) (x1 x2 y1 y2 : S),
 op x1 y1 [#] op x2 y2 -> x1 [#] x2 or y1 [#] y2.
Proof cs_bin_op_strext.

End csetoid_inner_ops.

Arguments commutes [S].
Arguments associative [S].

(* Needs to be unfolded to be used as a Hint *)
#[global]
Hint Resolve ap_wdr_unfolded ap_wdl_unfolded  bin_op_wd_unfolded un_op_wd_unfolded : algebra_c.

(**
** The binary outer operations on a csetoid
%\begin{convention}%
Let [S1] and [S2] be setoids.
%\end{convention}%
*)

Section csetoid_outer_ops.
Variables S1 S2 : CSetoid.

(**
Well-defined outer operations on a setoid.
*)
Definition outer_op_well_def := bin_fun_wd S1 S2 S2.
Definition outer_op_strext := bin_fun_strext S1 S2 S2.

Definition CSetoid_outer_op : Type := CSetoid_bin_fun S1 S2 S2.
Definition Build_CSetoid_outer_op := Build_CSetoid_bin_fun S1 S2 S2.
Definition csoo_wd := csbf_wd S1 S2 S2.
Definition csoo_strext := csbf_strext S1 S2 S2.
Lemma csoo_wd_unfolded : forall (op : CSetoid_outer_op) x1 x2 y1 y2,
 x1 [=] x2 -> y1 [=] y2 -> op x1 y1 [=] op x2 y2.
Proof csoo_wd.

(* begin hide *)
Identity Coercion outer_op_bin_fun : CSetoid_outer_op >-> CSetoid_bin_fun.
(* end hide *)

End csetoid_outer_ops.
#[global]
Hint Resolve csoo_wd_unfolded: algebra_c.

(**
** Subsetoids
%\begin{convention}%
Let [S] be a setoid, and [P] a predicate on the carrier of [S].
%\end{convention}%
*)

Section SubCSetoids.
Variable S : CSetoid.
Variable P : S -> CProp.

Record subcsetoid_crr : Type :=
 {scs_elem :> S;
  scs_prf  :  P scs_elem}.

(** Though [scs_elem] is declared as a coercion, it does not satisfy the
uniform inheritance condition and will not be inserted.  However it will
also not be printed, which is handy.
*)

Definition restrict_relation (R : Relation S) : Relation subcsetoid_crr :=
  fun a b : subcsetoid_crr =>
  match a, b with
  | Build_subcsetoid_crr x _, Build_subcsetoid_crr y _ => R x y
  end.

Definition Crestrict_relation (R : Crelation S) : Crelation subcsetoid_crr :=
  fun a b : subcsetoid_crr =>
  match a, b with
  | Build_subcsetoid_crr x _, Build_subcsetoid_crr y _ => R x y
  end.

Definition subcsetoid_eq : Relation subcsetoid_crr :=
  restrict_relation (cs_eq (r:=S)).

Definition subcsetoid_ap : Crelation subcsetoid_crr :=
  Crestrict_relation (cs_ap (c:=S)).

Remark subcsetoid_equiv : Tequiv _ subcsetoid_eq.
Proof.
 split.
  (* reflexive *)
  intros a; case a.
  intros x s. apply (eq_reflexive S).
  (* transitive *)
  split.
  intros a b c; case a.
  intros x s; case b.
  intros y t; case c.
  intros z u. apply eq_transitive.
  (* symmetric *)
  intros a b; case a.
 intros x s; case b.
 intros y t. apply eq_symmetric.
Qed.

Lemma subcsetoid_is_CSetoid : is_CSetoid _ subcsetoid_eq subcsetoid_ap.
Proof.
 apply (Build_is_CSetoid _ subcsetoid_eq subcsetoid_ap).
    (* irreflexive *)
    intro x. case x. intros. apply ap_irreflexive.
    (* symmetric *)
    intros x y. case x. case y. intros.
   exact (ap_symmetric S _ _ X).
  (* cotransitive *)
  intros x y. case x. case y. intros; case z. intros.
  exact (ap_cotransitive S _ _ X scs_elem2).
 (* tight *)
 intros x y. case x. case y. intros.
 exact (ap_tight S scs_elem1 scs_elem0).
Qed.

Definition Build_SubCSetoid : CSetoid := Build_CSetoid
 subcsetoid_crr subcsetoid_eq subcsetoid_ap subcsetoid_is_CSetoid.

(**
*** Subsetoid unary operations
%\begin{convention}%
Let [f] be a unary setoid operation on [S].
%\end{convention}%
*)

Section SubCSetoid_unary_operations.
Variable f : CSetoid_un_op S.
Definition un_op_pres_pred : CProp := forall x : S, P x -> P (f x).

(**
%\begin{convention}%
Assume [pr:un_op_pres_pred].
%\end{convention}% *)

Variable pr : un_op_pres_pred.

Definition restr_un_op (a : subcsetoid_crr) : subcsetoid_crr :=
  match a with
  | Build_subcsetoid_crr x p => Build_subcsetoid_crr (f x) (pr x p)
  end.

Lemma restr_un_op_wd : un_op_wd Build_SubCSetoid restr_un_op.
Proof.
 intros x y. case y. case x. intros. now apply: (csf_wd _ _ f).
Qed.

Lemma restr_un_op_strext : un_op_strext Build_SubCSetoid restr_un_op.
Proof.
 intros x y. case y. case x. intros. exact (cs_un_op_strext _ f _ _ X).
Qed.

Definition Build_SubCSetoid_un_op : CSetoid_un_op Build_SubCSetoid :=
  Build_CSetoid_un_op Build_SubCSetoid restr_un_op restr_un_op_strext.

End SubCSetoid_unary_operations.

(**
*** Subsetoid binary operations
%\begin{convention}%
Let [f] be a binary setoid operation on [S].
%\end{convention}%
*)

Section SubCSetoid_binary_operations.

Variable f : CSetoid_bin_op S.

Definition bin_op_pres_pred : CProp := forall x y : S, P x -> P y -> P (f x y).

(**
%\begin{convention}%
Assume [bin_op_pres_pred].
%\end{convention}%
*)

Variable pr : bin_op_pres_pred.

Definition restr_bin_op (a b : subcsetoid_crr) : subcsetoid_crr :=
  match a, b with
  | Build_subcsetoid_crr x p, Build_subcsetoid_crr y q =>
      Build_subcsetoid_crr (f x y) (pr x y p q)
  end.

Lemma restr_bin_op_well_def : bin_op_wd Build_SubCSetoid restr_bin_op.
Proof.
 intros x1 x2 y1 y2. case y2. case y1. case x2. case x1. intros.
 exact (cs_bin_op_wd _ f _ _ _ _ H H0).
Qed.

Lemma restr_bin_op_strext : bin_op_strext Build_SubCSetoid restr_bin_op.
Proof.
 intros x1 x2 y1 y2. case y2. case y1. case x2. case x1. intros.
 exact (cs_bin_op_strext _ f _ _ _ _ X).
Qed.

Definition Build_SubCSetoid_bin_op : CSetoid_bin_op Build_SubCSetoid :=
  Build_CSetoid_bin_op Build_SubCSetoid restr_bin_op restr_bin_op_strext.

Lemma restr_f_assoc : associative f -> associative Build_SubCSetoid_bin_op.
Proof.
 intros assf x y z. case z. case y. case x. intros. apply: assf.
Qed.

End SubCSetoid_binary_operations.

End SubCSetoids.

(* begin hide *)
Ltac Step_final x := apply eq_transitive with x; algebra.
(* end hide *)

Tactic Notation "Step_final" constr(c) :=  Step_final c.

(**
** Miscellaneous
*)

Lemma proper_caseZ_diff_CS : forall (S : CSetoid) (f : nat -> nat -> S),
 (forall m n p q : nat, m + q = n + p -> f m n [=] f p q) ->
 forall m n : nat, caseZ_diff (m - n) f [=] f m n.
Proof.
 intro CS. intros.
 pattern m, n in |- *.
 apply nat_double_ind.
   intro. replace (0%nat - n0)%Z with (- n0)%Z;auto. rewrite caseZ_diff_Neg; reflexivity.
   intros. replace (S n0 - 0%nat)%Z with (S n0:Z);auto. rewrite caseZ_diff_Pos; reflexivity.
  intros. generalize (H (S n0) (S m0) n0 m0); intro.
 cut (S n0 + m0 = S m0 + n0).
  intro. generalize (H1 H2); intro.
  apply eq_transitive with (f n0 m0).
   apply eq_transitive with (caseZ_diff (n0 - m0) f);auto.
   replace (S n0 - S m0)%Z with (n0 - m0)%Z.
    apply eq_reflexive.
   repeat rewrite Znat.inj_S; clear H1; auto with zarith.
  now apply eq_symmetric.
 clear H1; auto with zarith.
Qed.

(**
Finally, we characterize functions defined on the natural numbers also as setoid functions, similarly to what we already did for predicates.
*)

Definition nat_less_n_fun (S : CSetoid) (n : nat) (f : forall i : nat, i < n -> S) :=
  forall i j : nat, i = j -> forall (H : i < n) (H' : j < n), f i H [=] f j H'.

Definition nat_less_n_fun' (S : CSetoid) (n : nat) (f : forall i : nat, i <= n -> S) :=
  forall i j : nat, i = j -> forall (H : i <= n) (H' : j <= n), f i H [=] f j H'.

Arguments nat_less_n_fun [S n].
Arguments nat_less_n_fun' [S n].

Add Parametric Relation c : (cs_crr c) (@cs_eq c)
  reflexivity proved by (eq_reflexive c)
  symmetry proved by (eq_symmetric c)
  transitivity proved by (eq_transitive c)
  as CSetoid_eq_Setoid.

Add Parametric Morphism (c1 c2 c3 : CSetoid) f: (csbf_fun c1 c2 c3 f) with signature (@cs_eq c1) ==> (@cs_eq c2) ==> (@cs_eq c3) as csbf_fun_wd.
Proof.
 intros x1 x2 Hx y1 y2 Hy.
 now apply csbf_wd.
Qed.

Add Parametric Morphism (c1 c2 : CSetoid) f: (@csf_fun c1 c2 f) with signature (@cs_eq c1) ==> (@cs_eq c2) as csf_fun_wd.
Proof.
 intros x1 x2 Hx.
 now apply csf_wd.
Qed.


Require Import Coq.Lists.List.
Open Scope list_scope.
Import ListNotations.
Require Import Coq.Program.Equality.
Require Import Resources.utility.
Require Import Resources.name.
Require Import Resources.type.
Require Import Resources.value.
Require Import Resources.memory.
Require Import Resources.instr.
Require Import Resources.small_step.

Definition stack_tag_u (s : LocalStack) : Prop := ∀ t (p1 p2 : lstack_contains_t s t), p1 = p2.

Definition mem_tag_u (m : Memory) : Prop := ∀ t (p1 p2 : mem_contains_t m t), p1 = p2.

Definition stack_mem_disjoint_tag m s : Prop :=
  (∀ t, mem_contains_t m t → notT (lstack_contains_t s t)) ∧
  (∀ t, lstack_contains_t s t → notT (mem_contains_t m t)).

Definition tag_uniq s : Set :=
  mem_tag_u s.(mem) ∧
  stack_tag_u s.(stack) ∧
  stack_mem_disjoint_tag s.(mem) s.(stack).

Definition state_tag_u (s : state) : Prop := ∀ t (p1 p2: state_contains_t s t), p1 = p2.

Definition inject {A B} (f : A -> B) := (∀ x y, f x = f y -> x = y).

Ltac prove_inj := let h := fresh "Heq" in let x := fresh "x" in let y := fresh "y" in
  intros x y h; injection h; auto.

Ltac inject f := let hn := fresh "f_inj" in
  enough (∀ x y, f x = f y → x = y) as f_inj; try (eapply f_inj) || prove_inj.

Ltac inject1 f h :=
  enough (∀ x y, f x = f y → x = y) as h; try (eapply h) || prove_inj.

Lemma state_tag_u_implies_mem_tag_u : ∀ s, state_tag_u s → mem_tag_u s.(mem).
Proof.
  intros s Hs t p1 p2.
  inject (@ inl (mem_contains_t s.(mem) t) (lstack_contains_t s.(stack) t)).
  apply Hs.
Qed.

Lemma state_tag_u_implies_stack_tag_u : ∀ s, state_tag_u s → stack_tag_u s.(stack).
Proof.
  intros s Hs t p1 p2.
  inject (@ inr (mem_contains_t s.(mem) t) (lstack_contains_t s.(stack) t)).
  apply Hs.
Qed.

Lemma state_tag_u_implies_disjoint : ∀ s, state_tag_u s → stack_mem_disjoint_tag s.(mem) s.(stack).
Proof.
  intros s Hs.
  split.
  + intros t Hm contra.
    remember (inl Hm : state_contains_t s t) as q1 eqn:Hq1.
    remember (inr contra : state_contains_t s t) as q2 eqn:Hq2.
    unfold state_tag_u in Hs.
    specialize Hs with t q1 q2.
    subst.
    inversion Hq2.
  + intros t Hm contra.
    remember (inr Hm : state_contains_t s t) as q1 eqn:Hq1.
    remember (inl contra : state_contains_t s t) as q2 eqn:Hq2.
    unfold state_tag_u in Hs.
    specialize Hs with t q1 q2.
    subst.
    inversion Hq2.
Qed.

Lemma state_tag_u_implies_tag_uniq : ∀ s, state_tag_u s → tag_uniq s.
Proof.
  intros s Hs.
  split.
  + apply state_tag_u_implies_mem_tag_u; assumption.
  + split.
    ++ apply state_tag_u_implies_stack_tag_u; assumption.
    ++ apply state_tag_u_implies_disjoint; assumption.
Qed.

Lemma tag_uniq_implies_state_tag_u : ∀ s, tag_uniq s → state_tag_u s.
Proof.
  intros s Hs t p1 p2.
  destruct Hs as [Hm [Hs Hd]].
  dependent destruction p1; dependent destruction p2.
  + apply f_equal.
    apply Hm.
  + exfalso.
    eapply Hd; eauto.
  + exfalso.
    eapply Hd; eauto.
  + apply f_equal.
    apply Hs.
Qed.

Lemma stack_contains_t_cons_u : ∀ (u : UnrestrictedValue) s t,
  lstack_contains_t (val u :: s) t →
  lstack_contains_t s t.
Proof.
  intros.
  inversion H.
  assumption.
Defined.

Proposition step_preserve_stack_tag_u :
∀ (s0 s1 : state),
tag_uniq s0 →
step s0 s1 →
stack_tag_u s1.(stack).
Proof.
  intros s0 s1 [Hm [Hu Hd]] Hs.
  destruct Hs as [i Hs].
  unfold stack_tag_u in *.
  inversion Hs.
  + destruct v.
    ++ destruct v.
      {
        intros.
        dependent destruction p1; dependent destruction p2.
        + apply f_equal.
          inject (local_mem_contains_tc s0.(mem).(local) x r H4 t).
          inject1 (local_mem_ct (mem s0) t) f_inj1.
          apply Hm.
          {
            intros.
            dependent destruction Heq.
            reflexivity.
          }
          {
            intros.
            dependent destruction Heq.
            reflexivity.
          }
        + admit.
        + admit.
        + specialize Hu with t p1 p2.
          rewrite Hu.
          reflexivity.
      }
      {
        intros.
        dependent destruction p1.
        dependent destruction p2.
        specialize Hu with t p1 p2.
        rewrite Hu.
        reflexivity.
      }
    (* x -> ref *)
    ++ intros.
      dependent destruction p1.
      dependent destruction p2.
      specialize Hu with t p1 p2.
      rewrite Hu.
      reflexivity.
  + intros.
    dependent destruction p1.
    dependent destruction p2.
    specialize Hu with t p1 p2.
    rewrite Hu.
    reflexivity.
Admitted.

Proposition step_preserve_mem_tag_u :
∀ (s0 s1 : state),
tag_uniq s0 →
step s0 s1 →
mem_tag_u s1.(mem).
Proof.
  intros s0 s1 [H1 [H2 H3]] Hs.
  destruct Hs as [i Hs].
  inversion Hs; subst.
  + admit.
  + unfold mem_tag_u in *.
    destruct H3.
    assumption.
Admitted.

Proposition step_preserve_stack_mem_disjoint :
∀ (s0 s1 : state),
tag_uniq s0 →
step s0 s1 →
stack_mem_disjoint_tag s1.(mem) s1.(stack).
Proof.
  intros s0 s1 [_ [_ Hs0]] Hs1.
  destruct Hs1 as [i Hs1].
  inversion Hs1; subst.
  + admit.
  + unfold stack_mem_disjoint_tag in *.
    destruct Hs0 as [Hs0 H5].
    split.
    ++ intros t t_in_s0_mem.
      apply Hs0 in t_in_s0_mem.
      intro contra.
      apply stack_contains_t_cons_u in contra.
      contradiction.
    ++ intros t t_in_s1_stack.
      apply stack_contains_t_cons_u in t_in_s1_stack.
      auto.
Admitted.

Proposition step_preserve_tag_u :
∀ (s0 s1 : state),
tag_uniq s0 →
step s0 s1 →
tag_uniq s1.
Proof.
  intros.
  split.
  + apply step_preserve_mem_tag_u with (s0:=s0); assumption.
  + split.
    ++ apply step_preserve_stack_tag_u with (s0:=s0); assumption.
    ++ apply step_preserve_stack_mem_disjoint with (s0:=s0); assumption.
Qed.

Definition conserve_t {s0} {s1} (_ : step s0 s1) : Type :=
  (∀ t, state_contains_t s0 t → state_contains_t s1 t) *
  (∀ t, state_contains_t s1 t → state_contains_t s0 t).

Definition introduce_t {s0} {s1} (_ : step s0 s1) t : Type :=
  (∀ t, state_contains_t s0 t → state_contains_t s1 t) *
  notT (state_contains_t s0 t) *
  state_contains_t s1 t *
  (∀ t', state_contains_t s1 t' * notT (state_contains_t s0 t') → t' = t).

Definition elim_t {s0} {s1} (_ : step s0 s1) t : Type :=
  (∀ t, state_contains_t s1 t → state_contains_t s0 t) *
  notT (state_contains_t s1 t) *
  state_contains_t s0 t *
  (∀ t', state_contains_t s0 t' * notT (state_contains_t s1 t') → t' = t).

Lemma conserve_t_not_intro : ∀ {s0 s1} (Hs : step s0 s1),
  conserve_t Hs → ∀ t, notT (introduce_t Hs t).
Proof.
  intros s0 s1 Hs Hc t contra.
  destruct Hc as [Hc1 Hc2].
  destruct contra as [[[c1 c2] c3] c4].
  apply Hc2 in c3.
  apply c2 in c3.
  contradiction.
Qed.

Lemma conserve_t_not_elim : ∀ {s0 s1} (Hs : step s0 s1),
  conserve_t Hs → ∀ t, notT (elim_t Hs t).
Proof.
  intros s0 s1 Hs Hc t contra.
  destruct Hc as [Hc1 Hc2].
  destruct contra as [[[c1 c2] c3] c4].
  apply Hc1 in c3.
  apply c2 in c3.
  contradiction.
Qed.

Lemma introduce_t_not_conserved : ∀ {s0 s1} (Hs : step s0 s1) {t},
introduce_t Hs t → notT (conserve_t Hs).
Proof.
  intros s0 s1 Hs t Hi Hc.
  destruct Hi as [[[Hi1 Hi2] Hi3] Hi4].
  destruct Hc as [Hc1 Hc2].
  apply Hc2 in Hi3.
  apply Hi2 in Hi3.
  contradiction.
Qed.

Lemma introduce_t_not_elim_t : ∀ {s0 s1} (Hs : step s0 s1) {t},
introduce_t Hs t → ∀ t, notT (elim_t Hs t).
Proof.
  intros s0 s1 Hs t1 Hi t2 He.
  destruct Hi as [[[Hi1 Hi2] Hi3] Hi4].
  destruct He as [[[He1 He2] He3] He4].
  apply Hi1 in He3.
  contradiction.
Qed.

Lemma elim_t_not_conserved : ∀ {s0 s1} (Hs : step s0 s1) {t},
elim_t Hs t → notT (conserve_t Hs).
Proof.
  intros s0 s1 Hs t He Hc.
  destruct He as [[[He1 He2] He3] He4].
  destruct Hc as [Hc1 Hc2].
  apply Hc1 in He3.
  contradiction.
Qed.

Lemma elim_t_not_elim_t : ∀ {s0 s1} (Hs : step s0 s1) {t},
elim_t Hs t → ∀ t, notT (introduce_t Hs t).
Proof.
  intros s0 s1 Hs t1 He t2 Hi.
  destruct Hi as [[[Hi1 Hi2] Hi3] Hi4].
  destruct He as [[[He1 He2] He3] He4].
  apply He1 in Hi3.
  contradiction.
Qed.

Theorem local_resource_safety : ∀ {s0 s1} (Hs : step s0 s1),
conserve_t Hs +
{ t & introduce_t Hs t} +
{ t & elim_t Hs t}.
Proof.
  intros s0 s1 Hs.
  destruct Hs as [i Hs].
  inversion Hs; subst.
  + admit.
  + left. left.
    split.
    ++ intros t t_in_s0.
      destruct t_in_s0.
      {
        left.
        rewrite H in m.
        assumption.
      }
      {
        right.
        rewrite <- H3.
        apply lstackt_cdr.
        assumption.
      }
    ++ intros t t_in_s1.
      destruct t_in_s1.
      {
        left.
        rewrite H.
        assumption.
      }
      {
        rewrite <- H3 in l.
        apply stack_contains_t_cons_u in l.
        right.
        assumption.
      }
  (* StLoc *)
  + left. left. (* prove resource conservation *)
    split.
    (* tag s0 ⊆ tag s1 *)
    ++ intros t t_in_s0.
      destruct t_in_s0.
      (* t in memory of s0 *)
      {
        destruct m.
        (* t in local memory *)
        + left.
          apply local_mem_ct.
          rewrite <- H1.
          apply mem_update_local_u1.
          assumption.
        (* t in global memory *)
        + left.
          apply global_mem_ct.
          rewrite <- H1.
          apply mem_update_local_global_const1.
          assumption.
      }
      (* t in stack of s0 *)
      {
        right.
        rewrite <- H in l.
        apply stack_contains_t_cons_u in l.
        assumption.
      }
    (* tag s1 ⊆ tag s0 *)
    ++ intros t t_in_s1.
      destruct t_in_s1.
      {
        destruct m.
        + left.
          apply local_mem_ct.
          rewrite <- H1 in l.
          apply mem_update_local_u2 in l.
          assumption.
        + left.
          apply global_mem_ct.
          rewrite <- H1 in g.
          apply mem_update_local_global_const2 in g.
          assumption.
      }
      {
        right.
        rewrite <- H.
        apply lstackt_cdr.
        assumption.
      }
  +
Admitted.

Open Scope type_scope.
Theorem only_pack_intro_r : ∀ {s0 s1} (Hs : step s0 s1) {t}
(Hi : introduce_t Hs t),
{ τ & instr_of_step Hs = (Pack τ) } +
{r & { S & (val (resourceValue r) :: S = s1.(stack)) * (tag_of r = t) }}.
Proof.
Admitted.

Theorem only_unpack_elim_t : ∀ {s0 s1} (Hs : step s0 s1) {t}
(Hi : elim_t Hs t),
(instr_of_step Hs = Unpack) +
{ r & { S & (val (resourceValue r) :: S = s0.(stack)) * (tag_of r = t) }}.
Proof.
Admitted.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

Require Export Pmults.
Require Import Arith.
Section Pminus.
Load "hCoefStructure".
Load "hOrderStructure".
Load "hMults".

Inductive minusP :
list (Term A n) -> list (Term A n) -> list (Term A n) -> Prop :=
  | mnillu1 :
      forall l1 : list (Term A n),
      minusP (pO A n) l1
        (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) l1)
  | mnillu2 : forall l1 : list (Term A n), minusP l1 (pO A n) l1
  | mmainu1 :
      forall (a1 a2 : Term A n) (l1 l2 l3 : list (Term A n)),
      ltT ltM a2 a1 ->
      minusP l1 (pX a2 l2) l3 -> minusP (pX a1 l1) (pX a2 l2) (pX a1 l3)
  | mmainu2a :
      forall (a1 a2 : Term A n) (l1 l2 l3 : list (Term A n)),
      minusP l1 l2 l3 ->
      eqT a1 a2 ->
      zeroP (A:=A) A0 eqA (n:=n) (minusTerm (A:=A) minusA (n:=n) a1 a2) ->
      minusP (pX a1 l1) (pX a2 l2) l3
  | mmainu2b :
      forall (a1 a2 : Term A n) (l1 l2 l3 : list (Term A n)),
      minusP l1 l2 l3 ->
      eqT a1 a2 ->
      ~ zeroP (A:=A) A0 eqA (n:=n) (minusTerm (A:=A) minusA (n:=n) a1 a2) ->
      minusP (pX a1 l1) (pX a2 l2)
        (pX (minusTerm (A:=A) minusA (n:=n) a1 a2) l3)
  | mmainu3 :
      forall (a1 a2 : Term A n) (l1 l2 l3 : list (Term A n)),
      ltT ltM a1 a2 ->
      minusP (pX a1 l1) l2 l3 ->
      minusP (pX a1 l1) (pX a2 l2) (pX (invTerm (A:=A) invA (n:=n) a2) l3).
Hint Resolve mnillu1 mnillu2 mmainu1 mmainu2a mmainu2b mmainu3.
Require Import LetP.

Definition minuspp :
  forall l : list (Term A n) * list (Term A n),
  {a : list (Term A n) | minusP (fst l) (snd l) a}.
intros l; pattern l in |- *.
apply
 well_founded_induction
  with (A := (list (Term A n) * list (Term A n))%type) (R := lessP A n);
 auto.
apply wf_lessP; auto.
intros x; case x; intros l1 l2; simpl in |- *.
case l1.
intros H';
 exists (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) l2);
 auto.
intros a1 m1; case l2.
intros H'; exists (pX a1 m1); auto.
intros a2 m2 H'; case (ltT_dec A n ltM ltM_dec a1 a2);
 [ intros P; case P; clear P | idtac ]; intros H1.
lapply (H' (pX a1 m1, m2)); simpl in |- *;
 [ intros Rec; case Rec; clear Rec; intros Orec Prec | idtac ].
exists (pX (invTerm (A:=A) invA (n:=n) a2) Orec); auto.
change
  (minusP (pX a1 m1) (pX a2 m2) (pX (invTerm (A:=A) invA (n:=n) a2) Orec))
 in |- *; auto.
red in |- *; red in |- *; simpl in |- *; rewrite <- plus_n_Sm; auto.
lapply (H' (m1, pX a2 m2)); simpl in |- *;
 [ intros Rec; case Rec; clear Rec; intros Orec Prec | idtac ].
exists (pX a1 Orec); auto.
change (minusP (pX a1 m1) (pX a2 m2) (pX a1 Orec)) in |- *; auto.
red in |- *; red in |- *; simpl in |- *; rewrite <- plus_n_Sm; auto.
lapply (H' (m1, m2)); simpl in |- *;
 [ intros Rec; case Rec; clear Rec; intros Orec Prec | idtac ].
apply LetP with (A := Term A n) (h := minusTerm (A:=A) minusA (n:=n) a1 a2).
intros u H'0; case (zeroP_dec A A0 eqA eqA_dec n u); intros Z0.
exists Orec; auto.
rewrite H'0 in Z0; auto.
change (minusP (pX a1 m1) (pX a2 m2) Orec) in |- *; auto.
exists (pX u Orec); auto.
rewrite H'0 in Z0; auto.
rewrite H'0; auto.
change
  (minusP (pX a1 m1) (pX a2 m2)
     (pX (minusTerm (A:=A) minusA (n:=n) a1 a2) Orec))
 in |- *; auto.
red in |- *; red in |- *; simpl in |- *; rewrite <- plus_n_Sm; auto.
Defined.

Definition minuspf (l1 l2 : list (Term A n)) :=
  projsig1 (list (Term A n)) _ (minuspp (l1, l2)).

Theorem zerop_is_eqTerm :
 forall a b : Term A n,
 eqT a b ->
 zeroP (A:=A) A0 eqA (n:=n) (minusTerm (A:=A) minusA (n:=n) a b) ->
 eqTerm (A:=A) eqA (n:=n) a b.
intros a b H' H'0.
cut (eqT a (invTerm (A:=A) invA (n:=n) b)); [ intros eq1 | idtac ].
cut (eqT a (plusTerm (A:=A) plusA (n:=n) b (invTerm (A:=A) invA (n:=n) b)));
 [ intros eq2 | idtac ].
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := plusTerm (A:=A) plusA (n:=n) a
            (plusTerm (A:=A) plusA (n:=n) b (invTerm (A:=A) invA (n:=n) b)));
 auto.
apply zeroP_plusTermr with (1 := cs); auto.
apply plusTerm_invTerm_zeroP with (1 := cs); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := plusTerm (A:=A) plusA (n:=n) a
            (plusTerm (A:=A) plusA (n:=n) (invTerm (A:=A) invA (n:=n) b) b));
 auto.
apply plusTerm_comp_r with (1 := cs); auto.
apply (eqT_trans A n) with (plusTerm plusA b (invTerm invA b)); auto.
apply (eqTerm_imp_eqT A eqA); auto.
apply plusTerm_com with (1 := cs); auto.
apply plusTerm_com with (1 := cs); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := plusTerm (A:=A) plusA (n:=n)
            (plusTerm (A:=A) plusA (n:=n) a (invTerm (A:=A) invA (n:=n) b)) b);
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply plusTerm_assoc with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply zeroP_plusTerml with (1 := cs); auto.
apply (eqT_trans A n) with (invTerm invA b); auto.
apply plusTerm_eqT2; auto.
apply (eqT_sym A n); apply invTerm_eqT; auto.
apply zeroP_comp_eqTerm with (1 := cs) (2 := H'0).
apply eqTerm_minusTerm_plusTerm_invTerm with (1 := cs); auto.
apply (eqT_trans A n) with (1 := eq1); auto.
apply (eqT_sym A n); apply plusTerm_eqT2; auto.
apply (eqT_trans A n) with (1 := H'); auto.
Qed.
Hint Unfold minuspf.

Theorem minusTerm_zeroP_r :
 forall a b : Term A n,
 zeroP (A:=A) A0 eqA (n:=n) a ->
 eqT a b ->
 eqTerm (A:=A) eqA (n:=n) (minusTerm (A:=A) minusA (n:=n) a b)
   (invTerm (A:=A) invA (n:=n) b).
intros a b H' H0;
 apply
  (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
   with (y := plusTerm (A:=A) plusA (n:=n) a (invTerm (A:=A) invA (n:=n) b));
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply zeroP_plusTerml with (1 := cs); auto.
apply (eqT_trans A n) with (y := b); auto.
Qed.

Theorem minusTerm_zeroP :
 forall a b : Term A n,
 eqT a b ->
 zeroP (A:=A) A0 eqA (n:=n) b ->
 eqTerm (A:=A) eqA (n:=n) (minusTerm (A:=A) minusA (n:=n) a b) a.
intros a b H' H'0.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := plusTerm (A:=A) plusA (n:=n) a (invTerm (A:=A) invA (n:=n) b));
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply zeroP_plusTermr with (1 := cs); auto.
apply (eqT_trans A n) with (y := b); auto.
apply zeroP_invTerm_zeroP with (1 := cs); auto.
Qed.
Hint Resolve minusTerm_zeroP minusTerm_zeroP_r.

Theorem minusP_pO_is_eqP :
 forall p q r : list (Term A n),
 minusP p q r -> eqP A eqA n r (pO A n) -> eqP A eqA n p q.
intros p q r H'; elim H'; auto.
intros l1; case l1; simpl in |- *; auto.
intros t l H; inversion H.
intros a1 a2 l1 l2 l3 H H0 H1 H2; inversion H2.
intros a1 a2 l1 l2 l3 H H0 H1 H2 H3.
apply eqpP1; auto.
apply zerop_is_eqTerm; auto.
intros a1 a2 l1 l2 l3 H H0 H1 H2 H3; inversion H3.
intros a1 a2 l1 l2 l3 H H0 H1 H2; inversion H2.
Qed.

Lemma minusP_inv :
 forall (p q l : list (Term A n)) (a b : Term A n),
 minusP (pX a p) (pX b q) l ->
 exists l1 : list (Term A n),
   ltT ltM b a /\ minusP p (pX b q) l1 /\ l = pX a l1 \/
   ltT ltM a b /\
   minusP (pX a p) q l1 /\ l = pX (invTerm (A:=A) invA (n:=n) b) l1 \/
   eqT a b /\
   (zeroP (A:=A) A0 eqA (n:=n) (minusTerm (A:=A) minusA (n:=n) a b) /\
    minusP p q l \/
    ~ zeroP (A:=A) A0 eqA (n:=n) (minusTerm (A:=A) minusA (n:=n) a b) /\
    minusP p q l1 /\ l = pX (minusTerm (A:=A) minusA (n:=n) a b) l1).
intros p q l a b H'; simple inversion H'.
discriminate H.
discriminate H0.
rewrite <- H3; rewrite (pX_invl A n a2 b l2 q H2);
 rewrite (pX_invr A n l2 q a2 b H2); rewrite (pX_invl A n a1 a l1 p H1);
 rewrite (pX_invr A n l1 p a1 a H1).
intros H'0 H'1; exists l3; left; split; [ idtac | split ]; auto.
rewrite <- H4.
intros H'0 H'1 H'2; exists l3; right; right.
rewrite <- (pX_invl A n a2 b l2 q); try rewrite <- (pX_invl A n a1 a l1 p);
 auto.
rewrite <- (pX_invr A n l2 q a2 b); try rewrite <- (pX_invr A n l1 p a1 a);
 auto.
intros H'0 H'1 H'2; exists l3; right; right.
rewrite <- H4.
rewrite <- (pX_invl A n a2 b l2 q); try rewrite <- (pX_invl A n a1 a l1 p);
 auto.
rewrite <- (pX_invr A n l2 q a2 b); try rewrite <- (pX_invr A n l1 p a1 a);
 auto.
intros H'0 H'1; exists l3; right; left.
rewrite <- (pX_invl A n a2 b l2 q); try rewrite <- (pX_invl A n a1 a l1 p);
 auto.
rewrite <- (pX_invr A n l2 q a2 b); try rewrite <- (pX_invr A n l1 p a1 a);
 auto.
Qed.

Theorem uniq_minusp :
 forall (l : list (Term A n) * list (Term A n)) (l3 l4 : list (Term A n)),
 minusP (fst l) (snd l) l3 -> minusP (fst l) (snd l) l4 -> l3 = l4.
unfold pX, pX in |- *.
intros l; pattern l in |- *.
apply well_founded_ind with (1 := wf_lessP A n).
intros (l1, l2); simpl in |- *.
case l1; clear l1.
intros H' l3 l4 H'0; inversion_clear H'0; intros H'2; inversion_clear H'2;
 auto.
case l2; clear l2.
simpl in |- *; intros n0 l0 H' l3 l4 H'0 H'2.
inversion H'2; inversion H'0; auto.
simpl in |- *; intros n2 l2 n1 l1 Induc l3 l4 Hl3 Hl4.
case (minusP_inv l1 l2 l4 n1 n2); auto.
intros x H'; elim H'; intros H'0; [ idtac | elim H'0; clear H'0; intros H'0 ];
 clear H';
 (case (minusP_inv l1 l2 l3 n1 n2); auto; intros x1 H'; elim H'; intros H'1;
   [ idtac | elim H'1; clear H'1; intros H'1 ]; clear H').
elim H'1; intros H' H'2; elim H'2; intros H'3 H'4; rewrite H'4; clear H'2 H'1.
elim H'0; intros H'1 H'2; elim H'2; intros H'5 H'6; rewrite H'6;
 clear H'2 H'0.
apply pX_inj; auto.
apply Induc with (y := (l1, pX n2 l2)); auto.
red in |- *; red in |- *; simpl in |- *; auto.
elim H'1; intros H' H'2; clear H'1.
elim H'0; intros H'1 H'3; clear H'0.
absurd (ltT ltM n1 n2); auto.
elim H'1; intros H' H'2; clear H'1.
elim H'0; intros H'1 H'3; clear H'0.
absurd (eqT n2 n1); auto.
apply (eqT_sym A n); auto.
elim H'1; intros H' H'2; clear H'1.
elim H'0; intros H'1 H'3; clear H'0.
absurd (ltT ltM n1 n2); auto.
elim H'1; intros H' H'2; elim H'2; intros H'3 H'4; rewrite H'4; clear H'2 H'1.
elim H'0; intros H'1 H'2; elim H'2; intros H'5 H'6; rewrite H'6;
 clear H'2 H'0.
apply pX_inj; auto.
apply Induc with (y := (pX n1 l1, l2)); auto; red in |- *; simpl in |- *;
 auto.
rewrite <- plus_n_Sm; auto.
elim H'1; intros H' H'2; clear H'1.
elim H'0; intros H'1 H'3; clear H'0.
absurd (eqT n1 n2); auto.
elim H'1; intros H' H'2; clear H'1.
elim H'0; intros H'1 H'3; clear H'0.
absurd (eqT n2 n1); auto.
apply (eqT_sym A n); auto.
elim H'1; intros H' H'2; clear H'1.
elim H'0; intros H'1 H'3; clear H'0.
absurd (eqT n1 n2); auto.
elim H'1; intros H' H'2; elim H'2;
 [ intros H'3; clear H'2 H'1
 | intros H'3; elim H'3; intros H'4 H'5; elim H'5; intros H'6 H'7;
    rewrite H'7; clear H'5 H'3 H'2 H'1 ].
elim H'0; intros H'1 H'2; elim H'2;
 [ intros H'4; clear H'2 H'0
 | intros H'4; elim H'4; intros H'5 H'6; apply H'5 || elim H'5;
    try assumption; clear H'4 H'2 H'0 ].
elim H'4; intros H'0 H'2; clear H'4.
elim H'3; intros H'4 H'5; clear H'3.
apply Induc with (y := (l1, l2)); auto.
red in |- *; red in |- *; simpl in |- *; rewrite <- plus_n_Sm; auto.
elim H'3; intros H'0 H'2; clear H'3; auto.
elim H'0; intros H'1 H'2; elim H'2;
 [ intros H'3; clear H'2 H'0
 | intros H'3; elim H'3; intros H'5 H'8; elim H'8; intros H'9 H'10;
    rewrite H'10; clear H'8 H'3 H'2 H'0 ].
elim H'3; intros H'0 H'2; clear H'3.
apply H'4 || elim H'4; auto.
apply pX_inj; auto.
apply Induc with (y := (l1, l2)); auto.
red in |- *; red in |- *; simpl in |- *; rewrite <- plus_n_Sm; auto.
Qed.

Theorem minuspf_is_minusP :
 forall l1 l2 : list (Term A n), minusP l1 l2 (minuspf l1 l2).
intros l1 l2; try assumption.
unfold minuspf in |- *; case (minuspp (pair l1 l2)); simpl in |- *; auto.
Qed.
Hint Resolve minuspf_is_minusP.

Theorem minuspf_pO_is_eqP :
 forall p q : list (Term A n),
 eqP A eqA n (minuspf p q) (pO A n) -> eqP A eqA n p q.
intros p q H'.
apply minusP_pO_is_eqP with (r := minuspf p q); auto.
Qed.

Theorem order_minusP :
 forall (l1 l2 l3 : list (Term A n)) (a : Term A n),
 minusP l1 l2 l3 ->
 canonical A0 eqA ltM (pX a l1) ->
 canonical A0 eqA ltM (pX a l2) ->
 canonical A0 eqA ltM l3 -> canonical A0 eqA ltM (pX a l3).
intros l1 l2 l3 a H'; elim H'; auto.
intros l4 H'0 H'1 H'2.
cut (canonical A0 eqA ltM l4);
 try apply canonical_imp_canonical with (a := a); auto;
 intros C0.
apply
 canonical_pX_eqT
  with
    (a := multTerm (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
            a); auto.
change
  (canonical A0 eqA ltM
     (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
        (pX a l4))) in |- *; auto.
apply (eqT_sym A n);
 apply (eqT_trans A n) with (y := multTerm (A:=A) multA (n:=n) (T1 A1 n) a);
 auto.
apply (T1_eqT A A1 eqA); auto.
apply canonical_nzeroP with (ltM := ltM) (p := l4); auto.
intros a1 a2 l4 l5 l6 H'0 H'1 H'2 H'3 H'4 H'5.
apply canonical_cons; auto.
apply (canonical_pX_order A A0 eqA) with (ltM := ltM) (l := l4); auto.
apply canonical_nzeroP with (ltM := ltM) (p := pX a1 l4); auto.
intros a1 a2 l4 l5 l6 H'0 H'1 H'2 H'3 H'4 H'5 H'6.
apply H'1; auto.
apply canonical_skip_fst with (b := a1); auto.
apply canonical_skip_fst with (b := a2); auto.
intros a1 a2 l4 l5 l6 H'0 H'1 H'2 H'3 H'4 H'5 H'6.
apply canonical_cons; auto.
apply minusTerm_ltT_l; auto.
apply (canonical_pX_order A A0 eqA) with (l := l4); auto.
apply canonical_nzeroP with (ltM := ltM) (p := pX a1 l4); auto.
intros a1 a2 l4 l5 l6 H'0 H'1 H'2 H'3 H'4 H'5.
apply canonical_cons; auto.
apply invTerm_ltT_l; auto.
apply (canonical_pX_order A A0 eqA) with (l := l5); auto.
apply canonical_nzeroP with (ltM := ltM) (p := pX a1 l4); auto.
Qed.

Theorem canonical_minusP :
 forall l1 l2 l3 : list (Term A n),
 minusP l1 l2 l3 ->
 canonical A0 eqA ltM l1 ->
 canonical A0 eqA ltM l2 -> canonical A0 eqA ltM l3.
intros l1 l2 l3 H'; elim H'; auto.
intros a1 a2 l4 l5 l6 H'0 H'1 H'2 H'3 H'4.
apply order_minusP with (l1 := l4) (l2 := pX a2 l5); auto.
apply canonical_cons; auto.
apply canonical_nzeroP with (ltM := ltM) (p := l4); auto.
apply H'2; auto.
apply canonical_imp_canonical with (a := a1); auto.
intros a1 a2 l4 l5 l6 H'0 H'1 H'2 H'3 H'4 H'5.
apply H'1; auto.
apply canonical_imp_canonical with (a := a1); auto.
apply canonical_imp_canonical with (a := a2); auto.
intros a1 a2 l4 l5 l6 H'0 H'1 H'2 H'3 H'4 H'5.
apply order_minusP with (l1 := l4) (l2 := l5); auto.
apply canonical_pX_eqT with (a := a1); auto.
apply (eqT_sym A n); apply minusTerm_eqT; auto.
apply canonical_pX_eqT with (a := a2); auto.
apply (eqT_trans A n) with (y := a1); apply (eqT_sym A n); auto.
apply minusTerm_eqT; auto.
apply H'1.
apply canonical_imp_canonical with (a := a1); auto.
apply canonical_imp_canonical with (a := a2); auto.
intros a1 a2 l4 l5 l6 H'0 H'1 H'2 H'3 H'4.
apply order_minusP with (l1 := pX a1 l4) (l2 := l5); auto.
apply canonical_pX_eqT with (a := a2); auto.
apply canonical_cons; auto.
apply canonical_nzeroP with (ltM := ltM) (p := l5); auto.
apply nZero_invTerm_nZero with (1 := cs); auto.
apply canonical_nzeroP with (ltM := ltM) (p := l5); auto.
apply canonical_pX_eqT with (a := a2); auto.
apply nZero_invTerm_nZero with (1 := cs); auto.
apply canonical_nzeroP with (ltM := ltM) (p := l5); auto.
apply H'2; auto.
apply canonical_imp_canonical with (a := a2); auto.
Qed.

Theorem canonical_minuspf :
 forall l1 l2 : list (Term A n),
 canonical A0 eqA ltM l1 ->
 canonical A0 eqA ltM l2 -> canonical A0 eqA ltM (minuspf l1 l2).
intros l1 l2 H' H'0; generalize (minuspf_is_minusP l1 l2); intros u1.
apply canonical_minusP with (l1 := l1) (l2 := l2); auto.
Qed.

Lemma invTerm_eqT_comp :
 forall a b : Term A n, eqT a b -> eqT a (invTerm (A:=A) invA (n:=n) b).
intros a b H'.
apply (eqT_trans A n) with (y := b); auto.
Qed.

Lemma invTerm_T1_eqT_comp :
 forall a b : Term A n,
 eqT a b ->
 eqT a
   (invTerm (A:=A) invA (n:=n) (multTerm (A:=A) multA (n:=n) (T1 A1 n) b)).
intros a b H'.
apply (eqT_trans A n) with (y := b); auto.
apply (eqT_trans A n) with (y := multTerm (A:=A) multA (n:=n) (T1 A1 n) b);
 auto.
apply (T1_eqT A A1 eqA); auto.
Qed.

Lemma multTerm_invTerm_T1_eqT_comp :
 forall a b : Term A n,
 eqT a b ->
 eqT a
   (multTerm (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) b).
intros a b H'.
apply (eqT_trans A n) with (y := b); auto.
apply (eqT_trans A n) with (y := multTerm (A:=A) multA (n:=n) (T1 A1 n) b);
 auto.
apply (T1_eqT A A1 eqA); auto.
Qed.
Hint Resolve invTerm_eqT_comp invTerm_T1_eqT_comp
  multTerm_invTerm_T1_eqT_comp.

Lemma minusP_is_plusP_mults :
 forall p q r : list (Term A n),
 minusP p q r ->
 eqP A eqA n r
   (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec p
      (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) q)).
intros p q r H'; elim H'; auto.
intros; apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
simpl in |- *; intros; apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
intros a1 a2 l1 l2 l3 H'0 H'1 H'2.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pX a1
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec l1
               (pX
                  (multTerm (A:=A) multA (n:=n)
                     (invTerm (A:=A) invA (n:=n) (T1 A1 n)) a2)
                  (mults (A:=A) multA (n:=n)
                     (invTerm (A:=A) invA (n:=n) (T1 A1 n)) l2))));
 auto.
simpl in |- *; apply pluspf_inv1 with (1 := cs); auto.
change
  (ltT ltM
     (multTerm (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) a2)
     a1) in |- *.
apply eqT_compat_ltTl with (b := a2); auto.
intros a1 a2 l1 l2 l3 H'0 H'1 H'2 H'3.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            l1
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               l2)); auto.
simpl in |- *; apply pluspf_inv3a with (1 := cs); auto.
change
  (eqT a1
     (multTerm (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) a2))
 in |- *.
apply (eqT_trans A n) with (y := a2); auto.
change
  (zeroP (A:=A) A0 eqA (n:=n)
     (plusTerm (A:=A) plusA (n:=n) a1
        (multTerm (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
           a2))) in |- *; auto.
apply
 zeroP_comp_eqTerm with (1 := cs) (a := minusTerm (A:=A) minusA (n:=n) a1 a2);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := plusTerm (A:=A) plusA (n:=n) a1 (invTerm (A:=A) invA (n:=n) a2));
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply plusTerm_comp_r with (1 := cs); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := invTerm (A:=A) invA (n:=n)
            (multTerm (A:=A) multA (n:=n) (T1 A1 n) a2));
 auto.
apply eqTerm_invTerm_comp with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
intros a1 a2 l1 l2 l3 H'0 H'1 H'2 H'3.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pX
            (plusTerm (A:=A) plusA (n:=n) a1
               (multTerm (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) a2))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec l1
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) l2)));
 auto.
apply eqpP1; auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := plusTerm (A:=A) plusA (n:=n) a1 (invTerm (A:=A) invA (n:=n) a2));
 auto.
apply plusTerm_comp_r with (1 := cs); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := invTerm (A:=A) invA (n:=n)
            (multTerm (A:=A) multA (n:=n) (T1 A1 n) a2));
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
simpl in |- *; apply pluspf_inv3b with (1 := cs); auto.
change
  (eqT a1
     (multTerm (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) a2))
 in |- *.
apply (eqT_trans A n) with (y := a2); auto.
change
  (~
   zeroP (A:=A) A0 eqA (n:=n)
     (plusTerm (A:=A) plusA (n:=n) a1
        (multTerm (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
           a2))) in |- *; auto.
apply
 nzeroP_comp_eqTerm
  with (1 := cs) (a := minusTerm (A:=A) minusA (n:=n) a1 a2);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := plusTerm (A:=A) plusA (n:=n) a1 (invTerm (A:=A) invA (n:=n) a2));
 auto.
apply plusTerm_comp_r with (1 := cs); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := invTerm (A:=A) invA (n:=n)
            (multTerm (A:=A) multA (n:=n) (T1 A1 n) a2));
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
intros a1 a2 l1 l2 l3 H'0 H'1 H'2.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pX
            (multTerm (A:=A) multA (n:=n)
               (invTerm (A:=A) invA (n:=n) (T1 A1 n)) a2)
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (pX a1 l1)
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) l2)));
 auto.
apply eqpP1; auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := invTerm (A:=A) invA (n:=n)
            (multTerm (A:=A) multA (n:=n) (T1 A1 n) a2));
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
simpl in |- *; apply pluspf_inv2 with (1 := cs); auto.
change
  (ltT ltM a1
     (multTerm (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) a2))
 in |- *; auto.
apply eqT_compat_ltTr with (b := a2); auto.
Qed.

Theorem minuspf_is_pluspf_mults :
 forall p q : list (Term A n),
 eqP A eqA n (minuspf p q)
   (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec p
      (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) q)).
intros p q; try assumption.
apply minusP_is_plusP_mults with (p := p) (q := q); auto.
Qed.
Hint Resolve minuspf_is_pluspf_mults.

Theorem pO_minusP_inv1 :
 forall p q : list (Term A n),
 minusP (pO A n) p q ->
 q = mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) p.
intros p; elim p.
intros q H'; inversion H'; auto.
intros a l H' q H'0; inversion H'0; auto.
Qed.

Theorem pO_minusP_inv2 :
 forall p q : list (Term A n), minusP p (pO A n) q -> p = q.
intros p; elim p.
intros q H'; inversion H'; auto.
intros a l H' q H'0; inversion H'0; auto.
Qed.

Theorem minusP_inv1 :
 forall (a b : Term A n) (p q s : list (Term A n)),
 minusP (pX a p) (pX b q) s -> ltT ltM b a -> s = pX a (minuspf p (pX b q)).
intros a b p q s H'; inversion_clear H'; intros.
apply pX_inj; auto.
apply uniq_minusp with (l := (p, pX b q)); simpl in |- *; auto.
absurd (ltT ltM b a); auto.
apply ltT_not_eqT; auto; apply eqT_sym; auto.
absurd (ltT ltM b a); auto.
apply ltT_not_eqT; auto; apply eqT_sym; auto.
absurd (ltT ltM b a); auto.
Qed.

Theorem minusP_inv2 :
 forall (a b : Term A n) (p q s : list (Term A n)),
 minusP (pX a p) (pX b q) s ->
 ltT ltM a b -> s = pX (invTerm (A:=A) invA (n:=n) b) (minuspf (pX a p) q).
intros a b p q s H'; inversion_clear H'; intros.
absurd (ltT ltM a b); auto.
absurd (ltT ltM a b); auto.
absurd (ltT ltM a b); auto.
apply pX_inj; auto.
apply uniq_minusp with (l := (pX a p, q)); simpl in |- *; auto.
Qed.

Theorem minusP_inv3a :
 forall (a b : Term A n) (p q s : list (Term A n)),
 eqT a b ->
 zeroP (A:=A) A0 eqA (n:=n) (minusTerm (A:=A) minusA (n:=n) a b) ->
 minusP (pX a p) (pX b q) s -> s = minuspf p q.
intros a b p q s Eqd Z0 H'; inversion_clear H'.
absurd (ltT ltM b a); auto.
apply ltT_not_eqT; auto; apply eqT_sym; auto.
apply uniq_minusp with (l := (p, q)); simpl in |- *; auto.
case H1; auto.
absurd (ltT ltM a b); auto.
Qed.

Theorem minusP_inv3b :
 forall (a b : Term A n) (p q s : list (Term A n)),
 eqT a b ->
 ~ zeroP (A:=A) A0 eqA (n:=n) (minusTerm (A:=A) minusA (n:=n) a b) ->
 minusP (pX a p) (pX b q) s ->
 s = pX (minusTerm (A:=A) minusA (n:=n) a b) (minuspf p q).
intros a b p q s Eqd Z0 H'; inversion_clear H'.
absurd (ltT ltM b a); auto.
apply ltT_not_eqT; auto; apply eqT_sym; auto.
case Z0; auto.
apply pX_inj; auto.
apply uniq_minusp with (l := (p, q)); auto.
absurd (ltT ltM a b); auto.
Qed.

Theorem minuspf_inv1_eq :
 forall (a b : Term A n) (p q : list (Term A n)),
 ltT ltM b a -> pX a (minuspf p (pX b q)) = minuspf (pX a p) (pX b q).
intros a b p q H'; try assumption.
rewrite (minusP_inv1 a b p q (minuspf (pX a p) (pX b q))); auto.
Qed.

Theorem minuspf_inv2_eq :
 forall (a b : Term A n) (p q : list (Term A n)),
 ltT ltM a b ->
 pX (invTerm (A:=A) invA (n:=n) b) (minuspf (pX a p) q) =
 minuspf (pX a p) (pX b q).
intros a b p q H'; try assumption.
rewrite (minusP_inv2 a b p q (minuspf (pX a p) (pX b q))); auto.
Qed.

Theorem minuspf_inv3a_eq :
 forall (a b : Term A n) (p q : list (Term A n)),
 eqT a b ->
 zeroP (A:=A) A0 eqA (n:=n) (minusTerm (A:=A) minusA (n:=n) a b) ->
 minuspf p q = minuspf (pX a p) (pX b q).
intros a b p q H' Z; try assumption.
rewrite (minusP_inv3a a b p q (minuspf (pX a p) (pX b q))); auto.
Qed.

Theorem minuspf_inv3b_eq :
 forall (a b : Term A n) (p q : list (Term A n)),
 eqT a b ->
 ~ zeroP (A:=A) A0 eqA (n:=n) (minusTerm (A:=A) minusA (n:=n) a b) ->
 pX (minusTerm (A:=A) minusA (n:=n) a b) (minuspf p q) =
 minuspf (pX a p) (pX b q).
intros a b p q H' Z; try assumption.
rewrite (minusP_inv3b a b p q (minuspf (pX a p) (pX b q))); auto.
Qed.

Theorem minuspf_inv1 :
 forall (a b : Term A n) (p q : list (Term A n)),
 ltT ltM b a ->
 eqP A eqA n (pX a (minuspf p (pX b q))) (minuspf (pX a p) (pX b q)).
intros a b p q H'; try assumption.
rewrite (minusP_inv1 a b p q (minuspf (pX a p) (pX b q))); auto.
Qed.

Theorem minuspf_inv2 :
 forall (a b : Term A n) (p q : list (Term A n)),
 ltT ltM a b ->
 eqP A eqA n (pX (invTerm (A:=A) invA (n:=n) b) (minuspf (pX a p) q))
   (minuspf (pX a p) (pX b q)).
intros a b p q H'; try assumption.
rewrite (minusP_inv2 a b p q (minuspf (pX a p) (pX b q))); auto.
Qed.

Theorem minuspf_inv3a :
 forall (a b : Term A n) (p q : list (Term A n)),
 eqT a b ->
 zeroP (A:=A) A0 eqA (n:=n) (minusTerm (A:=A) minusA (n:=n) a b) ->
 eqP A eqA n (minuspf p q) (minuspf (pX a p) (pX b q)).
intros a b p q H' Z; try assumption.
rewrite (minusP_inv3a a b p q (minuspf (pX a p) (pX b q))); auto.
Qed.

Theorem minuspf_inv3b :
 forall (a b : Term A n) (p q : list (Term A n)),
 eqT a b ->
 ~ zeroP (A:=A) A0 eqA (n:=n) (minusTerm (A:=A) minusA (n:=n) a b) ->
 eqP A eqA n (pX (minusTerm (A:=A) minusA (n:=n) a b) (minuspf p q))
   (minuspf (pX a p) (pX b q)).
intros a b p q H' Z; try assumption.
rewrite (minusP_inv3b a b p q (minuspf (pX a p) (pX b q))); auto.
Qed.
Hint Resolve pluspf_inv1 pluspf_inv2 pluspf_inv3a pluspf_inv3b.
Hint Resolve minuspf_inv1 minuspf_inv2 minuspf_inv3a minuspf_inv3b.

Theorem minuspf_comp :
 forall p q r s : list (Term A n),
 canonical A0 eqA ltM p ->
 canonical A0 eqA ltM q ->
 canonical A0 eqA ltM r ->
 canonical A0 eqA ltM s ->
 eqP A eqA n p r ->
 eqP A eqA n q s -> eqP A eqA n (minuspf p q) (minuspf r s).
intros p q r s H' H'0 H'1 H'2 H'3 H'4;
 apply
  (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
   with
     (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
             ltM_dec p
             (mults (A:=A) multA (n:=n)
                (invTerm (A:=A) invA (n:=n) (T1 A1 n)) q)).
apply minuspf_is_pluspf_mults; auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            r
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               s)); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Theorem mults_dist_minuspf :
 forall (p q : list (Term A n)) (a : Term A n),
 canonical A0 eqA ltM p ->
 canonical A0 eqA ltM q ->
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 eqP A eqA n (mults (A:=A) multA (n:=n) a (minuspf p q))
   (minuspf (mults (A:=A) multA (n:=n) a p) (mults (A:=A) multA (n:=n) a q)).
intros p q a H' H'0 H'1.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := mults (A:=A) multA (n:=n) a
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec p
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) q)));
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) a p)
            (mults (A:=A) multA (n:=n) a
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) q)));
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) a p)
            (mults (A:=A) multA (n:=n)
               (multTerm (A:=A) multA (n:=n) a
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n))) q));
 auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) a p)
            (mults (A:=A) multA (n:=n)
               (multTerm (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) a) q));
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) a p)
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (mults (A:=A) multA (n:=n) a q))); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.
Hint Resolve mults_dist_minuspf.

Theorem minuspf_pO_refl :
 forall p : list (Term A n), eqP A eqA n (minuspf p (pO A n)) p.
intros p;
 apply
  (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
   with
     (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
             ltM_dec p
             (mults (A:=A) multA (n:=n)
                (invTerm (A:=A) invA (n:=n) (T1 A1 n))
                (pO A n))); auto; simpl in |- *; auto.
Qed.
Hint Resolve minuspf_pO_refl.

Theorem minuspf_pOmults :
 forall p : list (Term A n),
 eqP A eqA n (minuspf (pO A n) p)
   (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) p).
intros p;
 apply
  (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
   with
     (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
             ltM_dec (pO A n)
             (mults (A:=A) multA (n:=n)
                (invTerm (A:=A) invA (n:=n) (T1 A1 n)) p));
 auto; simpl in |- *; auto.
Qed.
Hint Resolve minuspf_pOmults.

Theorem mults_pO :
 forall (p : list (Term A n)) (a b : Term A n),
 eqT a b ->
 zeroP (A:=A) A0 eqA (n:=n) (minusTerm (A:=A) minusA (n:=n) a b) ->
 eqP A eqA n (pO A n)
   (minuspf (mults (A:=A) multA (n:=n) a p) (mults (A:=A) multA (n:=n) b p)).
intros p; elim p.
simpl in |- *; auto.
intros; apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
intros a l H' a0 b H'0 H'1; simpl in |- *.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := minuspf (mults (A:=A) multA (n:=n) a0 l)
            (mults (A:=A) multA (n:=n) b l)); auto.
apply minuspf_inv3a; auto.
apply
 zeroP_comp_eqTerm
  with
    (1 := cs)
    (a := multTerm (A:=A) multA (n:=n) (minusTerm (A:=A) minusA (n:=n) a0 b)
            a); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply multTerm_minusTerm_dist_l with (1 := cs); auto.
Qed.

Theorem mults_minusTerm :
 forall (p : list (Term A n)) (a b : Term A n),
 eqT a b ->
 ~ zeroP (A:=A) A0 eqA (n:=n) (minusTerm (A:=A) minusA (n:=n) a b) ->
 canonical A0 eqA ltM p ->
 eqP A eqA n
   (mults (A:=A) multA (n:=n) (minusTerm (A:=A) minusA (n:=n) a b) p)
   (minuspf (mults (A:=A) multA (n:=n) a p) (mults (A:=A) multA (n:=n) b p)).
intros p; elim p.
simpl in |- *; auto.
intros a b H H0 H1; apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
intros a l H' a0 b H'0 H'1 H'2; simpl in |- *; auto.
cut (canonical A0 eqA ltM l); try apply canonical_imp_canonical with (a := a);
 auto; intros Z0; auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pX
            (minusTerm (A:=A) minusA (n:=n)
               (multTerm (A:=A) multA (n:=n) a0 a)
               (multTerm (A:=A) multA (n:=n) b a))
            (minuspf (mults (A:=A) multA (n:=n) a0 l)
               (mults (A:=A) multA (n:=n) b l))); auto.
apply (eqpP1 A eqA); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply multTerm_minusTerm_dist_l with (1 := cs); auto.
apply minuspf_inv3b; auto.
apply
 nzeroP_comp_eqTerm
  with
    (1 := cs)
    (a := multTerm (A:=A) multA (n:=n) (minusTerm (A:=A) minusA (n:=n) a0 b)
            a); auto.
apply nzeroP_multTerm with (1 := cs); auto.
apply (canonical_nzeroP A A0 eqA n ltM) with (p := l); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply multTerm_minusTerm_dist_l with (1 := cs); auto.
Qed.

Theorem order_pluspf :
 forall (l1 l2 : list (Term A n)) (a : Term A n),
 canonical A0 eqA ltM (pX a l1) ->
 canonical A0 eqA ltM (pX a l2) ->
 canonical A0 eqA ltM
   (pX a
      (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec l1
         l2)).
intros l1 l2 a H' H'0.
apply order_plusP with (1 := os) (plusA := plusA) (l1 := l1) (l2 := l2); auto.
apply pluspf_is_plusP; auto.
apply canonical_pluspf; auto.
apply canonical_imp_canonical with (a := a); auto.
apply canonical_imp_canonical with (a := a); auto.
Qed.
Hint Resolve order_pluspf.

Theorem order_minuspf :
 forall (l1 l2 : list (Term A n)) (a : Term A n),
 canonical A0 eqA ltM (pX a l1) ->
 canonical A0 eqA ltM (pX a l2) ->
 canonical A0 eqA ltM (pX a (minuspf l1 l2)).
intros l1 l2 a H' H'0.
apply
 eqp_imp_canonical
  with
    (1 := cs)
    (p := pX a
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec l1
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) l2)));
 auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply order_pluspf; auto.
apply
 canonical_pX_eqT
  with
    (a := multTerm (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
            a); auto.
change
  (canonical A0 eqA ltM
     (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
        (pX a l2))) in |- *; auto.
apply (eqT_sym A n); auto.
apply (canonical_nzeroP A A0 eqA n ltM) with (p := l1); auto.
Qed.

Theorem minusP_refl :
 forall p q r : list (Term A n), minusP p q r -> p = q -> r = pO A n.
intros p q r H'; elim H'; auto.
intros l1 H'0; rewrite <- H'0; simpl in |- *; auto.
intros a1 a2 l1 l2 l3 H'0 H'1 H'2 H'3; generalize H'0.
rewrite (pX_invl A n a1 a2 l1 l2); auto; intros Ord.
absurd (ltT ltM a2 a2); auto.
intros a1 a2 l1 l2 l3 H'0 H'1 H'2 H'3 H'4.
apply H'1; auto.
apply pX_invr with (a := a1) (b := a2); auto.
intros a1 a2 l1 l2 l3 H'0 H'1 H'2 H'3 H'4; elim H'3; auto.
rewrite (pX_invl A n a1 a2 l1 l2); auto.
intros a1 a2 l1 l2 l3 H'0 H'1 H'2 H'3; generalize H'0.
rewrite (pX_invl A n a1 a2 l1 l2); auto; intros Ord.
absurd (ltT ltM a2 a2); auto.
Qed.

Theorem minuspf_refl_eq : forall p : list (Term A n), minuspf p p = pO A n.
intros p; rewrite (minusP_refl p p (minuspf p p)); auto.
Qed.

Theorem minuspf_refl :
 forall p : list (Term A n), eqP A eqA n (minuspf p p) (pO A n).
intros p.
rewrite (minusP_refl p p (minuspf p p)); auto.
Qed.

Theorem mults_comp_minuspf :
 forall (a : Term A n) (p q : list (Term A n)),
 canonical A0 eqA ltM p ->
 canonical A0 eqA ltM q ->
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 eqP A eqA n
   (minuspf (mults (A:=A) multA (n:=n) a p) (mults (A:=A) multA (n:=n) a q))
   (mults (A:=A) multA (n:=n) a (minuspf p q)).
intros a p q H' H'0 H'1.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) a p)
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (mults (A:=A) multA (n:=n) a q))); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) a p)
            (mults (A:=A) multA (n:=n)
               (multTerm (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) a) q));
 auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) a p)
            (mults (A:=A) multA (n:=n)
               (multTerm (A:=A) multA (n:=n) a
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n))) q));
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults (A:=A) multA (n:=n) a p)
            (mults (A:=A) multA (n:=n) a
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) q)));
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := mults (A:=A) multA (n:=n) a
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec p
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) q)));
 apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Theorem minuspf_zero :
 forall (a : Term A n) (p q : list (Term A n)),
 eqP A eqA n (minuspf (pX a p) (pX a q)) (minuspf p q).
intros a p q; try assumption.
apply (eqp_trans _ _ _ _ _ _ _ _ _ cs n) with (y := minuspf p q); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n).
apply minuspf_inv3a; auto.
Qed.
Hint Resolve canonical_minuspf.

Theorem pluspf_minuspf_id :
 forall p q : list (Term A n),
 canonical A0 eqA ltM p ->
 canonical A0 eqA ltM q ->
 eqP A eqA n
   (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
      (minuspf p q) q) p.
intros p q H' H'0.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec p
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) q)) q);
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            p
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) q) q));
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            p
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec q
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n)) q)));
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            p (pO A n)); auto.
Qed.

Theorem minusP_pO_refl_eq :
 forall p q : list (Term A n), minusP p (pO A n) q -> p = q.
unfold pO in |- *; intros p q H'; inversion H'; simpl in |- *; auto.
Qed.

Theorem minuspf_pO_refl_eq :
 forall p : list (Term A n), minuspf p (pO A n) = p.
intros p.
rewrite <- (minusP_pO_refl_eq p (minuspf p (pO A n))); auto.
Qed.

Theorem Opm_ind :
 forall (P : list (Term A n) -> list (Term A n) -> Prop)
   (p q : list (Term A n)),
 (forall p : list (Term A n), P (pO A n) p) ->
 (forall p : list (Term A n), P p (pO A n)) ->
 (forall (a b : Term A n) (p q : list (Term A n)),
  P (pX a p) q -> ltT ltM a b -> P (pX a p) (pX b q)) ->
 (forall (a b : Term A n) (p q : list (Term A n)),
  P p (pX b q) -> ltT ltM b a -> P (pX a p) (pX b q)) ->
 (forall (a b : Term A n) (p q : list (Term A n)),
  P p q -> eqT a b -> P (pX a p) (pX b q)) ->
 forall p q : list (Term A n), P p q.
intros P H' H'0 H'1 H'2 H'3 H'4 H'5 p; elim p; auto.
intros a l H'6 q; elim q; auto.
intros a0 l0 H'7;
 (case (ltT_dec A n ltM ltM_dec a a0);
   [ intros temp; case temp; clear temp | idtac ];
   intros test); change (P (pX a l) (pX a0 l0)) in |- *;
 auto.
Qed.

Theorem minuspf_eq_inv1 :
 forall (a : Term A n) (p q : list (Term A n)),
 canonical A0 eqA ltM (pX a p) ->
 canonical A0 eqA ltM (pX a q) ->
 eqP A eqA n (pX a (minuspf p q)) (minuspf (pX a p) q).
intros a p q; case q; simpl in |- *; auto.
intros H' H'0; rewrite minuspf_pO_refl_eq; rewrite minuspf_pO_refl_eq; auto.
intros a0 l H' H'0.
change
  (eqP A eqA n (pX a (minuspf p (pX a0 l))) (minuspf (pX a p) (pX a0 l)))
 in |- *; apply minuspf_inv1; auto.
apply (canonical_pX_order A A0 eqA) with (l := l); auto.
Qed.

Theorem minuspf_pOmults_eq :
 forall p : list (Term A n),
 minuspf (pO A n) p =
 mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) p.
intros p; apply uniq_minusp with (l := (pO A n, p)); auto.
Qed.

Theorem minuspf_eq_inv2 :
 forall (a : Term A n) (p q : list (Term A n)),
 canonical A0 eqA ltM (pX a p) ->
 canonical A0 eqA ltM (pX a q) ->
 eqP A eqA n (pX (invTerm (A:=A) invA (n:=n) a) (minuspf p q))
   (minuspf p (pX a q)).
intros a p; elim p; auto.
intros q H' H'0; rewrite minuspf_pOmults_eq.
rewrite minuspf_pOmults_eq; simpl in |- *.
apply eqpP1; auto.
change
  (eqTerm (A:=A) eqA (n:=n) (invTerm (A:=A) invA (n:=n) a)
     (multTerm (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) a))
 in |- *.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := invTerm (A:=A) invA (n:=n)
            (multTerm (A:=A) multA (n:=n) (T1 A1 n) a));
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
intros a0 l H' q H'0 H'1.
change
  (eqP A eqA n (pX (invTerm (A:=A) invA (n:=n) a) (minuspf (pX a0 l) q))
     (minuspf (pX a0 l) (pX a q))) in |- *.
rewrite <- (minuspf_inv2_eq a0 a l q); auto.
apply (canonical_pX_order A A0 eqA) with (l := l); auto.
Qed.

Definition inv : list (Term A n) -> Term A n -> Term A n.
intros p; case p.
intros a;
 exact
  (multTerm (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) a).
intros a1 p1 a; exact (invTerm (A:=A) invA (n:=n) a).
Defined.

Theorem inv_prop :
 forall (a : Term A n) (p q : list (Term A n)),
 canonical A0 eqA ltM (pX a p) ->
 minuspf p (pX a q) = pX (inv p a) (minuspf p q).
intros a p q; case p; simpl in |- *; auto.
intros H'.
change
  (minuspf (pO A n) (pX a q) =
   pX (multTerm (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) a)
     (minuspf (pO A n) q)) in |- *.
rewrite (minuspf_pOmults_eq (pX a q)); simpl in |- *; auto.
rewrite (minuspf_pOmults_eq q); simpl in |- *; auto.
intros a0 l H'.
change
  (minuspf (pX a0 l) (pX a q) =
   pX (invTerm (A:=A) invA (n:=n) a) (minuspf (pX a0 l) q))
 in |- *.
rewrite <- (minuspf_inv2_eq a0 a l q); auto.
apply (canonical_pX_order A A0 eqA) with (l := l); auto.
Qed.
Hint Resolve inv_prop.

Theorem invTerm_T1_multTerm_T1 :
 eqTerm (A:=A) eqA (n:=n)
   (multTerm (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
      (invTerm (A:=A) invA (n:=n) (T1 A1 n))) (T1 A1 n).
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := invTerm (A:=A) invA (n:=n)
            (multTerm (A:=A) multA (n:=n) (T1 A1 n)
               (invTerm (A:=A) invA (n:=n) (T1 A1 n))));
 [ auto | idtac ].
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := invTerm (A:=A) invA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)));
 auto.
apply eqTerm_invTerm_comp with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); apply T1_multTerm_l with (1 := cs);
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); apply invTerm_invol with (1 := cs);
 auto.
Qed.
Hint Resolve invTerm_T1_multTerm_T1.

Theorem pluspf_is_minuspf :
 forall p q : list (Term A n),
 canonical A0 eqA ltM p ->
 canonical A0 eqA ltM q ->
 eqP A eqA n
   (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec p q)
   (minuspf p
      (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) q)).
intros p q Opp Opq;
 apply
  (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
   with
     (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
             ltM_dec p
             (mults (A:=A) multA (n:=n)
                (invTerm (A:=A) invA (n:=n) (T1 A1 n))
                (mults (A:=A) multA (n:=n)
                   (invTerm (A:=A) invA (n:=n) (T1 A1 n)) q)));
 auto.
apply eqp_pluspf_com with (1 := cs); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := mults (A:=A) multA (n:=n)
            (multTerm (A:=A) multA (n:=n)
               (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (invTerm (A:=A) invA (n:=n) (T1 A1 n))) q);
 auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n);
 apply
  (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
   with (y := mults (A:=A) multA (n:=n) (T1 A1 n) q);
 auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Definition sminus : poly A0 eqA ltM -> poly A0 eqA ltM -> poly A0 eqA ltM.
intros sp1 sp2.
case sp1; case sp2.
intros p1 H'1 p2 H'2; exists (minuspf p1 p2); auto.
Defined.
End Pminus.


Require Import Morphisms.

Set Implicit Arguments.

Section relations.
Variables (cfg : Type) (cstep : cfg -> cfg -> Prop).

Definition Spec : Type := cfg -> (cfg -> Prop) -> Prop.
Definition subspec (A B:Spec) : Prop := forall k P, A k P -> B k P.
Definition mono (F : Spec -> Spec) : Prop := Proper (subspec ==> subspec) F.
Definition ho_mono (F : (Spec -> Spec) -> (Spec -> Spec)) : Prop
  := Proper ((subspec ==> subspec) ==> (subspec ==> subspec)) F.

(* Soundness *)
CoInductive reaches (k : cfg) (P : cfg -> Prop) : Prop :=
  (* reaches : Spec, but defining k and P as parameters
     gives a cleaner definition and induction principle. *)
| rdone : P k -> reaches k P
| rstep : forall k', cstep k k' -> reaches k' P -> reaches k P.

Definition sound Rules : Prop := subspec Rules reaches.

Inductive step (X : Spec) (k : cfg) (P : cfg -> Prop) : Prop :=
  (* step : Spec -> Spec *)
| sdone : P k -> step X k P
| sstep : forall k', cstep k k' -> X k' P -> step X k P.
Lemma step_mono : mono step.
Proof. destruct 2;econstructor(solve[eauto using step]). Qed.

Lemma reaches_stable : subspec reaches (step reaches).
Proof. destruct 1;econstructor(eassumption). Qed.

CoFixpoint stable_sound Rules (Hstable : subspec Rules (step Rules)) : sound Rules :=
  fun x P H =>
  match Hstable _ _ H with
    | sdone pf => rdone _ _ pf
    | sstep k' Hstep H' =>
        rstep Hstep (stable_sound Hstable _ _ H')
  end.

(* t : Spec -> Spec *)
Inductive t (X : Spec) : Spec :=
| t_def : forall Y, mono Y -> (forall A, subspec (Y (step A)) (step (Y A)))
                    -> subspec (Y X) (t X).

Lemma t_mono : mono t.
Proof. destruct 2. econstructor. eauto. eauto. revert H2. apply H0. assumption. Qed.
Lemma t_base : forall X, subspec (step X) (t X).
Proof. unfold subspec;intros. apply t_def with step. apply step_mono. firstorder. assumption. Qed.
Lemma t_id : forall (X:Spec), subspec X (t X).
Proof.
  unfold subspec;intros.
  apply t_def with (fun X => X);unfold mono;trivial || firstorder.
Qed.
Lemma t_compat : forall (X:Spec), subspec (t (step X)) (step (t X)).
Proof. unfold subspec. intros. destruct H. apply H0 in H1.
       revert H1. apply step_mono. eapply t_def;eauto. Qed.
Lemma t_idem : forall X, subspec (t (t X)) (t X).
Proof. unfold subspec. intros. apply t_def with (fun X => t (t X)).
       intro. intros. eauto using t_mono.
       intros. intro. intros. apply t_compat. revert H0. apply t_mono. apply t_compat.
       assumption.
Qed.

Lemma t_ext : forall Rules, subspec Rules (step (t Rules)) -> subspec (t Rules) (step (t Rules)).
Proof. intros. unfold subspec. intros. apply (t_mono H) in H0. apply t_compat in H0.
       revert H0. apply step_mono. apply t_idem. Qed.

Lemma proof_by_t : forall (Rules : Spec), subspec Rules (step (t Rules)) -> sound Rules.
  intros. apply t_ext in H. apply stable_sound in H. revert H.
  unfold sound, subspec. firstorder using t_id.
Qed.

Lemma t_rule : forall (F : Spec -> Spec), mono F -> (forall X, subspec (F X) (t X)) ->
                  forall A, subspec (F (t A)) (t A).
Proof. intros. unfold subspec;intros. eapply t_idem. revert H1. apply H0. Qed.

(* A higher order function so F <= Step F exactly when F is compatible, i.e. F o step <= step o F
   Thus t is the greatest fixpoint of B
 *)
Inductive Step (F : Spec -> Spec) (X : Spec) k (P:cfg -> Prop) : Prop :=
| Step_def : forall G, mono G
                       -> (forall A, subspec (G (step A)) (step (F A)))
                       -> G X k P -> Step F X k P.
(* T is related to Step as t is related to step.
   F <= B (T F) implies F <= t
 *)
Inductive T (F: Spec -> Spec) (X : Spec) : Spec :=
  (* trans : Spec -> Spec *)
| T_def : forall Y, ho_mono Y
                    -> (forall G A, mono G -> subspec (Y (Step G) A) (Step (Y G) A))
                    -> subspec (Y F X) (T F X).

Lemma Step_mono : ho_mono Step.
Proof. destruct 3. apply Step_def with G. assumption.
       intros. intro;intros. apply H2 in H4. revert H4. apply step_mono. apply H. firstorder.
       revert H3. apply H1. assumption.
Qed.

Lemma T_mono : ho_mono T.
Proof. destruct 3. econstructor;try eassumption. revert H3. apply H1.
       apply H. assumption.
Qed.

Lemma Tf_id : forall (F : Spec -> Spec), forall A, subspec A (T F A).
Proof.
  Ltac T_finish Q := apply T_def with Q;[solve[firstorder using step_mono]|..|assumption];
   let G:=fresh "G" in intro G;unfold subspec;intros;
   try solve[apply Step_def with (Q G);[firstorder using step_mono..|assumption]].
 Ltac T_solve :=
     match goal with
     | [|- forall F A, subspec (@?Q F A) (T F A) ] =>
                     intros F A;intro;intros;T_finish Q
     | [|- forall F A, mono F -> subspec (@?Q F A) (T F A) ] =>
                     intros F A HF;intro;intros;T_finish Q
     | [|- forall F, mono F -> forall A, subspec (@?Q F A) (T F A) ] =>
                     intros F HF A;intro;intros;T_finish Q
     end.
  T_solve.
Qed.

Lemma Tf_base : forall (F : Spec -> Spec), forall A, subspec (step A) (T F A).
Proof.
  T_solve.
Qed.

Lemma T_id : forall (F : Spec -> Spec), forall A, subspec (F A) (T F A).
Proof.
  T_solve.
  trivial.
Qed.

Lemma T_compat: forall F, mono F -> forall A, subspec (T (Step F) A) (Step (T F) A).
Proof.
  intros;intro;intros.
  destruct H0.
  apply H1 in H2;[|assumption].
  revert H2. apply Step_mono;[|firstorder].
  intro;intros. intro;intros. apply T_def with Y;try assumption.
  revert H3. apply H0;trivial.
Qed.

Lemma T_idem : forall (F : Spec -> Spec), forall A, subspec (T (T F) A) (T F A).
Proof.
  intros;intro;intros.
  eapply T_def with (fun F => T (T F));[..|assumption].
  intro;intros. apply T_mono. apply T_mono;assumption.
  intros. intro;intros. apply T_compat. apply T_mono; assumption.
  revert H1. apply T_mono;[|firstorder].
  intro;intros. intro;intros. apply T_compat. assumption.
  revert H2. apply T_mono. apply Step_mono. assumption. assumption.
Qed.

Definition bot (x:cfg) (P : cfg -> Prop) : Prop := False.

Lemma Tbot_compat : forall (X:Spec),
    subspec (T (fun _ => bot) (step X)) (step (T (fun _ => bot) X)).
Proof.
  intros;intro;intros. destruct H. edestruct H0.
  assert (mono (fun _ => bot)). firstorder. apply H2.
  eapply H. Focus 3. apply H1. firstorder.
  intro;intros. eassumption.
  edestruct H3. eassumption.
  constructor. trivial.
  eapply sstep. eassumption.
  eapply T_def. apply H. assumption. trivial.
Qed.

Lemma T_t : forall A, subspec (t A) (T (fun _ => bot) A).
Proof.
  destruct 1.
  apply T_def with (fun _ => Y);[firstorder| |assumption].
  unfold subspec;intros.
  apply Step_def with Y;auto.
Qed.

Lemma t_T : forall A, subspec (T (fun _ => bot) A) (t A).
Proof.
  intros;intro;intros.
  eapply t_def; try eassumption. apply T_mono. firstorder.
  intros;intro;intros. apply Tbot_compat. trivial.
Qed.

Lemma Tf_t : forall F A, mono F -> subspec (t A) (T F A).
Proof.
  unfold subspec;intros.
  apply T_t in H0. revert H0.
  apply T_mono. firstorder.
  unfold subspec;trivial.
Qed.

Lemma dup_compat : forall F A, mono F ->
   subspec (Step F (Step F A)) (Step (fun A => F (F A)) A).
Proof.
  intros. intro;intros.
  apply Step_def with (G:=(fun A => Step F (Step F A)));[..|assumption].
  intro;intros. apply Step_mono. trivial. apply Step_mono;trivial.
  intros;intro;intros.
  assert (forall X, subspec (Step F (step X)) (step (F X))).
  intros;intro;intros. destruct H2. apply H3. assumption.
  apply H2. revert H1. apply Step_mono. trivial.
  apply H2.
Qed.

Lemma Tf_idem : forall (F : Spec -> Spec), mono F ->
                                           forall A, subspec (T F (T F A)) (T F A).
Proof.
  intros;intro;intros.
  apply T_idem. apply T_def with (fun F A => F (F A));[..|assumption].
     intro;intros;intro;intros. apply H1. apply H1. assumption.
  apply dup_compat.
Qed.

Lemma tfun : forall (F : Spec -> Spec), mono F ->
                                         forall A, subspec (F (T F A)) (T F A).
Proof.
  intros;intro;intros. apply Tf_idem. assumption. apply T_id. assumption.
Qed.

Lemma t_gfp : forall (F : Spec -> Spec), mono F ->
    (forall A, subspec (F A) (Step F A)) ->
    (forall A, subspec (F A) (t A)).
intros;intro;intros.
apply t_def with F;try assumption.
intros;intro;intros.
destruct (H0 (step A0) _ _ H2).
apply H4. assumption.
Qed.

Lemma t_gfp_help : forall (F : Spec -> Spec), mono F ->
    (forall A, subspec ((T F) A) (Step (T F) A)) ->
    (forall A, subspec ((T F) A) (t A)).
Proof.
  intros. apply t_gfp. apply T_mono. eauto. assumption.
Qed.

Lemma t_gfp' : forall (F : Spec -> Spec), mono F ->
    (forall A, subspec (F A) (Step (T F) A)) ->
    (forall A, subspec (F A) (t A)).
Proof.
  intros. assert (subspec (F A) (Step (T F) A)) by apply H0.
  assert (forall A, subspec ((T F) A) (T (Step (T F)) A)). (* assumption, mono of T *)
  intros;intro;intros. eapply T_mono. Focus 3. eapply H2. firstorder. firstorder.
  assert (forall A, subspec (T (Step (T F)) A) (Step (T (T F)) A)).
  intros;intro;intros. apply T_compat. apply T_mono. eauto. trivial.
  assert (forall A, subspec (Step (T (T F)) A) (Step (T F) A)). (* idempotency of T *)
  intros;intro;intros. inversion H4; subst.
  eapply Step_def. apply H5.
  intros;intro;intros. edestruct H6. apply H8. constructor. assumption.
  eapply sstep. eassumption. apply T_idem. assumption. assumption.
  assert (forall A, subspec ((T F) A) (Step (T F) A)).
  intros;intro;intros. apply H4. apply H3. apply H2. trivial.
  eapply t_gfp_help with (A:=A) in H5.
  intro;intros. apply H5. apply T_id. trivial. trivial.
Qed.

Lemma T_rule_f : forall F, mono F -> (forall A, subspec (F A) (t A)) ->
                           (forall A, subspec (T F A) (t A)).
Proof.
  intros;intro;intros.
  assert (forall A, subspec (T F A) (T t A)).
  intros. apply T_mono; firstorder.
  pose proof T_t.
  assert (forall A, subspec (T F A) (T (T (fun _ => bot)) A)).
  intros.
  intro;intros. apply H2 in H4. inversion H4; subst.
  eapply T_def. eassumption. apply H6. revert H7. apply H5. unfold respectful.
  intros;intro;intros. apply H3. revert H8. apply t_mono. trivial.
  firstorder.
  eapply T_idem in H4.
  pose proof t_T. apply H5. eassumption. trivial.
Qed.

Lemma rule_by_T : forall (F : Spec -> Spec), mono F ->
    (forall A, subspec (F (step A)) (step (T F A))) -> (forall A, subspec (F A) (t A)).
  (* true by lemma 6.2 and fb <= b(Tf) ==> f <= B(Tf) ==> f <= Bdag f ==> f <= t *)
  intros. apply t_gfp'. apply H.
  intros. unfold subspec. intros. apply Step_def with (G := F) (F := T F). eassumption.
  apply H0. trivial.
Qed.

Definition trans (X:Spec) : Spec := fun k P => exists Q, X k Q /\ (forall k', Q k' -> X k' P).

Lemma mono_trans : mono trans.
Proof.
  destruct 2. inversion H0. econstructor; split. apply H. eassumption.
  intros. apply H. apply H2. trivial.
Qed.

Lemma trans_ok_rule : forall X, subspec (trans X) (t X).
  apply rule_by_T. apply mono_trans.
  unfold subspec. intros. destruct H as [Q [HQ H]].
  destruct HQ. specialize (H _ H0). revert H. apply step_mono. apply Tf_id.
  eapply sstep;eauto. apply Tf_idem.
  firstorder. apply T_id.
  exists Q. split. apply Tf_id;assumption. intros. specialize (H k'0 H2). apply Tf_base. assumption.
Qed.

Lemma use_trans : forall A, subspec (trans (t A)) (t A).
apply t_rule. firstorder. apply trans_ok_rule.
Qed.

Lemma use_step : forall F, mono F -> forall A, subspec (step (T F A)) (T F A).
Proof.
  unfold subspec;intros. apply Tf_idem. assumption. apply Tf_base. auto.
Qed.

Lemma tstep: forall F, mono F -> forall A x P,
    forall x', cstep x x' -> T F A x' P -> T F A x P.
Proof.
  intros. apply use_step. assumption. eapply sstep;eassumption.
Qed.
Lemma tdone: forall F, mono F -> forall A x (P:cfg->Prop), P x -> T F A x P.
Proof.
  intros. apply use_step. assumption. eapply sdone;eassumption.
Qed.

Lemma ttrans: forall F, mono F -> forall A x Q P,
    T F A x Q -> (forall y, Q y -> T F A y P) -> T F A x P.
Proof.
  intros. apply Tf_idem. assumption. apply Tf_t. assumption.
  apply trans_ok_rule. unfold trans. exists Q.
  split;assumption.
Qed.

(* X <= step(t X) ==> X <= gfp step *)
(* X <= Step (T X) *)
(* X (step A) <= step ((T X) A) ==> X <= t
   ==> X reaches <= reaches, other stuff *)

(* t_|_ = gfp step ==> t (gfp step) = t (t _|_) = t bot = gfp step *)

(* F : higher order spec  *)
(* F(A) <= step((T F) A)  *)
(* gfp F <= reaches *)
Lemma ok : forall F, mono F ->
    (forall A, subspec (F A) (step (T F A))) ->
    (forall X, subspec X (F X) -> subspec X reaches)
    (* == subspec (gfp F) reaches *).
  intros.
  assert (forall A, subspec (F A) (t A)).
  intros. apply rule_by_T. apply H.
  unfold subspec;intros. apply H0 in H2. revert H2. apply step_mono.
  unfold subspec;intros. apply Tf_idem. assumption.
  revert H2. apply T_mono. assumption. apply Tf_base.
  apply proof_by_t. intro;intros.
  apply H1 in H3. apply H0 in H3.
  revert H3. apply step_mono. apply T_rule_f. assumption. assumption.
Qed.

End relations.

Print Assumptions ok.