(**************************************************************************
* TLC: A library for Coq                                                  *
* Shared definitions for containers                                       *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic LibReflect
  LibRelation LibOperation LibInt LibStruct.
Generalizable Variables A B K T.

(* ********************************************************************** *)
(** * Operators *)

(* ---------------------------------------------------------------------- *)
(** ** Definitions *)

Class BagEmpty T := { empty : T }.
Class BagSingle A T := { single : A -> T }.
Class BagSingleBind A B T := { single_bind : A -> B -> T }.
Class BagIn A T := { is_in : A -> T -> Prop }.
Class BagBinds A B T := { binds : T -> A -> B -> Prop }.
Class BagRead A B T := { read : T -> A -> B }.
Class BagUpdate A B T := { update : T -> A -> B -> T }.
Class BagUnion T := { union : T -> T -> T }.
Class BagInter T := { inter : T -> T -> T }.
Class BagIncl T := { incl : binary T }.
Class BagDisjoint T := { disjoint : binary T }.
Class BagRestrict T K := { restrict : T -> K -> T }.
Class BagRemove T K := { remove : T -> K -> T }.
Class BagFold I F T := { fold : monoid_def I -> F -> T -> I }.
Class BagCard T := { card : T -> nat }.
Class BagDom T Ks := { dom : T -> Ks }.
Class BagIndex A T := { index : T -> A -> Prop }.

Definition notin `{BagIn A T} x m :=
  ~ (is_in x m).

(* ---------------------------------------------------------------------- *)
(** ** Notation *)

Notation "\{}" := (empty)
  : container_scope.
Notation "\{ x }" := (single x)
  : container_scope.
Notation "x '\in' m" := (is_in x m)
  (at level 39) : container_scope.
Notation "x '\notin' E" := (notin x E)
  (at level 39) : container_scope.
Notation "x \:= v" := (single_bind x v)
  (at level 29) : container_scope.
Notation "m [ x ]" := (read m x)
  (at level 9, format "m [ x ]").
Notation "m [ x := v ]" := (update m x v)
  (at level 9, format "m [ x  :=  v ]").

(* DEPRECATED *)
Notation "m \( x )" := (read m x)
  (at level 33, format "m \( x )", only parsing) : container_scope.
Notation "m \( x := v )" := (update m x v)
  (at level 33, format "m \( x := v )", only parsing) : container_scope.

Notation "m1 '\c' m2" := (incl m1 m2)
  (at level 38) : container_scope.
Notation "m1 '\u' m2" := (union m1 m2)
  (at level 37, right associativity) : container_scope.
Notation "m1 '\n' m2" := (inter m1 m2)
  (at level 36, right associativity) : container_scope.
Notation "m1 '\-' m2" := (remove m1 m2)
  (at level 35) : container_scope.
Notation "m1 '\|' m2" := (restrict m1 m2)
  (at level 34) : container_scope.
Notation "m1 '\#' m2" := (disjoint m1 m2)
  (at level 37, right associativity) : container_scope.

Open Scope container_scope.

(* todo: bug with spaces *)
Notation "''{' x '}'" := (single x) (format "''{' x '}'")
  : container_scope.

Notation "M \-- i" := (M \- \{i}) (at level 35) : container_scope.

(* ---------------------------------------------------------------------- *)
(** ** [forall x \in E, P x] notation *)

Notation "'forall_' x '\in' E ',' P" :=
  (forall x, x \in E -> P)
  (at level 200, x ident) : container_scope.
Notation "'forall_' x y '\in' E ',' P" :=
  (forall x y, x \in E -> y \in E -> P)
  (at level 200, x ident, y ident) : container_scope.
Notation "'forall_' x y z '\in' E ',' P" :=
  (forall x y z, x \in E -> y \in E -> z \in E -> P)
  (at level 200, x ident, y ident, z ident) : container_scope.

(* ---------------------------------------------------------------------- *)
(** ** [exists x \in E st P x] notation *)

Notation "'exists_' x '\in' E ',' P" :=
  (exists x, x \in E /\ P)
  (at level 200, x ident) : container_scope.
Notation "'exists_' x y '\in' E ',' P" :=
  (exists x, x \in E /\ y \in E /\ P)
  (at level 200, x ident, y ident) : container_scope.
Notation "'exists_' x y z '\in' E ',' P" :=
  (exists x, x \in E /\ y \in E /\ z \in E /\ P)
  (at level 200, x ident, y ident, z ident) : container_scope.

(* ---------------------------------------------------------------------- *)
(** ** Foreach *)

Definition foreach `{BagIn A T} (P:A->Prop) (E:T) :=
  forall x, x \in E -> P x.

(* ---------------------------------------------------------------------- *)
(** ** [index] for natural numbers *)

Instance int_index : BagIndex int int.
Proof using. intros. constructor. exact (fun n (i:int) => 0 <= i < n). Defined.

Lemma int_index_def : forall (n i : int),
  index n i = (0 <= i < n).
Proof using. auto. Qed.

Global Opaque int_index.

Lemma int_index_le : forall i n m : int,
  index n i -> n <= m -> index m i.
Proof using. introv. do 2 rewrite @int_index_def. math. Qed.

Lemma int_index_prove : forall (n i : int),
  0 <= i -> i < n -> index n i.
Proof using. intros. rewrite~ int_index_def. Qed.

Lemma int_index_succ : forall n i, n >= 0 ->
  index (n + 1) i = (index n i \/ i = n).
Proof using.
  introv P. do 2 rewrite int_index_def. extens. iff H.
  apply classic_left. math.
  destruct H; math.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Derivable *)

(** Bag update can be defined as bag union with a singleton bag *)

Instance bag_update_as_union_single : forall A B T
  `{BagSingleBind A B T} `{BagUnion T},
  BagUpdate A B T.
  constructor. apply (fun m k v => m \u (k \:= v)). Defined.

Global Opaque bag_update_as_union_single.

(* ---------------------------------------------------------------------- *)
(** ** Properties *)

Section Properties.

Context {A T:Type}
  {BI: BagIn A T} {BE: BagEmpty T} {BS: BagSingle A T}
  {BN: BagInter T} {BU: BagUnion T} {BR: BagRemove T T} {BC: BagCard T}
  {BL: BagIncl T} {BD: BagDisjoint T}.

(** In *)

Class In_empty_eq :=
  { in_empty_eq : forall x, x \in \{} = False }.
Class In_empty :=
  { in_empty : forall x, x \in \{} -> False }.

Class Notin_eq :=
  { notin_eq : forall x E, (x \notin E) = ~ (x \in E) }.
Class Notin_empty :=
  { notin_empty : forall x, x \notin \{} }.

Class In_single_eq :=
  { in_single_eq : forall x y, x \in \{y} = (x = y) }.
Class In_single :=
  { in_single : forall x y, x \in \{y} -> x = y }.
Class In_single_self :=
  { in_single_self : forall x, x \in \{x} }.

Class In_extens_eq :=
  { in_extens_eq : forall E F, (forall x, x \in E = x \in F) -> E = F }.
Class In_extens :=
  { in_extens : forall E F, (forall x, x \in E <-> x \in F) -> E = F }.

Class Is_empty_eq :=
  { is_empty_eq : forall E, (E = \{}) = (forall x, x \in E -> False) }.
Class Is_empty_prove :=
  { is_empty_prove : forall E, (forall x, x \in E -> False) -> E = \{} }.
Class Is_empty_inv :=
  { is_empty_inv : forall x E, E = \{} -> x \in E -> False }.
Class Is_nonempty_prove :=
  { is_nonempty_prove : forall x E, x \in E -> E <> \{} }.

Class Is_single_eq :=
  { is_single_eq : forall x E, (E = \{x}) = (x \in E /\ (forall y, y \in E -> y = x)) }.
Class Is_single_prove :=
  { is_single_prove : forall x E, x \in E -> (forall y, y \in E -> y = x) -> E = \{x} }.
Class Is_single_inv :=
  { is_single_inv : forall x y E, E = \{x} -> y \in E -> y = x }.
Class Notin_single_eq :=
  { notin_single_eq : forall x y, x \notin \{y} = (x <> y) }.

Class In_inter_eq :=
  { in_inter_eq : forall x E F, x \in (E \n F) = (x \in E /\ x \in F) }.
Class In_inter :=
  { in_inter : forall x E F, x \in E -> x \in F -> x \in (E \n F) }.
Class In_inter_inv :=
  { in_inter_inv : forall x E F, x \in (E \n F) -> x \in E /\ x \in F }.

Class Notin_inter_eq :=
  { notin_inter_eq : forall x E F, x \notin (E \n F) = (x \notin E \/ x \notin F) }.
Class Notin_inter_l :=
  { notin_inter_l : forall x E F, x \notin E -> x \notin (E \n F) }.
Class Notin_inter_r :=
  { notin_inter_r : forall x E F, x \notin F -> x \notin (E \n F) }.
Class Notin_inter_inv :=
  { notin_inter_inv : forall x E F, x \notin (E \n F) -> x \notin E \/ x \notin F }.

Class In_union_eq :=
  { in_union_eq : forall x (E F : T), x \in (E \u F) = (x \in E \/ x \in F) }.
Class In_union_l :=
  { in_union_l : forall x E F, x \in E -> x \in (E \u F) }.
Class In_union_r :=
  { in_union_r : forall x E F, x \in F -> x \in (E \u F) }.
Class In_union_inv :=
  { in_union_inv : forall x (E F : T), x \in (E \u F) -> (x \in E \/ x \in F) }.

Class Notin_union_eq :=
  { notin_union_eq : forall x E F, x \notin (E \u F) = (x \notin E /\ x \notin F) }.
Class Notin_union :=
  { notin_union : forall x E F, x \notin E -> x \notin F -> x \notin (E \u F) }.
Class Notin_union_inv :=
  { notin_union_inv : forall x E F, x \notin (E \u F) -> x \notin E /\ x \notin F }.

Class In_remove_eq :=
  { in_remove_eq : forall x (E F : T), x \in (E \- F) = (x \in E /\ x \notin F) }.
Class Remove_incl :=
  { remove_incl : forall (E F : T), (E \- F) \c E }.
