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


Require Import TestSuite.admit.
Require Import Coq.Classes.Morphisms Coq.Classes.RelationClasses Coq.Program.Program Coq.Setoids.Setoid.

Global Set Implicit Arguments.

Hint Extern 0 => apply reflexivity : typeclass_instances.

Inductive Comp : Type -> Type :=
| Pick : forall A, (A -> Prop) -> Comp A.

Axiom computes_to : forall A, Comp A -> A -> Prop.

Axiom refine : forall {A} (old : Comp A) (new : Comp A), Prop.

Global Instance refine_PreOrder A : PreOrder (@refine A).
Admitted.
Add Parametric Morphism A
: (@Pick A)
    with signature
    (pointwise_relation _ (flip impl))
      ==> (@refine A)
      as refine_flip_impl_Pick.
  admit.
Defined.
Definition remove_forall_eq' A x B (P : A -> B -> Prop) : pointwise_relation _ impl (P x) (fun z => forall y : A, y = x -> P y z).
  admit.
Defined.
Goal forall A B (x : A) (P : _ -> _ -> Prop),
       refine (Pick (fun n : B => forall y, y = x -> P y n))
              (Pick (fun n : B => P x n)).
Proof.
  intros.
  setoid_rewrite (@remove_forall_eq' _ _ _ _).
  Undo.
  (* This failed with NotConvertible at some time *)
  setoid_rewrite (@remove_forall_eq' _ _ _).


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