Class Remove_disjoint :=
  { remove_disjoint : forall (E F : T), F \# (E \- F) }.

(** Incl *)

Class Incl_in_eq :=
  { incl_in_eq : forall E F, (E \c F) = (forall x, x \in E -> x \in F) }.
Class Incl_prove :=
  { incl_prove : forall E F, (forall x, x \in E -> x \in F) -> E \c F }.
Class Incl_inv :=
  { incl_inv : forall x E F, E \c F -> x \in E -> x \in F}.

Class Incl_refl :=
  { incl_refl : refl incl }.
Class Incl_trans :=
  { incl_trans : trans incl }.
Class Incl_antisym := (* note: double inclusion *)
  { incl_antisym : antisym incl }.
Class Incl_order :=
  { incl_order : LibOrder.order incl }.

Class Empty_incl :=
  { empty_incl : forall E, \{} \c E }.
Class Incl_empty :=
  { incl_empty : forall E, (E \c \{}) = (E = \{}) }.
Class Incl_empty_inv :=
  { incl_empty_inv : forall E, E \c \{} -> E = \{} }.

Class Single_incl_r_eq :=
  { single_incl_r_eq : forall x E, (\{x} \c E) = (x \in E) }.
Class Single_incl_r :=
  { single_incl_r : forall x E, x \in E -> \{x} \c E }.

Class Single_incl_l_eq :=
  { single_incl_l_eq : forall x E, (E \c \{x}) = (E = \{} \/ E = \{x}) }.

Class Incl_union_l :=
  { incl_union_l : forall E F G, E \c F -> E \c (F \u G) }.
Class Incl_union_r :=
  { incl_union_r : forall E F G, E \c G -> E \c (F \u G) }.

Class Union_incl_eq :=
  { union_incl_eq : forall E F G, ((E \u F) \c G) = (E \c G /\ F \c G) }.
Class Union_incl :=
  { union_incl : forall E F G, E \c G -> F \c G -> (E \u F) \c G }.
Class Union_incl_inv :=
  { union_incl_inv : forall E F G, (E \u F) \c G -> E \c G /\ F \c G }.

Class Incl_inter_eq :=
  { incl_inter_eq : forall E F G, E \c (F \n G) = (E \c F /\ E \c G) }.
Class Incl_inter :=
  { incl_inter : forall E F G, E \c F -> E \c G -> E \c (F \n G) }.
Class Incl_inter_inv :=
  { incl_inter_inv : forall E F G, E \c (F \n G) -> E \c F /\ E \c G }.

(** Union *)

Class Union_assoc :=
  { union_assoc : assoc union }.
Class Union_comm :=
  { union_comm : comm union }.
Class Union_comm_assoc :=
  { union_comm_assoc : comm_assoc union }.
Class Union_empty_l :=
  { union_empty_l : neutral_l union empty }.
Class Union_empty_r :=
  { union_empty_r : neutral_r union empty }.
Class Union_empty_inv :=
  { union_empty_inv : forall E F, E \u F = \{} -> E = \{} /\ F = \{} }.
Class Union_self :=
  { union_self : idempotent2 union }.

(** Intersection *)

Class Inter_assoc :=
  { inter_assoc : assoc inter }.
Class Inter_comm :=
  { inter_comm : comm inter }.
Class Inter_comm_assoc :=
  { inter_comm_assoc : comm_assoc inter }.
Class Inter_empty_l :=
  { inter_empty_l : absorb_l inter empty }.
Class Inter_empty_r :=
  { inter_empty_r : absorb_r inter empty }.
Class Inter_self :=
  { inter_self : idempotent2 inter }.

(** Removal *)

  (* TODO: add more *)

(** Cardinal *)

Class Card_empty :=
  { card_empty : card \{} = 0%nat }.
Class Card_single :=
  { card_single : forall X, card \{X} = 1%nat }.
Class Card_union :=
  { card_union : forall E F, E \# F -> card (E \u F) = (card E + card F)%nat }.
Class Card_union_le :=
  { card_union_le : forall E F, card (E \u F) <= (card E + card F)%nat }.

(** Disjointness *)

Class Disjoint_sym :=
  { disjoint_sym : sym disjoint }.
Class Disjoint_eq :=
  { disjoint_eq : forall E F, (E \# F) = (forall x, x \in E -> x \in F -> False) }.
Class Disjoint_prove :=
  { disjoint_prove : forall E F, (forall x, x \in E -> x \in F -> False) -> E \# F }.
Class Disjoint_inv :=
  { disjoint_inv : forall x E F, (E \# F) -> x \in E -> x \in F -> False }.
Class Disjoint_single_l_eq :=
  { disjoint_single_l_eq : forall x E, (\{x} \# E) = x \notin E }.
Class Disjoint_single_r_eq :=
  { disjoint_single_r_eq : forall x E, (E \# \{x}) = x \notin E }.

Class Inter_disjoint :=
  { inter_disjoint : forall E F, E \# F -> E \n F = \{} }.

  (* TODO: add more *)

End Properties.

(** Lemmas with premises and operators in the conclusion
    need additional implicit arguments *)

Implicit Arguments is_empty_inv [[A] [T] [BI] [BE] [Is_empty_inv] x E].
Implicit Arguments is_nonempty_prove [[A] [T] [BE] [Is_nonempty_prove] x E].

Implicit Arguments in_single [A T [BI] [BS] [In_single] [x] [y]].
Implicit Arguments is_single_inv [[A] [T] [BI] [BS] [Is_single_inv] x E].

Implicit Arguments in_inter [[A] [T] [BI] [BN] [In_inter] x E F].
Implicit Arguments in_inter_inv [[A] [T] [BI] [BN] [In_inter_inv] x E F].

Implicit Arguments notin_inter_l [[A] [T] [BI] [BN] [Notin_inter_l] x E F].
Implicit Arguments notin_inter_r [[A] [T] [BI] [BN] [Notin_inter_r] x E F].
Implicit Arguments notin_inter_inv [[A] [T] [BI] [BN] [Notin_inter_inv] x E F].

Implicit Arguments in_union_l [[A] [T] [BI] [BU] [In_union_l] x E F].
Implicit Arguments in_union_r [[A] [T] [BI] [BU] [In_union_r] x E F].
Implicit Arguments in_union_inv [[A] [T] [BI] [BU] [In_union_inv] x E F].

Implicit Arguments notin_union [[A] [T] [BI] [BU] [Notin_union] x E F].
Implicit Arguments notin_union_inv [[A] [T] [BI] [BU] [Notin_union_inv] x E F].

Implicit Arguments incl_prove [[A] [T] [BI] [BL] [Incl_prove] E F].
Implicit Arguments incl_inv [[A] [T] [BI] [BL] [Incl_inv] x E F].
Implicit Arguments incl_trans [[T] [BL] [Incl_trans] x z].
Implicit Arguments incl_empty_inv [[T] [BL] [Incl_empty_inv] E].

Implicit Arguments incl_union_l [[T] [BL] [Incl_union_l] E F G].
Implicit Arguments incl_union_r [[T] [BL] [Incl_union_r] E F G].
Implicit Arguments incl_inter [[T] [BL] [Incl_inter] E F G].
Implicit Arguments incl_inter_inv [[T] [BL] [Incl_inter_inv] E F G].

Implicit Arguments union_empty_inv [[T] [BU] [Union_empty_inv] E F].

Implicit Arguments disjoint_sym [[T] [BD] [Disjoint_sym]].
Implicit Arguments disjoint_prove [[A] [T] [BI] [BD] [Disjoint_prove] E F].
Implicit Arguments disjoint_inv [[A] [T] [BI] [BD] [Disjoint_inv] x E F].
Implicit Arguments disjoint_single_l_eq [[A] [T] [BI] [BS] [BD] [Disjoint_single_l_eq]].
Implicit Arguments disjoint_single_r_eq [[A] [T] [BI] [BS] [BD] [Disjoint_single_r_eq]].

(* ---------------------------------------------------------------------- *)
(** ** Derived Properties *)

Section DerivedProperties.

Context {A T:Type}
  {BI: BagIn A T} {BE: BagEmpty T} {BS: BagSingle A T}
  {BN: BagInter T} {BU: BagUnion T} {BR: BagRemove T T} {BC: BagCard T}
  {BL: BagIncl T} {BD: BagDisjoint T}.

(** In *)

Global Instance in_empty_from_in_empty_eq :
  In_empty_eq -> In_empty.
Proof using. constructor. introv I. rewrite~ in_empty_eq in I. Qed.

Global Instance notin_eq_from_nothing :
  Notin_eq.
Proof using. constructor. intros. unfold notin. auto. Qed.

Global Instance notin_empty_from_in_empty_eq :
  In_empty_eq -> Notin_empty.
Proof using. constructor. introv I. rewrite~ in_empty_eq in I. Qed.

Global Instance in_single_from_in_single_eq :
  In_single_eq -> In_single.
Proof using. constructor. introv I. rewrite~ in_single_eq in I. Qed.

Global Instance in_single_self_from_in_single_eq :
  In_single_eq -> In_single_self.
Proof using. constructor. intros. rewrite~ in_single_eq. Qed.

Global Instance in_extens_eq_from_in_extens :
  In_extens -> In_extens_eq.
Proof using. constructor. introv I. apply in_extens. intros. rewrite* I. Qed.

Global Instance is_empty_eq_from_in_empty_eq :
  In_extens -> In_empty_eq -> Is_empty_eq.
Proof using.
  constructor. intros. extens. iff M.
    subst. introv N. rewrite* in_empty_eq in N.
    apply in_extens. iff N. false* M. rewrite* in_empty_eq in N.
Qed.

Global Instance is_empty_prove_from_is_empty_eq :
  Is_empty_eq -> Is_empty_prove.
Proof using. constructor. introv I. rewrite* is_empty_eq. Qed.

Global Instance is_empty_inv_from_is_empty_eq :
  Is_empty_eq -> Is_empty_inv.
Proof using. constructor. introv I1 I2. rewrite* is_empty_eq in I1. Qed.

Global Instance is_nonempty_prove_from_is_empty_eq :
  Is_empty_eq -> Is_nonempty_prove.
Proof using. constructor. introv I1 I2. rewrite is_empty_eq in I2. eauto. Qed.

Global Instance is_single_eq_from_in_single_eq :
  In_extens -> In_single_eq -> Is_single_eq.
Proof using.
  constructor. intros. extens. iff M (M1&M2).
    subst. split. rewrite* in_single_eq. introv N. rewrite* in_single_eq in N.
    apply in_extens. iff N.
      rewrite* (M2 x0). rewrite* in_single_eq.
      rewrite* in_single_eq in N. subst*.
Qed.

Global Instance is_single_prove_from_is_single_eq :
  Is_single_eq -> Is_single_prove.
Proof using. constructor. introv I. rewrite* is_single_eq. Qed.

Global Instance is_single_inv_from_is_single_eq :
  Is_single_eq -> Is_single_inv.
Proof using. constructor. introv I1 I2. rewrite* is_single_eq in I1. Qed.

Global Instance notin_single_eq_from_in_single_eq :
  In_single_eq -> Notin_single_eq.
Proof using. constructor. intros. unfold notin. rewrite in_single_eq. eauto. Qed.

Global Instance in_inter_from_in_inter_eq :
  In_inter_eq -> In_inter.
Proof using. constructor. introv I1 I2. rewrite in_inter_eq. rew_reflect*. Qed.

Global Instance in_inter_inv_from_in_inter_eq :
  In_inter_eq -> In_inter_inv.
Proof using. constructor. introv I. rewrite~ <- in_inter_eq. Qed.

Global Instance notin_inter_l_from_notin_inter_eq :
  Notin_inter_eq -> Notin_inter_l.
Proof using. constructor. introv I. rewrite~ notin_inter_eq. Qed.

Global Instance notin_inter_r_from_notin_inter_eq :
  Notin_inter_eq -> Notin_inter_r.
Proof using. constructor. introv I. rewrite~ notin_inter_eq. Qed.

Global Instance notin_inter_inv_from_notin_inter_eq :
  Notin_inter_eq -> Notin_inter_inv.
Proof using. constructor. introv I. rewrite~ notin_inter_eq in I. Qed.

Global Instance in_union_l_from_in_union_eq :
  In_union_eq -> In_union_l.
Proof using. constructor. introv I. rewrite in_union_eq. rew_reflect*. Qed.

Global Instance in_union_r_from_in_union_eq :
  In_union_eq -> In_union_r.
Proof using. constructor. introv I. rewrite in_union_eq. rew_reflect*. Qed.

Global Instance in_union_inv_from_in_union_eq :
  In_union_eq -> In_union_inv.
Proof using. constructor. introv I. rewrite~ @in_union_eq in I. Qed.

Global Instance notin_union_from_notin_union_eq :
  Notin_union_eq -> Notin_union.
Proof using. constructor. introv I1 I2. rewrite~ notin_union_eq. Qed.

Global Instance notin_union_inv_from_notin_union_eq :
  Notin_union_eq -> Notin_union_inv.
Proof using. constructor. introv I. rewrite~ notin_union_eq in I. Qed.

  (* TODO: in remove properties?*)

(** Incl *)

Global Instance incl_prove_from_in_eq :
  Incl_in_eq -> Incl_prove.
Proof using. constructor. introv I. rewrite* incl_in_eq. Qed.

Global Instance incl_inv_from_in_eq :
  Incl_in_eq -> Incl_inv.
Proof using. constructor. introv I1 I2. rewrite* incl_in_eq in I1. Qed.

Global Instance incl_order_from_incl_in_eq :
  Incl_in_eq -> In_extens -> Incl_order.
Proof using.
  constructor. constructor.
  intros x. rewrite* incl_in_eq.
  intros E F G I1 I2. rewrite incl_in_eq. rewrite incl_in_eq in I1,I2. autos*.
  intros E F I1 I2. rewrite incl_in_eq in I1,I2. apply* in_extens.
Qed.

Global Instance incl_refl_from_incl_order :
  Incl_order -> Incl_refl.
Proof using. constructor. apply order_refl. apply incl_order. Qed.

Global Instance incl_trans_from_incl_order :
  Incl_order -> Incl_trans.
Proof using. constructor. apply order_trans. apply incl_order. Qed.

Global Instance incl_antisym_from_incl_order :
  Incl_order -> Incl_antisym.
Proof using. constructor. apply order_antisym. apply incl_order. Qed.

Global Instance empty_incl_inv_from_incl_in_eq_and_in_empty_eq :
  Incl_in_eq -> In_empty_eq -> Empty_incl.
Proof using.
  constructor. intros. rewrite incl_in_eq. introv M.
  rewrite in_empty_eq in M. false.
Qed.

Global Instance incl_empty_from_in_empty_eq_and_incl_in_eq :
  In_extens -> In_empty_eq -> Incl_in_eq -> Incl_empty.
Proof using.
  constructor. intros. extens. rewrite incl_in_eq. iff M.
    apply in_extens. iff N. applys* M. rewrite in_empty_eq in N. false.
    subst. introv N. rewrite in_empty_eq in N. false.
Qed.

Global Instance incl_empty_inv_from_incl_empty :
  Incl_empty -> Incl_empty_inv.
Proof using. constructor. introv I. rewrite~ incl_empty in I. Qed.

Global Instance single_incl_r_eq_from_in_single_eq_and_and_incl_in_eq :
  In_extens -> In_single_eq -> Incl_in_eq -> Single_incl_r_eq.
Proof using.
  constructor. intros. extens. rewrite incl_in_eq. iff M.
    applys* M. rewrite~ in_single_eq.
    introv N. rewrite in_single_eq in N. subst~.
Qed.

Global Instance single_incl_r_from_single_incl_r_eq:
  Single_incl_r_eq -> Single_incl_r.
Proof using.
  constructor. intros. rewrite single_incl_r_eq. assumption.
Qed.

Global Instance single_incl_l_eq_from_in_empty_eq_and_in_single_eq_and_and_incl_in_eq :
  In_extens -> In_empty_eq -> In_single_eq -> Incl_in_eq -> Single_incl_l_eq.
Proof using.
  constructor. intros. extens. rewrite incl_in_eq. iff M.
    tests: (x \in E).
      right. apply* is_single_prove. introv N. forwards~ R: M y.
        rewrite* in_single_eq in R.
      left. apply in_extens. iff N. forwards~ R: M x0.
        rewrite* in_single_eq in R. subst. false*.
        rewrite in_empty_eq in N. false.
    introv N. rewrite in_single_eq. destruct M.
      subst. rewrite in_empty_eq in N. false.
      subst. rewrite in_single_eq in N. auto.
Qed.

Global Instance union_incl_eq_from_in_union_eq_and_and_incl_in_eq :
  In_extens -> In_union_eq -> Incl_in_eq -> Union_incl_eq.
Proof using.
  constructor. intros. extens. repeat rewrite incl_in_eq. iff M (M1&M2).
    split. intros x N. specializes M x. rewrite* in_union_eq in M.
           intros x N. specializes M x. rewrite* in_union_eq in M.
    intros x N. specializes M1 x. specializes M2 x. rewrite* in_union_eq in N.
Qed.

Global Instance incl_union_l_from_incl_in_eq_and_in_union_eq :
  Incl_in_eq -> In_union_eq -> Incl_union_l.
Proof using.
  constructor. introv I. rewrite incl_in_eq. rewrite incl_in_eq in I.
  (* coqbug on "rewrite incl_in_eq in *" *)
  introv N. rewrite* in_union_eq.
Qed.

Global Instance incl_union_r_from_incl_union_l :
  Incl_union_l -> Union_comm -> Incl_union_r.
Proof using. constructor. introv I. rewrite union_comm. apply* @incl_union_l. Qed.

Global Instance union_incl_from_union_incl_eq :
  Union_incl_eq -> Union_incl_eq.
Proof using. constructor. intros_all. rewrite union_incl_eq. rew_reflect*. Qed.

Global Instance union_incl_inv_from_union_incl_eq :
  Union_incl_eq -> Union_incl_inv.
Proof using. constructor. introv I. rewrite union_incl_eq in I. destruct* I. Qed.

Global Instance incl_inter_eq_from_in_inter_eq_and_and_incl_in_eq :
  In_extens -> In_inter_eq -> Incl_in_eq -> Incl_inter_eq.
Proof using.
  constructor. intros. extens. repeat rewrite incl_in_eq. iff M (M1&M2).
    split. intros x N. specializes M x. rewrite* in_inter_eq in M.
           intros x N. specializes M x. rewrite* in_inter_eq in M.
    intros x N. specializes M1 N. specializes M2 N. rewrite* in_inter_eq.
Qed.

Global Instance incl_inter_from_incl_inter_eq :
  Incl_inter_eq -> Incl_inter.
Proof using. constructor. intros. rewrite* incl_inter_eq. Qed.

Global Instance incl_inter_inv_from_incl_inter_eq :
  Incl_inter_eq -> Incl_inter_inv.
Proof using. constructor. introv N. rewrite* incl_inter_eq in N. Qed.

(** Tactics *)

Hint Rewrite @in_union_eq @in_inter_eq
  @in_empty_eq @in_single_eq : rew_in_eq.

Tactic Notation "contain_by_in_double" :=
  intros_all; apply in_extens; intros;
  autorewrite with rew_in_eq; rew_reflect;
  intuition (try solve [auto|eauto|auto_false|false]).

(** Union *)

Global Instance union_comm_form_in_union_eq :
  In_extens -> In_union_eq -> Union_comm.
Proof using. constructor. contain_by_in_double. Qed.

Global Instance union_assoc_form_in_union_eq :
  In_extens -> In_union_eq -> Union_assoc.
Proof using. constructor. contain_by_in_double. Qed.

Global Instance union_comm_assoc_from_union_comm_and_union_assoc :
  Union_comm -> Union_assoc -> Union_comm_assoc.
Proof using.
  constructor. intros_all. do 2 rewrite union_assoc.
  rewrite (union_comm _ x). auto.
Qed.

Global Instance union_empty_l_from_in_union_eq_and_in_empty_eq :
  In_extens -> In_union_eq -> In_empty_eq -> Union_empty_l.
Proof using. constructor. contain_by_in_double. Qed.

Global Instance union_empty_r_from_union_empty_l :
  Union_empty_l -> Union_comm -> Union_empty_r.
Proof using. constructor. intros_all. rewrite union_comm. apply union_empty_l. Qed.

Global Instance union_empty_inv_from_in_union_eq :
  In_extens -> In_empty_eq -> In_union_eq -> Union_empty_inv.
Proof using.
  constructor. introv N. split.
    apply in_extens. iff R. rewrite <- N. rewrite* in_union_eq. rewrite* in_empty_eq in R.
    apply in_extens. iff R. rewrite <- N. rewrite* in_union_eq. rewrite* in_empty_eq in R.
Qed.

Global Instance union_self_from_in_union_eq :
  In_extens -> In_union_eq -> Union_self.
Proof using. constructor. contain_by_in_double. Qed.

Global Instance notin_union_eq_from_in_union_eq :
  In_union_eq -> Notin_union_eq.
Proof using. constructor. intros. unfold notin. rewrite @in_union_eq. extens*. eauto. Qed.

(** Inter *)

Global Instance inter_comm_form_in_inter_eq :
  In_extens -> In_inter_eq -> Inter_comm.
Proof using. constructor. contain_by_in_double. Qed.

Global Instance inter_assoc_form_in_inter_eq :
  In_extens -> In_inter_eq -> Inter_assoc.
Proof using. constructor. contain_by_in_double. Qed.

Global Instance inter_comm_assoc_from_inter_comm_and_inter_assoc :
  Inter_comm -> Inter_assoc -> Inter_comm_assoc.
Proof using.
  constructor. intros_all. do 2 rewrite inter_assoc.
  rewrite (inter_comm _ x). auto.
Qed.

Global Instance inter_empty_l_from_in_inter_eq_and_in_empty_eq :
  In_extens -> In_inter_eq -> In_empty_eq -> Inter_empty_l.
Proof using. constructor. contain_by_in_double. Qed.

Global Instance inter_empty_r_from_inter_empty_l :
  Inter_empty_l -> Inter_comm -> Inter_empty_r.
Proof using. constructor. intros_all. rewrite inter_comm. apply inter_empty_l. Qed.

Global Instance inter_self_from_in_inter_eq :
  In_extens -> In_inter_eq -> Inter_self.
Proof using. constructor. contain_by_in_double. Qed.

(** Remove *)

Global Instance remove_incl_from_in_remove_eq_and_incl_in_eq :
  In_remove_eq -> Incl_in_eq -> Remove_incl.
Proof using.
  constructor. intros. rewrite incl_in_eq. introv N. rewrite* in_remove_eq in N.
Qed.

Global Instance remove_disjoint_from_in_remove_eq_and_disjoint_eq :
  In_remove_eq -> Disjoint_eq -> Remove_disjoint.
Proof using.
  constructor. intros. rewrite disjoint_eq. introv N M.
  rewrite* in_remove_eq in M.
Qed.

(** Disjoint *)

Global Instance disjoint_prove_from_disjoint_eq :
  Disjoint_eq -> Disjoint_prove.
Proof using. constructor. intros. rewrite* disjoint_eq. Qed.

Global Instance disjoint_inv_from_disjoint_eq :
  Disjoint_eq -> Disjoint_inv.
Proof using. constructor. introv I I1 I2. rewrite* disjoint_eq in I. Qed.

Global Instance disjoint_single_l_eq_from_disjoint_eq_and_in_single_eq :
  Disjoint_eq -> In_single_eq -> Disjoint_single_l_eq.
Proof using.
  constructor. intros. rewrite disjoint_eq. unfold notin. extens. iff M.
    introv N. specializes M N. rewrite* in_single_eq. false.
    introv N1 N2. rewrite in_single_eq in N1. subst. false.
Qed.

Global Instance disjoint_sym_from_disjoint_eq :
  Disjoint_eq -> Disjoint_sym.
Proof using. constructor. intros x y. do 2 rewrite* disjoint_eq. Qed.

Global Instance disjoint_single_r_eq_from_disjoint_single_l :
  Disjoint_single_l_eq -> Disjoint_sym -> Disjoint_single_r_eq.
Proof using.
  constructor. intros_all.
  rewrite (sym_to_eq disjoint_sym). apply disjoint_single_l_eq.
Qed.

Global Instance inter_disjoint_from_disjoint_eq_and_in_inter_eq :
  In_extens -> In_empty_eq -> Disjoint_eq -> In_inter_eq -> Inter_disjoint.
Proof using.
  constructor. introv M. apply in_extens. rewrite disjoint_eq in M. iff N.
    rewrite in_inter_eq in N. false*.
    rewrite in_empty_eq in N. false.
Qed.

End DerivedProperties.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e521m1_9limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


(*
  Simple memory model. Inspired by Vellvm

  Memory cells all have the same type: `CarrierA`.
 *)

From Coq.FSets Require Import
     FSetAVL
     FSetInterface
     FSetFacts
     FSetProperties
     FSetToFiniteSet
     FMapAVL
     FMapInterface
     FMapFacts.

Require Import Coq.Structures.OrderedTypeEx.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Peano_dec.
Require Import Coq.Logic.Decidable.
Require Export Coq.Sets.Ensembles.
Require Import Psatz.

Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Data.Monads.OptionMonad.

Require Import Helix.MSigmaHCOL.CType.
Require Import Helix.Tactics.HelixTactics.
Require Import Helix.Util.OptionSetoid.
Require Import Helix.Util.ListUtil.

Require Import CoLoR.Util.Bool.BoolUtil.

Import MonadNotation.
Open Scope monad_scope.

Definition addr := (nat * nat) % type.
Definition null := (0, 0).

Open Scope nat_scope.

Lemma addr_dec : forall (a b : addr), {a = b} + {a <> b}.
Proof.
  intros [a1 a2] [b1 b2].
  destruct (eq_nat_dec a1 b1);
    destruct (eq_nat_dec a2 b2); subst.
  - left; reflexivity.
  - right. intros H. inversion H; subst. apply n. reflexivity.
  - right. intros H. inversion H; subst. apply n. reflexivity.
  - right. intros H. inversion H; subst. apply n. reflexivity.
Qed.

Module NM := FMapAVL.Make(Nat_as_OT).
Module Import NP := FMapFacts.WProperties_fun(Nat_as_OT)(NM).
Definition NatMap := NM.t.

Module NS := FSetAVL.Make(Nat_as_OT).
Module Import NSP := FSetProperties.WProperties_fun(Nat_as_OT)(NS).
Definition NatSet := NS.t.
Module Import NE := FSetToFiniteSet.WS_to_Finite_set(Nat_as_OT)(NS).

Definition NM_sequence
           {A:Type}
           {m} {M:Monad m}
           (mv: NM.t (m A)): m (NM.t A)
  := NM.fold
       (fun k v acc =>
          v' <- v ;;
             acc' <- acc ;;
             ret (NM.add k v' acc'))
       mv
       (ret (@NM.empty A)).

Lemma NM_NS_In {elt:Type} (k:NM.key) (m:NM.t elt):
  NM.In k m <->
  NS.In k (of_list (map fst (NM.elements  m))).
Proof.
  pose proof (NM.elements_3w m) as U.
  split; intros H.
  -
    rewrite <- NP.of_list_3 with (s:=m) in H.
    unfold NP.of_list, NP.to_list in H.
    generalize dependent (NM.elements m). intros l U H.
    induction l.
    +
      simpl in H.
      apply NP.F.empty_in_iff in H.
      tauto.
    +
      destruct a as [k' v].
      simpl in *.
      destruct (eq_nat_dec k k') as [K|NK].
      *
        (* k=k' *)
        apply NS.add_1.
        auto.
      *
        (* k!=k' *)
        apply NSP.FM.add_neq_iff; try auto.
        apply IHl.
        --
          inversion U.
          auto.
        --
          eapply NP.F.add_neq_in_iff with (x:=k').
          auto.
          apply H.
  -
    rewrite <- NP.of_list_3 with (s:=m).
    unfold NP.of_list, NP.to_list.
    generalize dependent (NM.elements m). intros l U H.
    induction l.
    +
      simpl in H.
      apply NSP.FM.empty_iff in H.
      tauto.
    +
      destruct a as [k' v].
      simpl in *.
      destruct (eq_nat_dec k k') as [K|NK].
      *
        (* k=k' *)
        apply NP.F.add_in_iff.
        auto.
      *
        (* k!=k' *)
        apply NP.F.add_neq_in_iff; auto.
        apply IHl.
        --
          inversion U.
          auto.
        --
          apply NS.add_3 in H; auto.
Qed.

Module Type MBasic (Import CT : CType).

  Definition mem_add (k:nat) (v:t) := NM.add k v.
  Definition mem_delete (k:nat) (m:NatMap t) := NM.remove k m.
  Definition mem_member (k:nat) (m:NatMap t) := NM.mem k m.
  Definition mem_in     (k:nat) (m:NatMap t) := NM.In k m.
  Definition mem_lookup (k:nat) (m:NatMap t) := NM.find k m.
  Definition mem_empty := @NM.empty t.

  Definition mem_block := NatMap t.

  Definition mem_keys_lst (m:NatMap t): list nat :=
    List.map fst (NM.elements m).

  Definition mem_value_lst (m:NatMap t): list t :=
    List.map snd (NM.elements m).

  Definition mem_keys_set (m: mem_block): NatSet :=
    NSP.of_list (mem_keys_lst m).

  Definition mem_block_of_list (lst:list t): mem_block :=
    let fix f l n m :=
        match l with
        | nil => m
        | (x::xs) => f xs (S n) (mem_add n x m)
        end
    in
    f lst 0 (mem_empty).

  (* forcefull union of two memory blocks. conflicts are resolved by
   giving preference to elements of the 1st block *)
  Definition mem_union (m1 m2 : mem_block) : mem_block
    := NM.map2 (fun mx my =>
                  match mx with
                  | Some x => Some x
                  | None => my
                  end) m1 m2.

  Definition is_disjoint (a b: NatSet) : bool :=
    NS.is_empty (NS.inter a b).

  Lemma is_disjoint_Disjoint (s s' : NS.t)
    : Ensembles.Disjoint NS.elt (NE.mkEns s) (NE.mkEns s') <-> is_disjoint s s' = true.
  Proof.
    split.
    -
      intros E.
      destruct E as [E].
      unfold is_disjoint.
      apply NS.is_empty_1.
      unfold NS.Empty.
      intros a.
      specialize (E a).
      intros H.
      rewrite NE.In_In in H.
      apply NE.inter_Intersection in H.
      congruence.
    -
      intros D.
      unfold is_disjoint in D.
      apply NS.is_empty_2 in D.
      apply NE.Empty_Empty_set in D.
      apply Disjoint_intro.
      intros x E.
      unfold Ensembles.In in E.
      apply NE.inter_Intersection in E.
      unfold Ensembles.In in E.
      apply D in E. clear D.
      apply Constructive_sets.Noone_in_empty in E.
      tauto.
  Qed.

  Lemma is_disjoint_sym {a b}:
    is_disjoint a b = is_disjoint b a .
  Proof.
    destruct (is_disjoint a b) eqn:AB;
      destruct (is_disjoint a b) eqn:BA; try inversion AB.
    -
      clear AB.
      symmetry.
      rewrite <- is_disjoint_Disjoint.
      rewrite <- is_disjoint_Disjoint in BA.
      apply Disjoint_intro.
      intros x.
      destruct BA as [BA].
      specialize (BA x).
      intros AB.
      contradict BA.
      apply Constructive_sets.Intersection_inv in AB.
      destruct AB as [A B].
      unfold Ensembles.In.
      apply Intersection_intro; auto.
    -
      clear AB. rename BA into AB.
      symmetry.
      apply not_true_is_false.
      rewrite <- is_disjoint_Disjoint.
      apply BoolUtil.false_not_true in AB.
      rewrite <- is_disjoint_Disjoint in AB.
      intros BA.
      contradict AB.
      apply Disjoint_intro.
      intros x.
      destruct BA as [BA].
      specialize (BA x).
      intros AB.
      contradict BA.
      apply Constructive_sets.Intersection_inv in AB.
      destruct AB as [A B].
      unfold Ensembles.In.
      apply Intersection_intro; auto.
  Qed.

  Definition mem_merge (a b: mem_block) : option mem_block
    :=
      let kx := mem_keys_set a in
      let ky := mem_keys_set b in
      if is_disjoint kx ky
      then Some (mem_union a b)
      else None.

  (* merge two memory blocks using given operation to combine values *)
  Definition mem_merge_with (f: t -> t -> t): mem_block -> mem_block -> mem_block
    :=
      NM.map2 (fun a b =>
                 match a,b with
                 | None, None => None
                 | Some x, None => Some x
                 | None, Some y => Some y
                 | Some x, Some y => Some (f x y)
                 end).

  (* Combine non-empty elements of two memory blocks using given operation.
   Unlike [mem_merge_with], combining [Some _] and [None] results in [None].
   *)
  Definition mem_map2 (f: t -> t -> t): mem_block -> mem_block -> mem_block
    := NM.map2 (liftM2 f).

  (* merge two memory blocks in (0..n-1) using given operation to combine values *)
  Definition mem_merge_with_def
             (f: t -> t -> t)
             (default: t)
    : mem_block -> mem_block -> mem_block
    :=
      NM.map2 (fun a b =>
                 match a,b with
                 | None, None => None
                 | Some x, None => Some (f x default)
                 | None, Some y => Some (f default y)
                 | Some x, Some y => Some (f x y)
                 end).

  (* block of memory with indices (0..n-1) set to `v` *)
  Fixpoint mem_const_block (n:nat) (v: t) : mem_block
    :=
      match n with
      | O => mem_empty
      | S n' => mem_add n' v (mem_const_block n' v)
      end.

  (* ------------------ Proofs below ------------------- *)

  Lemma mem_keys_set_In (k:NM.key) (m:mem_block):
    NM.In k m <-> NS.In k (mem_keys_set m).
  Proof.
    apply NM_NS_In.
  Qed.

  Lemma mem_keys_set_in_union_dec
        (m0 m1 : mem_block)
        (k : NM.key):
    NS.In k (mem_keys_set (mem_union m0 m1)) ->
    {NS.In k (mem_keys_set m1)}+{NS.In k (mem_keys_set m0)}.
  Proof.
    intros H.
    unfold mem_union in H.
    apply mem_keys_set_In, NM.map2_2 in H.
    rewrite 2!NP.F.mem_in_iff in H.
    apply orb_true_intro, orb_true_elim in H.
    inversion H; [right|left] ;
      apply mem_keys_set_In, NP.F.mem_in_iff;
      auto.
  Qed.

  Lemma mem_union_as_Union
        (m m0 m1 : mem_block)
        (MM : mem_union m0 m1 = m)
        (k:NM.key)
    :
      mem_in k m <-> ((mem_in k m0) \/ (mem_in k m1)).
  Proof.
    split.
    -
      intros H.
      subst m.
      unfold mem_union in H.
      apply F.in_find_iff in H.
      erewrite F.map2_1bis in H; try reflexivity.
      break_match_hyp.
      +
        left.
        apply F.in_find_iff.
        eapply Some_ne_None.
        eauto.
      +
        right.
        clear Heqo.
        apply F.in_find_iff.
        apply H.
    -
      intros [H1 | H2];
        subst m;
        unfold mem_union;
        apply F.in_find_iff;
        erewrite F.map2_1bis; try reflexivity; break_match; try some_none.
      +
        apply F.in_find_iff in H1.
        congruence.
      +
        apply F.in_find_iff in H2.
        assumption.
  Qed.

  Lemma mem_union_key_dec
        (m m0 m1 : mem_block)
        (MM : mem_union m0 m1 = m)
        (k:NM.key)
    :
      (NM.In k m -> {NM.In k m0}+{NM.In k m1}) *
      ({NM.In k m0}+{NM.In k m1} -> NM.In k m).
  Proof.
    split; intros H; subst m; unfold mem_union in *.
    -
      apply F.in_find_iff in H.
      erewrite F.map2_1bis in H; try reflexivity.
      break_match.
      +
        left.
        apply F.in_find_iff.
        eapply Some_ne_None.
        eauto.
      +
        right.
        apply F.in_find_iff.
        assumption.
    -
      apply F.in_find_iff.
      erewrite F.map2_1bis.
      +
        destruct H.
        *
          break_match; try some_none.
          apply F.in_find_iff in i.
          congruence.
        *
          break_match; try some_none.
          apply F.in_find_iff in i.
          assumption.
      +
        reflexivity.
  Qed.

  Lemma mem_merge_key_dec
        (m m0 m1 : mem_block)
        (MM : mem_merge m0 m1 = Some m)
        (k:NM.key)
    :
      (NM.In k m -> {NM.In k m0}+{NM.In k m1}) *
      ({NM.In k m0}+{NM.In k m1} -> NM.In k m).
  Proof.
    split.
    -
      intros H.
      rename m into mm.
      destruct (NP.F.In_dec m1 k) as [M1 | M1], (NP.F.In_dec m0 k) as [M0|M0]; auto.
      exfalso. (* Could not be in neither. *)
      unfold mem_merge in MM.
      break_if; inversion MM.
      subst mm. clear MM.
      rewrite mem_keys_set_In in M0, M1.
      clear Heqb.
      apply mem_keys_set_In, mem_keys_set_in_union_dec in H.
      destruct H; auto.
    -
      intros H.
      rename m into mm.
      unfold mem_merge, mem_union in MM.
      break_if; try some_none.
      some_inv.
      clear H1 mm.
      apply F.in_find_iff.
      rewrite F.map2_1bis by reflexivity.
      break_match.
      some_none.
      destruct H as [H | H].
      apply F.in_find_iff in H; congruence.
      apply F.in_find_iff, H.
  Qed.

  Lemma mem_merge_key_not_in
        (m m0 m1 : mem_block)
        (MM : mem_merge m0 m1 = Some m)
        (k: NM.key)
    :
      (not (NM.In k m)) <-> (not (NM.In k m0)) /\ (not (NM.In k m1)).
  Proof.
    split.
    -
      intros H.
      unfold mem_merge in MM.
      break_if; inversion MM.
      clear MM Heqb.
      subst m.
      unfold mem_union in H.
      remember
        (fun mx my : option t =>
           match mx with
           | Some x => Some x
           | None => my
           end) as f.

      pose proof (F.map2_1bis) as F.
      assert(FN: f None None = None) by (subst f; reflexivity).
      specialize (F _ _ t m0 m1 k f FN). clear FN.
      apply F.not_find_in_iff in H.
      rewrite F in H. clear F.
      subst f.
      break_match.
      inversion H.
      split.
      apply F.not_find_in_iff in Heqo; auto.
      apply F.not_find_in_iff in H; auto.
    -
      intros [H0 H1].
      intros H.
      apply mem_merge_key_dec with (m0:=m0) (m1:=m1) in H; auto.
      crush.
  Qed.

  Lemma decidable_mem_in (k:NM.key) (m:mem_block): decidable (mem_in k m).
  Proof.
    unfold decidable.
    destruct (NP.F.In_dec m k); auto.
  Qed.

  Lemma mem_keys_disjoint_inr
        (m1 m2: mem_block)
        (k: NM.key):
    is_disjoint (mem_keys_set m1) (mem_keys_set m2) = true
    -> mem_in k m1 -> not (mem_in k m2).
  Proof.
    intros D M1 M2.
    apply mem_keys_set_In in M1.
    apply mem_keys_set_In in M2.
    generalize dependent (mem_keys_set m1).
    generalize dependent (mem_keys_set m2).
    intros s1 M1 s2 D M2.
    clear m1 m2.
    apply is_disjoint_Disjoint in D.
    rewrite NE.In_In in M1.
    rewrite NE.In_In in M2.
    destruct D as [D].
    specialize (D k).
    contradict D.
    unfold Ensembles.In.
    apply Intersection_intro; auto.
  Qed.

  (* TODO: could be proven <-> *)
  Lemma mem_merge_is_Some
        (m0 m1 : mem_block)
    :
      Ensembles.Disjoint nat (NE.mkEns (mem_keys_set m0))
                         (NE.mkEns (mem_keys_set m1)) -> (mem_merge m0 m1 <> None).
  Proof.
    unfold mem_merge.
    unfold mem_keys_set.
    generalize (NSP.of_list (mem_keys_lst m0)) as s0.
    generalize (NSP.of_list (mem_keys_lst m1)) as s1.
    intros s1 s0 H.
    break_if.
    -
      crush.
    -
      apply is_disjoint_Disjoint in H.
      congruence.
  Qed.

  Lemma Disjoint_of_mem_merge
        {m0 m1 m2 m3: mem_block}
        (M: mem_merge m2 m3 = @Some mem_block m1)
        (D1: Ensembles.Disjoint nat (NE.mkEns (mem_keys_set m0)) (NE.mkEns (mem_keys_set m2)))
        (D2: Ensembles.Disjoint nat (NE.mkEns (mem_keys_set m0)) (NE.mkEns (mem_keys_set m3))):
    Ensembles.Disjoint nat (NE.mkEns (mem_keys_set m0)) (NE.mkEns (mem_keys_set m1)).
  Proof.
    apply Disjoint_intro.
    intros k C.
    apply mem_merge_key_dec with (k:=k) in M.
    -
      destruct C as [k C1 C2].
      destruct M as [[M2| M3] _].
      +
        apply mem_keys_set_In in C2.
        apply C2.
      +
        (* k in `m2` *)
        clear D2.
        apply mem_keys_set_In in M2.
        destruct D1 as [D]; specialize (D k).
        contradict D.
        apply Intersection_intro.
        apply C1.
        apply M2.
      +
        (* k in `m1` *)
        clear D1.
        apply mem_keys_set_In in M3.
        destruct D2 as [D]; specialize (D k).
        contradict D.
        apply Intersection_intro.
        apply C1.
        apply M3.
  Qed.

  Lemma mem_merge_as_Union
        (m m0 m1 : mem_block)
        (k: nat)
    :
      mem_merge m0 m1 = Some m ->
      (mem_in k m <->
       ((mem_in k m0) \/ (mem_in k m1))).
  Proof.
    intros M.
    split; intros H.
    -
      unfold mem_in, mem_merge, mem_union in *.
      break_if; try some_none.
      some_inv.
      apply NP.F.in_find_iff in H.
      rewrite <- H1 in H. clear H1.
      rewrite NP.F.map2_1bis in H by reflexivity.
      repeat break_match; try some_none.
      +
        left.
        apply NP.F.in_find_iff.
        rewrite Heqo.
        some_none.
      +
        right.
        apply NP.F.in_find_iff.
        apply H.
    -
      unfold mem_in, mem_merge, mem_union in *.
      break_if; try some_none.
      some_inv. clear m H1.
      apply F.in_find_iff.
      destruct H.
      rewrite NP.F.map2_1bis by reflexivity.
      repeat break_match; try some_none.
      +
        apply F.in_find_iff in H.
        congruence.
      +
        rewrite NP.F.map2_1bis by reflexivity.
        repeat break_match; try some_none.
        apply NP.F.in_find_iff, H.
  Qed.

  Lemma mem_merge_to_mem_union
        (m m0 m1 : mem_block)
    :
      mem_merge m0 m1 = Some m ->
      mem_union m0 m1 = m.
  Proof.
    intros H.
    unfold mem_merge in H.
    break_if; try some_none.
    apply Some_inj_eq.
    apply H.
  Qed.

  Lemma mem_merge_with_as_Union
        (dot : t -> t -> t)
        (m1 m2 : mem_block)
        (k:nat)
    :
      ((mem_in k m1) \/ (mem_in k m2)) <->
      mem_in k (mem_merge_with dot m1 m2).
  Proof.
    split.
    --
      intros H.
      destruct (NP.F.In_dec m1 k) as [M1 | M1], (NP.F.In_dec m2 k) as [M0|M0];
        unfold mem_in, mem_merge_with in *;
        apply NP.F.in_find_iff;
        rewrite NM.map2_1; try apply H;

          rewrite mem_keys_set_In in M0, M1;
          repeat break_match; try some_none;
            apply NP.F.not_find_in_iff in Heqo;
            apply NP.F.not_find_in_iff in Heqo0;
            crush.
    --
      intros H.
      unfold mem_in, mem_merge_with in *.
      apply NP.F.in_find_iff in H.
      rewrite NP.F.map2_1bis in H by reflexivity.
      repeat break_match; try some_none;
        try apply Some_ne_None, NP.F.in_find_iff in Heqo;
        try apply Some_ne_None, NP.F.in_find_iff in Heqo0; crush.
  Qed.

  Lemma mem_merge_with_def_as_Union
        (dot : t -> t -> t)
        (initial: t)
        (m1 m2 : mem_block)
        (k:nat)
    :
      ((mem_in k m1) \/ (mem_in k m2)) <->
      mem_in k (mem_merge_with_def dot initial m1 m2).
  Proof.
    split.
    --
      intros H.
      destruct (NP.F.In_dec m1 k) as [M1 | M1], (NP.F.In_dec m2 k) as [M0|M0];
        unfold mem_in, mem_merge_with_def in *;
        apply NP.F.in_find_iff;
        rewrite NM.map2_1; try apply H;

          rewrite mem_keys_set_In in M0, M1;
          repeat break_match; try some_none;
            apply NP.F.not_find_in_iff in Heqo;
            apply NP.F.not_find_in_iff in Heqo0;
            crush.
    --
      intros H.
      unfold mem_in, mem_merge_with_def in *.
      apply NP.F.in_find_iff in H.
      rewrite NP.F.map2_1bis in H by reflexivity.
      repeat break_match; try some_none;
        try apply Some_ne_None, NP.F.in_find_iff in Heqo;
        try apply Some_ne_None, NP.F.in_find_iff in Heqo0; crush.
  Qed.

  Lemma mem_merge_with_not_as_Union
        (dot : t -> t -> t)
        (m1 m2 : mem_block)
        (k:nat)
    :
      (not (mem_in k m1)) -> (not (mem_in k m2)) ->
      not (mem_in k (mem_merge_with dot m1 m2)).
  Proof.
    intros H0 H1 H.
    apply mem_merge_with_as_Union in H.
    crush.
  Qed.

  Lemma mem_const_block_find
        (n : nat)
        (v : t)
        (j : nat):
    (j < n) -> (NM.find j (mem_const_block n v) = Some v).
  Proof.
    intros jc.
    induction n.
    -
      nat_lt_0_contradiction.
    -
      simpl.
      destruct (eq_nat_dec j n) as [N | NN].
      +
        subst.
        rewrite F.add_eq_o; reflexivity.
      +
        rewrite F.add_neq_o; auto.
        apply IHn.
        lia.
  Qed.

  Lemma mem_const_block_In_oob
        (n : nat)
        (v : t)
        (j : nat):
    (j >= n) -> (not (NM.In j (mem_const_block n v))).
  Proof.
    intros jc.
    induction n.
    -
      simpl.
      unfold mem_empty.
      intros C.
      apply F.empty_in_iff in C.
      tauto.
    -
      simpl.
      unfold mem_add.
      intros C.
      apply F.add_in_iff in C.
      destruct C.
      +
        crush.
      +
        crush.
  Qed.

  Lemma mem_const_block_find_oob
        (n : nat)
        (v : t)
        (j : nat):
    (j >= n) -> (NM.find j (mem_const_block n v) = None).
  Proof.
    intros jc.
    apply F.not_find_in_iff.
    apply mem_const_block_In_oob.
    apply jc.
  Qed.

  Section Memory_Blocks.

    (* memory is a map of memory blocks *)
    Definition memory := NatMap mem_block.

    Definition memory_empty : memory := NM.empty _.

    Definition memory_lookup
               (m: memory)
               (n: nat)
      : option mem_block
      := NM.find n m.

    Definition memory_set
               (m: memory)
               (n: nat)
               (v: mem_block)
      : memory
      :=
        NM.add n v m.

    Definition memory_remove
               (m: memory)
               (n: nat)
      : memory
      :=
        NM.remove n m.

    (* memory [m] has block [b] under id [n] *)
    Definition memory_mapsto (m : memory) (n : nat) (b : mem_block) :=
      NM.MapsTo (elt:=mem_block) n b m.

    Definition mem_block_exists: nat -> memory -> Prop
      := NM.In (elt:=mem_block).

    Lemma decidable_mem_block_exists (k:NM.key) (m:memory): decidable (mem_block_exists k m).
    Proof.
      unfold decidable.
      destruct (NP.F.In_dec m k); auto.
    Qed.

    Definition memory_keys_lst (m:memory): list nat :=
      List.map fst (NM.elements m).

    Definition memory_keys_set (m: memory): NatSet :=
      NSP.of_list (memory_keys_lst m).

    (* Returns block ID which is guaraneed to be free in [m] *)
    Definition memory_next_key
               (m: memory): nat
      :=  match NS.max_elt (memory_keys_set m) with
          | None => 0
          | Some k => S k
          end.

    (* forced union of two memory states. conflicts are resolved by
       giving preference to elements of the 1st state *)
    Definition memory_union (m1 m2 : memory) : memory
      := NM.map2 (fun mx my =>
                    match mx with
                    | Some x => Some x
                    | None => my
                    end) m1 m2.

    Lemma mem_block_exists_exists (m:memory) (k:nat):
      mem_block_exists k m <-> exists y : mem_block, memory_lookup m k = Some y.
    Proof.
      split; intros H.
      -
        apply NP.F.in_find_iff, is_Some_ne_None, MathClasses.misc.util.is_Some_def in H.
        apply H.
      -
        apply NP.F.in_find_iff, is_Some_ne_None, MathClasses.misc.util.is_Some_def.
        apply H.
    Qed.

    Lemma mem_block_not_exists_exists (m:memory) (k:nat):
      not (mem_block_exists k m) <-> memory_lookup m k = None.
    Proof.
      split; intros H; unfold mem_block_exists in *.
      -
        apply F.not_find_in_iff, H.
      -
        intros H1.
        unfold memory_lookup in H.
        apply F.not_find_in_iff in H1; congruence.
    Qed.

    Lemma memory_is_set_is_Some (m:memory) (k:nat):
      mem_block_exists k m <-> MathClasses.misc.util.is_Some (memory_lookup m k).
    Proof.
      unfold mem_block_exists, memory_lookup, MathClasses.misc.util.is_Some.
      split; intros H.
      -
        apply NP.F.in_find_iff in H.
        break_match; auto.
      -
        apply NP.F.in_find_iff.
        break_match_hyp; auto.
        some_none.
    Qed.

    Lemma mem_block_exists_memory_remove (k:nat) (m:memory):
      not (mem_block_exists k (memory_remove m k)).
    Proof.
      unfold mem_block_exists, memory_remove.
      apply NM.remove_1.
      reflexivity.
    Qed.

    Lemma mem_block_exists_memory_remove_neq
          {k k' m}
          (NK:k <> k'):
      mem_block_exists k m <-> mem_block_exists k (memory_remove m k').
    Proof.
      unfold mem_block_exists, memory_remove.
      split; intros H.
      -
        apply NP.F.remove_neq_in_iff; auto.
      -
        apply NP.F.remove_neq_in_iff in H; auto.
    Qed.

    Lemma mem_block_exists_memory_set {k k' m v}:
      mem_block_exists k m ->
      mem_block_exists k (memory_set m k' v).
    Proof.
      unfold mem_block_exists, memory_set.
      intros H.
      destruct (Nat.eq_dec k k').
      -
        apply NP.F.add_in_iff.
        left.
        auto.
      -
        apply NP.F.add_in_iff.
        right.
        auto.
    Qed.

    Lemma mem_block_exists_memory_set_inv {k k' m v}:
      mem_block_exists k (memory_set m k' v) ->
      ((mem_block_exists k m) \/ k=k').
    Proof.
      unfold mem_block_exists, memory_set.
      intros H.
      destruct (Nat.eq_dec k k') as [kc|kc].
      -
        right.
        assumption.
      -
        left.
        apply F.add_in_iff in H.
        destruct H.
        +
          congruence.
        +
          apply H.
    Qed.

    Lemma mem_block_exists_memory_set_eq
          {k k' m v}
          (NK:k = k'):
      mem_block_exists k (memory_set m k' v).
    Proof.
      unfold mem_block_exists, memory_set.
      apply F.add_in_iff.
      auto.
    Qed.

    Lemma mem_block_exists_memory_set_neq
          {k k' m v}
          (NK:k <> k'):
      mem_block_exists k m <-> mem_block_exists k (memory_set m k' v).
    Proof.
      unfold mem_block_exists, memory_set.
      split; intros H.
      -
        apply NP.F.add_neq_in_iff; auto.
      -
        apply NP.F.add_neq_in_iff in H; auto.
    Qed.

    Lemma memory_keys_set_In (k:NM.key) (m:memory):
      NM.In k m <-> NS.In k (memory_keys_set m).
    Proof.
      apply NM_NS_In.
    Qed.

    Lemma memory_next_key_S m n:
      memory_next_key m = S n ->
      mem_block_exists n m.
    Proof.
      intros H.
      unfold memory_next_key in H.
      break_match_hyp ; inv H.
      apply memory_keys_set_In.
      apply Memory.NS.max_elt_1.
      auto.
    Qed.

    Lemma mem_block_exists_memory_next_key
          (m : memory):
      not (mem_block_exists (memory_next_key m) m).
    Proof.
      unfold mem_block_exists, memory_next_key.
      break_match; rename Heqo into H.
      -
        rewrite memory_keys_set_In.
        revert H.
        generalize (memory_keys_set m) as ms.
        intros ms H C.
        clear m.
        apply NS.max_elt_2  with (y:=S e) in H; auto.
      -

        apply NS.max_elt_3 in H.
        rewrite memory_keys_set_In.
        apply MP.empty_is_empty_1 in H.
        unfold NS.Equal in *.
        intros C.
        apply H in C.
        apply FM.empty_iff in C.
        congruence.
    Qed.

    Lemma mem_block_exists_next_key_gt:
      forall k m, mem_block_exists k m -> memory_next_key m > k.
    Proof.
      intros k m H.
      unfold mem_block_exists in H.
      unfold memory_next_key.
      apply memory_keys_set_In in H.
      generalize dependent (memory_keys_set m).
      intros s H.
      clear m.
      break_match.
      -
        apply NS.max_elt_2 with (y:=k) in Heqo.
        lia.
        apply H.
      -
        rename Heqo into E.
        apply NS.max_elt_3 in E.
        apply empty_is_empty_1 in E.
        rewrite E in H.
        apply FM.empty_iff in H.
        inversion H.
    Qed.

    Lemma memory_set_memory_next_key_gt m1 m2 b k:
      m2 = memory_set m1 k b ->
      memory_next_key m2 > k.
    Proof.
      intros H.

      assert(mem_block_exists k m2) as E.
      {
        subst m2.
        apply mem_block_exists_memory_set_eq; reflexivity.
      }
      apply mem_block_exists_next_key_gt, E.
    Qed.

    Lemma memory_lookup_memory_next_key_is_None (m:memory):
      MathClasses.misc.util.is_None (memory_lookup m (memory_next_key m)).
    Proof.
      pose proof (mem_block_exists_memory_next_key m) as P.
      apply mem_block_not_exists_exists in P.
      unfold MathClasses.misc.util.is_None.
      break_match; try some_none; auto.
    Qed.

    (* Also there is an [equiv] version elsewhere *)
    Lemma memory_lookup_not_next {m k v}:
      memory_lookup m k = Some v ->
      k <> memory_next_key m.
    Proof.
      intros H.
      destruct (eq_nat_dec k (memory_next_key m)) as [E|NE]; [exfalso|auto].
      rewrite E in H.
      pose proof (memory_lookup_memory_next_key_is_None m) as N.
      rewrite H in N.
      some_none.
    Qed.

    Lemma memory_mapsto_memory_lookup k v m:
      memory_mapsto m k v <-> memory_lookup m k = Some v.
    Proof.
      unfold memory_mapsto, memory_lookup.
      split.
      - apply NM.find_1.
      - apply NM.find_2.
    Qed.

  End Memory_Blocks.

End MBasic.


Require List.
Import List.ListNotations.
Local Open Scope list_scope.
Require Import Program.

Definition Shape := list (list Type).

Inductive fin : nat -> Type :=
  | FZ : forall {n}, fin (S n)
  | FS : forall {n}, fin n -> fin (S n).

Fixpoint nat_to_fin (m : nat) (n : nat) : option (fin m) :=
  match m, n with
  | S m', 0 => Some FZ
  | S m', S n' => option_map FS (nat_to_fin m' n')
  | _, _ => None
  end.

Fixpoint weaken {m} (n : fin m) : fin (S m) :=
  match n with
  | FZ => FZ
  | FS n' => FS (weaken n')
  end.

Inductive hlist : list Type -> Type :=
  | HNil : hlist nil
  | HCons : forall {x xs}, x -> hlist xs -> hlist (x :: xs).

Inductive At {A} : nat -> A -> list A -> Prop :=
  | Here : forall {x xs}, At 0 x (x :: xs)
  | There : forall {x y xs n}, At n x xs -> At (S n) x (y :: xs).

Fixpoint index {A} (i : nat) (l : list A) {struct l} : option A :=
  match l with
  | [] => None
  | x :: xs =>
    match i with
    | 0 => Some x
    | S i' => index i' xs
    end
  end.

Fixpoint indexT (i : nat) (l : list Type) {struct l} : Type :=
  match l with
  | [] => False
  | x :: xs =>
    match i with
    | 0 => x
    | S i' => indexT i' xs
    end
  end.

Inductive union (xs : list Type) : Type :=
  u_intro : forall (i : nat) {x : Type}, indexT i xs -> union xs.

Definition Rep (s : Shape) := union (List.map hlist s).

Class Generic (a : Type) := {
  shape : Shape;
  construct : Rep shape -> a;
  destruct : a -> Rep shape;
  construct_destruct : forall (x : a), construct (destruct x) = x;
  destruct_construct : forall (x : Rep shape), destruct (construct x) = x
}.
Instance Generic_unit : Generic unit := {
  shape := [[]];
  construct _ := tt;
  destruct _ := u_intro [hlist []] 0 HNil
}.
exact (hlist []).
intro x. destruct x. auto.
intro x. destruct x.
destruct i; simpl in i0.
dependent destruction i0. simpl. reflexivity.
simpl in e. inversion e. subst x. pattern e.
dependent destruction e.
dependent destruction x0. reflexivity.
simpl in e. inversion e.
Defined.

Instance Generic_sum {A B} {_ : Generic A} {_ : Generic B} : Generic (A + B) := {
  shape := [[A]; [B]];
  destruct x :=
    match x with
    | inl a => u_intro _ 0 _ (HCons a HNil)
    | inr b => u_intro _ 1 _ (HCons b HNil)
    end
}.
- intro. destruct X.
  destruct i.
  * simpl in e. inversion e. subst x.
    dependent destruction x0. constructor. assumption.
  * simpl in e. inversion e.
    destruct i; try (inversion e).
    subst x. dependent destruction x0.
    right. assumption.
- reflexivity.
- reflexivity.
- intros x.
  case x; intro; reflexivity.
-intro x.
 dependent inversion x; simpl.
Admitted.


Require Import rt.util.all.
Require Import rt.model.arrival.basic.task.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.

Module ConcreteTask.

  Import SporadicTaskset.

  Section Defs.

    (* Definition of a concrete task. *)
    Record concrete_task :=
    {
      task_id: nat; (* for uniqueness *)
      task_cost: nat;
      task_period: nat;
      task_deadline: nat;
      task_jitter: nat
    }.

    (* To make it compatible with ssreflect, we define a decidable
       equality for concrete tasks. *)
    Definition task_eqdef (t1 t2: concrete_task) :=
      (task_id t1 == task_id t2) &&
      (task_cost t1 == task_cost t2) &&
      (task_period t1 == task_period t2) &&
      (task_deadline t1 == task_deadline t2) &&
      (task_jitter t1 == task_jitter t2).

    (* Next, we prove that task_eqdef is indeed an equality, ... *)
    Lemma eqn_task : Equality.axiom task_eqdef.
    Proof.
      unfold Equality.axiom; intros x y.
      destruct (task_eqdef x y) eqn:EQ.
      {
        apply ReflectT.
        unfold task_eqdef in *.
        move: EQ => /andP [/andP [/andP [/andP [/eqP ID /eqP COST] /eqP PERIOD] /eqP DL] /eqP JITTER].
        by destruct x, y; simpl in *; subst.
      }
      {
        apply ReflectF.
        unfold task_eqdef, not in *; intro BUG.
        apply negbT in EQ; rewrite negb_and in EQ.
        destruct x, y.
        rewrite negb_and in EQ.
        move: EQ => /orP [/orP [EQ | /eqP DL] | /eqP JITTER]; last by apply JITTER; inversion BUG.
        rewrite negb_and in EQ.
        move: EQ => /orP [EQ | /eqP DL]; last by apply DL; inversion BUG.
        rewrite negb_and in EQ.
        move: EQ => /orP [/eqP ID | /eqP PERIOD]; last by apply PERIOD; inversion BUG.
        by apply ID; inversion BUG.
        by apply DL; inversion BUG.
      }
    Qed.

    (* ..., which allows instantiating the canonical structure. *)
    Canonical concrete_task_eqMixin := EqMixin eqn_task.
    Canonical concrete_task_eqType := Eval hnf in EqType concrete_task concrete_task_eqMixin.

  End Defs.

  Section ConcreteTaskset.

    Definition concrete_taskset :=
      taskset_of concrete_task_eqType.

  End ConcreteTaskset.

End ConcreteTask.


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

(* *************************************************************************

          Buchberger : multiplication by a scalar, definition of Pmults

          Laurent Thery March 1998 (revised April 2001)

  ************************************************************************** *)

From Buchberger Require Export Pplus.

Set Default Proof Using "Type".

Section Pmults.
Load hCoefStructure.
Load hOrderStructure.
Load hPlus.

Set Implicit Arguments.
Unset Strict Implicit.

Definition mults : Term A n -> list (Term A n) -> list (Term A n).
intros a p; elim p; clear p.
exact (pO A n).
intros b p1 p'1.
exact (pX (multTerm (A:=A) multA (n:=n) a b) p'1).
Defined.

Set Strict Implicit.
Unset Implicit Arguments.

Local Hint Resolve multTerm_eqT : core.
Local Hint Resolve invTerm_eqT : core.
Local Hint Resolve T1_is_min_ltT : core.

Lemma mults_order_l :
 forall l m1 m2,
 ~ zeroP (A:=A) A0 eqA (n:=n) m1 ->
 canonical A0 eqA ltM (pX m2 l) ->
 canonical A0 eqA ltM (pX (multTerm (A:=A) multA (n:=n) m1 m2) (mults m1 l)).
Proof using plusA os minusA invA eqA_dec divA cs A1.
intros l; elim l; simpl in |- *; auto.
intros m1 m2 H' H'0.
apply canonicalp1; auto.
red in |- *; intros H'1; apply H'.
elim multTerm_zeroP_div with (1 := cs) (a := m1) (b := m2); auto; intros H'5.
absurd (zeroP (A:=A) A0 eqA (n:=n) m2); auto.
apply canonical_nzeroP with (ltM := ltM) (p := pO A n); auto.
intros a l0 H' m1 m2 H'0 H'1.
apply canonical_cons; auto.
apply multTerm_ltT_l; auto.
apply (canonical_pX_order A A0 eqA) with (l := l0); auto.
red in |- *; intros H'2; apply H'0.
elim multTerm_zeroP_div with (1 := cs) (a := m1) (b := m2); auto; intros H'5.
absurd (zeroP (A:=A) A0 eqA (n:=n) m2); auto.
apply canonical_nzeroP with (ltM := ltM) (p := pX a l0); auto.
apply H'; auto.
apply canonical_imp_canonical with (a := m2); auto.
Qed.

Lemma canonical_mults :
 forall m l,
 ~ zeroP (A:=A) A0 eqA (n:=n) m ->
 canonical A0 eqA ltM l -> canonical A0 eqA ltM (mults m l).
Proof using plusA os minusA invA eqA_dec divA cs A1.
intros m l; elim l; simpl in |- *; auto.
intros a l0 H' H'0 H'1.
apply mults_order_l; auto.
Qed.

Lemma canonical_mults_inv :
 forall (p : list (Term A n)) (a : Term A n),
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 canonical A0 eqA ltM (mults a p) -> canonical A0 eqA ltM p.
Proof using plusA os minusA ltM_dec invA divA cs A1.
intros p; elim p; simpl in |- *; auto.
intros a l; case l; simpl in |- *; auto.
intros H' a0 H'0 H'1.
change (canonical A0 eqA ltM (pX a (pO A n))) in |- *; apply canonicalp1;
 auto.
red in |- *; intros H'2;
 absurd (zeroP (A:=A) A0 eqA (n:=n) (multTerm (A:=A) multA (n:=n) a0 a));
 auto.
apply canonical_nzeroP with (ltM := ltM) (p := pO A n); auto.
intros a0 l0 H' a1 H'0 H'1.
change (canonical A0 eqA ltM (pX a (pX a0 l0))) in |- *.
apply canonical_cons; auto.
case (ltT_dec A n ltM ltM_dec a0 a);
 [ intros temp; case temp; clear temp | idtac ]; intros H;
 auto.
absurd
 (ltT ltM (multTerm (A:=A) multA (n:=n) a1 a)
    (multTerm (A:=A) multA (n:=n) a1 a0)); auto.
apply ltT_not_ltT; auto.
apply (canonical_pX_order A A0 eqA) with (l := mults a1 l0); auto.
apply multTerm_ltT_l with (1 := os); auto.
absurd
 (ltT ltM (multTerm (A:=A) multA (n:=n) a1 a0)
    (multTerm (A:=A) multA (n:=n) a1 a)); auto.
apply (canonical_pX_order A A0 eqA) with (l := mults a1 l0); auto.
red in |- *; intros H'2;
 absurd (zeroP (A:=A) A0 eqA (n:=n) (multTerm (A:=A) multA (n:=n) a1 a));
 auto.
apply canonical_nzeroP with (ltM := ltM) (p := mults a1 l0); auto.
apply canonical_skip_fst with (b := multTerm (A:=A) multA (n:=n) a1 a0); auto.
apply H' with (a := a1); auto.
apply canonical_imp_canonical with (a := multTerm (A:=A) multA (n:=n) a1 a);
 auto.
Qed.

Set Implicit Arguments.
Unset Strict Implicit.

Definition tmults : Term A n -> list (Term A n) -> list (Term A n).
intros a; case (zeroP_dec A A0 eqA eqA_dec n a); intros Z0.
intros H'; exact (pO A n).
intros p; exact (mults a p).
Defined.

Set Strict Implicit.
Unset Implicit Arguments.

Theorem tmults_zerop_eqp_pO :
 forall p a,
 zeroP (A:=A) A0 eqA (n:=n) a -> eqP A eqA n (tmults a p) (pO A n).
Proof.
intros p a; unfold tmults in |- *; case (zeroP_dec A A0 eqA eqA_dec n a);
 auto.
intros H' H'0; elim H'; auto.
Qed.

Theorem mults_eqp_pO_pO :
 forall p a, eqP A eqA n p (pO A n) -> eqP A eqA n (mults a p) (pO A n).
Proof.
unfold pO in |- *; intros p a H'; inversion H'; auto.
Qed.

Theorem eqp_invT1_pO_is_pO :
 forall p : list (Term A n),
 eqP A eqA n (mults (invTerm (A:=A) invA (n:=n) (T1 A1 n)) p) (pO A n) ->
 eqP A eqA n p (pO A n).
Proof.
intros p; case p; simpl in |- *; auto.
intros a l H'; inversion H'.
Qed.

Theorem mults_eqp_zpO :
 forall a : Term A n,
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 forall p : list (Term A n),
 eqP A eqA n (mults a p) (pO A n) -> eqP A eqA n p (pO A n).
Proof.
intros a H' p; elim p; simpl in |- *; auto.
intros a0 l H'0 H'1; inversion H'1; auto.
Qed.

Theorem mults_dist1 :
 forall p a b,
 eqT a b ->
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b ->
 ~ zeroP (A:=A) A0 eqA (n:=n) (plusTerm (A:=A) plusA (n:=n) a b) ->
 canonical A0 eqA ltM p ->
 eqP A eqA n (mults (plusTerm (A:=A) plusA (n:=n) a b) p)
   (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
      (mults a p) (mults b p)).
Proof using os minusA invA divA cs A1.
intros p; elim p; simpl in |- *; auto.
intros; apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n);
 apply p0_pluspf_l with (1 := cs); auto.
intros a l H' a0 b H'0 H'1 H'2 H'3 H'4.
cut (canonical A0 eqA ltM l); try apply canonical_imp_canonical with (a := a);
 auto; intros C0.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pX
            (plusTerm (A:=A) plusA (n:=n) (multTerm (A:=A) multA (n:=n) a0 a)
               (multTerm (A:=A) multA (n:=n) b a))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (mults a0 l) (mults b l)));
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pX
            (plusTerm (A:=A) plusA (n:=n) (multTerm (A:=A) multA (n:=n) a0 a)
               (multTerm (A:=A) multA (n:=n) b a))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (mults a0 l) (mults b l)));
 auto.
apply (eqpP1 _ eqA n); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply multTerm_plusTerm_dist_l with (1 := cs); auto.
apply pluspf_inv3b with (1 := cs); auto.
red in |- *; intros H'5;
 absurd
  (zeroP (A:=A) A0 eqA (n:=n)
     (multTerm (A:=A) multA (n:=n) (plusTerm (A:=A) plusA (n:=n) a0 b) a));
 auto.
red in |- *; intros H'6.
elim
 multTerm_zeroP_div
  with (1 := cs) (a := plusTerm (A:=A) plusA (n:=n) a0 b) (b := a);
 auto.
intros H'7; absurd (zeroP (A:=A) A0 eqA (n:=n) a); auto.
apply canonical_nzeroP with (ltM := ltM) (p := l); auto.
apply
 zeroP_comp_eqTerm
  with
    (1 := cs)
    (a := plusTerm (A:=A) plusA (n:=n) (multTerm (A:=A) multA (n:=n) a0 a)
            (multTerm (A:=A) multA (n:=n) b a)); auto.
apply multTerm_plusTerm_dist_l with (1 := cs); auto.
Qed.

Theorem mults_dist2 :
 forall (p : list (Term A n)) (a b : Term A n),
 eqT a b ->
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b ->
 zeroP (A:=A) A0 eqA (n:=n) (plusTerm (A:=A) plusA (n:=n) a b) ->
 canonical A0 eqA ltM p ->
 eqP A eqA n (pO A n)
   (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
      (mults a p) (mults b p)).
Proof using os minusA invA divA cs A1.
intros p; elim p; simpl in |- *; auto.
intros; apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
intros a l H' a0 b H'0 H'1 H'2 H'3 H'4.
cut (canonical A0 eqA ltM l); try apply canonical_imp_canonical with (a := a);
 auto; intros C0.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults a0 l) (mults b l)); auto.
apply pluspf_inv3a with (1 := cs); auto.
apply
 zeroP_comp_eqTerm
  with
    (1 := cs)
    (a := multTerm (A:=A) multA (n:=n) (plusTerm (A:=A) plusA (n:=n) a0 b) a);
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply multTerm_plusTerm_dist_l with (1 := cs); auto.
Qed.

Theorem mults_T1 :
 forall (p : list (Term A n)) (a : Term A n),
 eqTerm (A:=A) eqA (n:=n) a (T1 A1 n) -> eqP A eqA n (mults a p) p.
Proof using plusA minusA invA divA cs A0.
intros p; elim p; auto.
simpl in |- *; auto.
intros a l H a0 H0;
 change
   (eqP A eqA n (pX (multTerm (A:=A) multA (n:=n) a0 a) (mults a0 l))
      (pX a l)) in |- *; auto.
apply (eqpP1 A eqA n); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); apply T1_multTerm_l with (1 := cs);
 auto.
Qed.

Theorem mults_invTerm :
 forall (p : list (Term A n)) (a : Term A n),
 eqTerm (A:=A) eqA (n:=n) a (T1 A1 n) ->
 eqP A eqA n
   (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec p
      (mults (invTerm (A:=A) invA (n:=n) a) p)) (pO A n).
Proof using os minusA divA cs.
intros p; elim p; simpl in |- *; auto.
intros a l H' a0 H'0.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            l (mults (invTerm (A:=A) invA (n:=n) a0) l));
 auto.
change
  (eqP A eqA n
     (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
        (pX a l)
        (pX (multTerm (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) a0) a)
           (mults (invTerm (A:=A) invA (n:=n) a0) l)))
     (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec l
        (mults (invTerm (A:=A) invA (n:=n) a0) l)))
 in |- *.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); apply pluspf_inv3a with (1 := cs);
 auto.
apply (eqT_trans A n) with (y := multTerm (A:=A) multA (n:=n) a0 a); auto.
apply (T1_eqT _ A1 eqA); auto.
apply
 zeroP_comp_eqTerm
  with
    (1 := cs)
    (a := plusTerm (A:=A) plusA (n:=n) a (invTerm (A:=A) invA (n:=n) a));
 auto.
apply plusTerm_invTerm_zeroP with (1 := cs); auto.
apply plusTerm_comp_r with (1 := cs); auto.
change
  (eqT a (multTerm (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) a0) a))
 in |- *.
apply (eqT_trans A n) with (y := multTerm (A:=A) multA (n:=n) (T1 A1 n) a);
 auto.
apply (T1_eqT _ A1 eqA); auto.
apply multTerm_eqT; auto.
apply (eqT_trans A n) with (y := a0); auto.
apply (eqT_sym A n); auto.
apply (eqTerm_imp_eqT A eqA); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := invTerm (A:=A) invA (n:=n)
            (multTerm (A:=A) multA (n:=n) a (T1 A1 n)));
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := invTerm (A:=A) invA (n:=n) (multTerm (A:=A) multA (n:=n) a a0));
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply eqTerm_invTerm_comp with (1 := cs); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := invTerm (A:=A) invA (n:=n) (multTerm (A:=A) multA (n:=n) a0 a));
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply mult_invTerm_com with (1 := cs); auto.
Qed.

Theorem mults_multTerm :
 forall (p : list (Term A n)) (a b : Term A n),
 eqP A eqA n (mults (multTerm (A:=A) multA (n:=n) a b) p)
   (mults a (mults b p)).
Proof using plusA minusA invA divA cs A1 A0.
intros p; elim p; simpl in |- *; auto.
intros a l H a0 b; apply (eqpP1 A eqA n); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply multTerm_assoc with (1 := cs); auto.
Qed.

Theorem mults_com :
 forall (p : list (Term A n)) (a b : Term A n),
 eqP A eqA n (mults (multTerm (A:=A) multA (n:=n) a b) p)
   (mults (multTerm (A:=A) multA (n:=n) b a) p).
Proof using plusA minusA invA divA cs A1 A0.
intros p; elim p; simpl in |- *; auto.
Qed.

Theorem mults_comp :
 forall (a b : Term A n) (p q : list (Term A n)),
 eqTerm (A:=A) eqA (n:=n) a b ->
 eqP A eqA n p q -> eqP A eqA n (mults a p) (mults b q).
Proof using plusA minusA invA divA cs A1 A0.
intros a b p q H' H'0; elim H'0; simpl in |- *; auto.
Qed.

Theorem mults_ltP_comp :
 forall (a : Term A n) (p q : list (Term A n)),
 ltP (A:=A) (n:=n) ltM p q -> ltP (A:=A) (n:=n) ltM (mults a p) (mults a q).
Proof using os.
intros a p q H'; elim H'; simpl in |- *; auto.
intros x y p0 q0 H'0; simpl in |- *; apply ltP_hd; auto.
apply multTerm_ltT_l with (1 := os); auto.
Qed.

Theorem multlm_comp_canonical :
 forall (p : list (Term A n)) (a b : Term A n),
 canonical A0 eqA ltM (pX a p) ->
 ~ zeroP (A:=A) A0 eqA (n:=n) b ->
 canonical A0 eqA ltM (pX (multTerm (A:=A) multA (n:=n) b a) (mults b p)).
Proof using plusA os minusA invA eqA_dec divA cs A1.
intros p a b H' H'0; generalize (canonical_mults b (pX a p)); simpl in |- *;
 auto.
Qed.

Local Hint Resolve multlm_comp_canonical : core.

Let ffst := fst (A:=list (Term A n)) (B:=list (Term A n)).

Let ssnd := snd (A:=list (Term A n)) (B:=list (Term A n)).

Let ppair := pair (A:=list (Term A n)) (B:=list (Term A n)).

Theorem twoP_ind :
  forall P : list (Term A n) -> list (Term A n) -> Prop,
  (forall p q : list (Term A n),
   (forall r s : list (Term A n), lessP A n (r, s) (p, q) -> P r s) -> P p q) ->
  forall p q : list (Term A n), P p q.
Proof.
intros P H' p q; try assumption.
change
  ((fun pq : list (Term A n) * list (Term A n) => P (ffst pq) (ssnd pq))
     (p, q)) in |- *.
cut (exists x : list (Term A n) * list (Term A n), x = ppair p q).
unfold ppair in |- *; intros H'0; elim H'0; intros x E; rewrite <- E;
 clear H'0.
pattern x in |- *;
 apply
  well_founded_ind
   with
     (A := (list (Term A n) * list (Term A n))%type)
     (R := lessP A n)
     (1 := wf_lessP A n); auto.
intros x0 H'0; apply H'; auto.
intros r s H'1.
apply (H'0 (r, s)).
generalize H'1; case x0; simpl in |- *; auto.
exists (ppair p q); auto.
Qed.

Theorem mults_dist_pluspf :
 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
      (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec p
         q))
   (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
      (mults a p) (mults a q)).
Proof using os minusA invA divA cs A1.
intros p q; pattern p, q in |- *.
apply twoP_ind; simpl in |- *; auto.
intros p0; case p0; simpl in |- *; auto.
intros q0 H' a H'0 H'1 H'2.
apply (eqp_trans _ _ _ _ _ _ _ _ _ cs n) with (y := mults a q0); auto.
apply mults_comp; auto.
change
  (eqP A eqA n
     (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
        (pO A n) q0) q0) in |- *; auto.
change
  (eqP A eqA n (mults a q0)
     (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
        (pO A n) (mults a q0))) in |- *; auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
intros a l q0.
case q0; simpl in |- *; auto.
intros H' a0 H'0 H'1 H'2.
apply (eqp_trans _ _ _ _ _ _ _ _ _ cs n) with (y := mults a0 (pX a l)); auto.
apply mults_comp; auto.
change
  (eqP A eqA n
     (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
        (pX a l) (pO A n)) (pX a l)) in |- *; auto.
change
  (eqP A eqA n (mults a0 (pX a l))
     (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
        (pX (multTerm multA a0 a) (mults a0 l)) (pO A n)))
 in |- *; simpl in |- *; apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n);
 auto.
intros a0 l0 H' a1 H'0 H'1 H'2; simpl in |- *.
case (ltT_dec A n ltM ltM_dec a a0); [ intros H0; case H0; clear H0 | idtac ];
 intros H0.
cut
 (ltT ltM (multTerm (A:=A) multA (n:=n) a1 a)
    (multTerm (A:=A) multA (n:=n) a1 a0)); [ intros Od0 | idtac ];
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := mults a1
            (pX a0
               (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
                  ltM_dec (pX a l) l0))); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply mults_comp; auto.
change
  (eqP A eqA n
     (pX a0
        (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
           (pX a l) l0))
     (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
        (pX a l) (pX a0 l0))) in |- *.
auto.
apply pluspf_inv2 with (1 := cs); auto.
simpl in |- *.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pX (multTerm (A:=A) multA (n:=n) a1 a0)
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (pX (multTerm (A:=A) multA (n:=n) a1 a) (mults a1 l))
               (mults a1 l0))); auto.
apply eqpP1; auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults a1 (pX a l)) (mults a1 l0)); auto.
apply H'; simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; rewrite <- plus_n_Sm; auto.
apply canonical_imp_canonical with (a := a0); auto.
apply pluspf_inv2 with (1 := cs); auto.
apply multTerm_ltT_l; auto.
cut
 (ltT ltM (multTerm (A:=A) multA (n:=n) a1 a0)
    (multTerm (A:=A) multA (n:=n) a1 a)); [ intros Od0 | idtac ];
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := mults a1
            (pX a
               (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
                  ltM_dec l (pX a0 l0)))); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply mults_comp; auto.
change
  (eqP A eqA n
     (pX a
        (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
           l (pX a0 l0)))
     (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
        (pX a l) (pX a0 l0))) in |- *.
apply pluspf_inv1 with (1 := cs); auto.
simpl in |- *.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pX (multTerm (A:=A) multA (n:=n) a1 a)
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (mults a1 l)
               (pX (multTerm (A:=A) multA (n:=n) a1 a0) (mults a1 l0))));
 auto.
apply eqpP1; auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults a1 l) (mults a1 (pX a0 l0))); auto.
apply H'; simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; auto.
apply canonical_imp_canonical with (a := a); auto.
apply pluspf_inv1 with (1 := cs); auto.
apply multTerm_ltT_l; auto.
cut
 (eqT (multTerm (A:=A) multA (n:=n) a1 a)
    (multTerm (A:=A) multA (n:=n) a1 a0)); [ intros Od0 | idtac ];
 auto.
case (zeroP_dec A A0 eqA eqA_dec n (plusTerm (A:=A) plusA (n:=n) a a0));
 intros Z0.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := mults a1
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec l l0)); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply mults_comp; auto.
change
  (eqP A eqA n
     (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec l
        l0)
     (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
        (pX a l) (pX a0 l0))) in |- *; auto.
apply pluspf_inv3a with (1 := cs); auto.
cut
 (zeroP (A:=A) A0 eqA (n:=n)
    (plusTerm (A:=A) plusA (n:=n) (multTerm (A:=A) multA (n:=n) a1 a)
       (multTerm (A:=A) multA (n:=n) a1 a0))); [ intros Od1 | idtac ];
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (mults a1 l) (mults a1 l0)); auto.
apply H'; simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; rewrite <- plus_n_Sm; auto.
apply canonical_imp_canonical with (a := a); auto.
apply canonical_imp_canonical with (a := a0); auto.
apply pluspf_inv3a with (1 := cs); auto.
apply
 zeroP_comp_eqTerm
  with
    (1 := cs)
    (a := multTerm (A:=A) multA (n:=n) a1 (plusTerm (A:=A) plusA (n:=n) a a0)).
apply zeroP_multTerm_r with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply multTerm_plusTerm_dist_r with (1 := cs); auto.
cut
 (~
  zeroP (A:=A) A0 eqA (n:=n)
    (plusTerm (A:=A) plusA (n:=n) (multTerm (A:=A) multA (n:=n) a1 a)
       (multTerm (A:=A) multA (n:=n) a1 a0))); [ intros Od1 | idtac ];
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := mults a1
            (pX (plusTerm (A:=A) plusA (n:=n) a a0)
               (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
                  ltM_dec l l0))); auto.
apply mults_comp; auto.
change
  (eqP A eqA n
     (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
        (pX a l) (pX a0 l0))
     (pX (plusTerm (A:=A) plusA (n:=n) a a0)
        (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
           l l0))) in |- *.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); apply pluspf_inv3b with (1 := cs);
 auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pX
            (plusTerm (A:=A) plusA (n:=n) (multTerm (A:=A) multA (n:=n) a1 a)
               (multTerm (A:=A) multA (n:=n) a1 a0))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec (mults a1 l) (mults a1 l0)));
 auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); apply pluspf_inv3b with (1 := cs);
 auto.
simpl in |- *.
apply eqpP1; auto.
apply multTerm_plusTerm_dist_r with (1 := cs); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply H'; simpl in |- *; auto.
red in |- *; red in |- *; simpl in |- *; rewrite <- plus_n_Sm; auto.
apply canonical_imp_canonical with (a := a); auto.
apply canonical_imp_canonical with (a := a0); auto.
apply
 nzeroP_comp_eqTerm
  with
    (1 := cs)
    (a := multTerm (A:=A) multA (n:=n) a1 (plusTerm (A:=A) plusA (n:=n) a a0));
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply multTerm_plusTerm_dist_r with (1 := cs); auto.
Qed.

Local Hint Resolve mults_dist_pluspf : core.

Definition smults : Term A n -> poly A0 eqA ltM -> poly A0 eqA ltM.
intros a sp1.
case sp1.
intros p1 H'1; exists (tmults a p1); auto.
unfold tmults in |- *; case (zeroP_dec A A0 eqA eqA_dec n a); simpl in |- *;
 auto.
intros; apply canonical_mults; auto.
Defined.

End Pmults.