Require Import ConstructiveEpsilon.
Require Import Real.
Set Warnings "-parsing".
From mathcomp Require Import all_ssreflect.
Require Import Psatz.
Require Import Nat.
Require Import PeanoNat.
Require Import Kleene.
Require Import Reals.
Set Warnings "parsing".
(*
   Multivalued searching from existing searching:
     constructive_indefinite_ground_description_nat_Acc_PQ
   It is not yet decided if this to be used for our searching..
 *)

Section testsearch.
  Generalizable Variables K M.

  Context `{klb : LazyBool K} `{M_Monad : Monad M}
          {MultivalueMonad_description : Monoid_hom M_Monad NPset_Monad}
          {M_MultivalueMonad : MultivalueMonad}.

  Definition when_first : forall P Q : nat -> Prop, (forall n : nat, {P n} + {Q n}) -> (nat -> Prop).
  Proof.
    intros.
    destruct (H H0).
    exact True.
    exact False.
  Defined.

  Definition epsilon_smallest_PQ
    : forall P Q : nat -> Prop,
      (forall n, {P n} + {Q n}) ->
      (exists n, ~Q n) ->
      {n | P n /\ (forall k, (k < n)%coq_nat -> Q k)}.
  Proof.
    intros P Q H H0.
    pose proof (epsilon_smallest (when_first P Q H)).

    (* eliminate first premise of H1: *)
    assert ((forall n : nat, {when_first P Q H n} + {~ when_first P Q H n})).
    clear H1.
    intro.
    unfold when_first.
    destruct (H n).
    left; auto.
    right; auto.
    pose proof (H1 H2).
    clear H1 H2.

    (* eliminate another premise of H1 (now H3): *)
    assert (exists n : nat, when_first P Q H n).
    clear H3.
    unfold when_first.
    destruct H0.
    exists x.
    destruct (H x); auto.
    pose proof (H3 H1).
    clear H3 H1.

    destruct H2.
    unfold when_first in a.
    exists x.
    destruct (H x).
    destruct a.
    split. auto.
    intros k kx.
    have Hk := (H2 k).
    destruct (H k).
    lia.
    auto.
    destruct a.
    induction H1.
  Defined.

  Definition epsilon_smallest_PQ_M
    : forall P Q : nat -> Prop,
      (forall n, M ({P n} + {Q n})) ->
      (exists n, ~Q n) ->
      M {n | P n /\ (forall k, (k < n)%coq_nat -> Q k)}.
  Proof.
    intros.
    apply M_countable_lift in X.
    apply (M_lift (forall n : nat, {P n} + {Q n})).
    intro.
    apply (epsilon_smallest_PQ P Q); auto.
    exact X.
  Defined.

  (*********)

  (* ******************************************** *)
  (* search for the minimal n with P n for a
  "non-deterministically choosable" precidate P  *)
  (* ******************************************** *)

  Definition epsilon_smallest_choose_M
    : forall P : nat -> Prop,
      (forall n : nat, M ({P n.+1} + {~ P n}) ) ->
      (exists n : nat, P n) ->
      M {n : nat | P (n.+1) /\ (forall k, (k < n)%coq_nat -> ~ P k)}.
  Proof.
    intros P P_decM e.
    apply epsilon_smallest_PQ_M.
    exact P_decM.
    destruct e.
    exists x.
    auto.
  Defined.

  Lemma weaken_orM_r : forall P Q Q': Prop, (Q -> Q') -> M ({P}+{Q}) -> M ({P}+{Q'}).
  Proof.
    intros P Q Q' QQ'.
    apply M_lift.
    move => [iP|iQ].
    left. by auto.
    right. exact (QQ' iQ).
  Qed.

End testsearch.


Require Import Raft.
Require Import RaftRefinementInterface.

Section RequestVoteReplyMoreUpToDate.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition requestVoteReply_moreUpToDate (net : network) : Prop :=
    forall t h h' p,
      currentTerm (snd (nwState net h)) = t ->
      type (snd (nwState net h)) = Candidate ->
      In p (nwPackets net) ->
      pBody p = RequestVoteReply t true ->
      pDst p = h ->
      pSrc p = h' ->
      exists vl,
        moreUpToDate (maxTerm (log (snd (nwState net h)))) (maxIndex (log (snd (nwState net h))))
                     (maxTerm vl) (maxIndex vl) = true /\
        In (t, h, vl) (votesWithLog (fst (nwState net h'))).

  Class requestVoteReply_moreUpToDate_interface : Prop :=
    {
      requestVoteReply_moreUpToDate_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          requestVoteReply_moreUpToDate net
    }.
End RequestVoteReplyMoreUpToDate.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D B1 C1 P Q R V W X : Universe, ((wd_ C C1 /\ (wd_ C D /\ (wd_ D B1 /\ (wd_ C B1 /\ (wd_ B1 B /\ (wd_ B D /\ (wd_ A B /\ (wd_ A D /\ (wd_ C A /\ (wd_ B C /\ (wd_ A B1 /\ (wd_ A C1 /\ (wd_ B1 C1 /\ (wd_ B C1 /\ (wd_ D C1 /\ (wd_ P Q /\ (wd_ Q R /\ (wd_ V W /\ (wd_ W X /\ (col_ C1 C B /\ (col_ A C C1 /\ (col_ A B B1 /\ col_ B1 D C1)))))))))))))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^194 - 33
Base: 21 + 5/9
***)

Definition curve : CurveParameters :=
  {|
    sz := 9%nat;
    base := 21 + 5/9;
    bitwidth := 32;
    s := 2^194;
    c := [(1, 33)];
    carry_chains := Some [seq 0 (pred 9); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^452 - 3
Base: 50 + 2/9
***)

Definition curve : CurveParameters :=
  {|
    sz := 9%nat;
    base := 50 + 2/9;
    bitwidth := 64;
    s := 2^452;
    c := [(1, 3)];
    carry_chains := Some [seq 0 (pred 9); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import vcfloat.VCFloat.
Require Import Interval.Tactic.
Import Binary Coq.Lists.List ListNotations.
Set Bullet Behavior "Strict Subproofs".
Section WITHNANS.
Context {NANS:Nans}.
Open Scope R_scope.

Definition delta4_bmap_list := [Build_varinfo Tdouble 1%positive (4) (63504e-4);Build_varinfo Tdouble 2%positive (4) (63504e-4);Build_varinfo Tdouble 3%positive (4) (63504e-4);Build_varinfo Tdouble 4%positive (4) (63504e-4);Build_varinfo Tdouble 5%positive (4) (63504e-4);Build_varinfo Tdouble 6%positive (4) (63504e-4)].

Definition delta4_bmap :=
 ltac:(let z := compute_PTree (boundsmap_of_list delta4_bmap_list) in exact z).

Definition delta4 (x1 : ftype Tdouble) (x2 : ftype Tdouble) (x3 : ftype Tdouble) (x4 : ftype Tdouble) (x5 : ftype Tdouble) (x6 : ftype Tdouble) :=
  cast Tdouble ((((((((-x2) * x3)%F64 - (x1 * x4)%F64)%F64 + (x2 * x5)%F64)%F64 + (x3 * x6)%F64)%F64 - (x5 * x6)%F64)%F64 + (x1 * ((((((-x1) + x2)%F64 + x3)%F64 - x4)%F64 + x5)%F64 + x6)%F64)%F64)%F64).

Definition delta4_expr :=
 ltac:(let e' :=  HO_reify_float_expr constr:([1%positive;2%positive;3%positive;4%positive;5%positive;6%positive]) delta4 in exact e').

Derive delta4_b
SuchThat (forall vmap, prove_roundoff_bound delta4_bmap vmap delta4_expr delta4_b)
As delta4_bound.
Proof.
idtac "Starting delta4".
subst delta4_b. intro. prove_roundoff_bound.
-
time "prove_rndval" prove_rndval; time "interval" interval.
-
time "prove_roundoff_bound2" prove_roundoff_bound2;
time "prune_terms" (prune_terms (cutoff 30)).
time "do_interval" do_interval.
Qed.

Lemma check_delta4_bound: ltac:(CheckBound delta4_b 2.51e-13%F64).
Proof. reflexivity. Qed.

Definition delta_bmap_list := [Build_varinfo Tdouble 1%positive (4) (63504e-4);Build_varinfo Tdouble 2%positive (4) (63504e-4);Build_varinfo Tdouble 3%positive (4) (63504e-4);Build_varinfo Tdouble 4%positive (4) (63504e-4);Build_varinfo Tdouble 5%positive (4) (63504e-4);Build_varinfo Tdouble 6%positive (4) (63504e-4)].

Definition delta_bmap :=
 ltac:(let z := compute_PTree (boundsmap_of_list delta_bmap_list) in exact z).

Definition delta (x1 : ftype Tdouble) (x2 : ftype Tdouble) (x3 : ftype Tdouble) (x4 : ftype Tdouble) (x5 : ftype Tdouble) (x6 : ftype Tdouble) :=
  cast Tdouble (((((((((x1 * x4)%F64 * ((((((-x1) + x2)%F64 + x3)%F64 - x4)%F64 + x5)%F64 + x6)%F64)%F64 + ((x2 * x5)%F64 * (((((x1 - x2)%F64 + x3)%F64 + x4)%F64 - x5)%F64 + x6)%F64)%F64)%F64 + ((x3 * x6)%F64 * (((((x1 + x2)%F64 - x3)%F64 + x4)%F64 + x5)%F64 - x6)%F64)%F64)%F64 + (((-x2) * x3)%F64 * x4)%F64)%F64 + (((-x1) * x3)%F64 * x5)%F64)%F64 + (((-x1) * x2)%F64 * x6)%F64)%F64 + (((-x4) * x5)%F64 * x6)%F64)%F64).

Definition delta_expr :=
 ltac:(let e' :=  HO_reify_float_expr constr:([1%positive;2%positive;3%positive;4%positive;5%positive;6%positive]) delta in exact e').

Derive delta_b
SuchThat (forall vmap, prove_roundoff_bound delta_bmap vmap delta_expr delta_b)
As delta_bound.
Proof.
idtac "Starting delta".
subst delta_b. intro. prove_roundoff_bound.
-
time "prove_rndval" prove_rndval; time "interval" interval.
-
time "prove_roundoff_bound2" prove_roundoff_bound2;
time "prune_terms" (prune_terms (cutoff 30)).
time "do_interval" do_interval.
Qed.

Lemma check_delta_bound: ltac:(CheckBound delta_b 6.2e-12%F64).
Proof. reflexivity. Qed.

End WITHNANS.


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

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

          Buchberger : reduction

          Laurent Thery May 97 (revised April 01)

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

From Buchberger Require Export Pspminus.

Set Default Proof Using "Type".

Section Preduce.
Load hCoefStructure.
Load hOrderStructure.
Load hSpminus.

Inductive inPolySet : list (Term A n) -> list (poly A0 eqA ltM) -> Prop :=
  | incons :
      forall (a : Term A n) (p : list (Term A n))
        (H : canonical A0 eqA ltM (pX a p)) (P : list (poly A0 eqA ltM)),
      inPolySet (pX a p)
        (exist (fun l0 : list (Term A n) => canonical A0 eqA ltM l0)
           (pX a p) H :: P)
  | inskip :
      forall (a : poly A0 eqA ltM) (p : list (Term A n))
        (P : list (poly A0 eqA ltM)), inPolySet p P -> inPolySet p (a :: P).

Local Hint Resolve incons inskip : core.

Lemma inPolySet_imp_canonical :
 forall (p : list (Term A n)) (L : list (poly A0 eqA ltM)),
 inPolySet p L -> canonical A0 eqA ltM p.
Proof.
intros p L H'; elim H'; auto.
Qed.

Local Hint Resolve inPolySet_imp_canonical : core.

Lemma not_nil_in_polySet_elm :
 forall (Q : list (poly A0 eqA ltM)) (p : list (Term A n)),
 inPolySet p Q -> p <> pO A n.
Proof.
intros Q p H'; elim H'; auto.
intros a p0 H'0 H'1; red in |- *; intros H'2; inversion H'2.
Qed.

Theorem not_nil_in_polySet :
 forall (Q : list (poly A0 eqA ltM)) (p : list (Term A n)),
 ~ inPolySet (pO A n) Q.
Proof.
intros Q H'; red in |- *; intros H'0.
lapply (not_nil_in_polySet_elm Q (pO A n));
 [ intros H'3; apply H'3 || elim H'3 | idtac ]; auto.
Qed.

Lemma inPolySet_is_pX :
 forall (p : list (Term A n)) (L : list (poly A0 eqA ltM)),
 inPolySet p L ->
 exists a : Term A n, (exists q : list (Term A n), p = pX a q).
Proof.
intros p L H'; elim H'; auto.
intros a p0 H'0 H'1; exists a; exists p0; auto.
Qed.

Inductive reduce (Q : list (poly A0 eqA ltM)) :
list (Term A n) -> list (Term A n) -> Prop :=
  | reducetop :
      forall (a b : Term A n) (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b)
        (p q r : list (Term A n)),
      inPolySet (pX b q) Q ->
      divP A A0 eqA multA divA n a b ->
      eqP A eqA n
        (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a
           b nZb p q) r -> reduce Q (pX a p) r
  | reduceskip :
      forall (a b : Term A n) (p q : list (Term A n)),
      reduce Q p q ->
      eqTerm (A:=A) eqA (n:=n) a b -> reduce Q (pX a p) (pX b q).

Local Hint Resolve reduceskip : core.

Lemma pO_reduce :
 forall (Q : list (poly A0 eqA ltM)) (p : list (Term A n)),
 ~ reduce Q (pO A n) p.
Proof.
intros Q p; red in |- *; intros H'; inversion H'; auto.
Qed.

Theorem reduce_in_pO :
 forall (Q : list (poly A0 eqA ltM)) (p : list (Term A n)),
 inPolySet p Q -> reduce Q p (pO A n).
Proof using plusA os cs.
intros Q p; case p; simpl in |- *; auto.
intros H'; elim (inPolySet_is_pX (pO A n) Q);
 [ intros a E; elim E; intros q E0; inversion E0 | idtac ];
 auto.
intros a l H'.
cut (canonical A0 eqA ltM (pX a l)); [ intros Op0 | idtac ].
cut (canonical A0 eqA ltM l);
 [ intros Op1 | apply canonical_imp_canonical with (a := a) ];
 auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a); [ intros Nza | idtac ].
cut
 (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a a Nza l
    l = pO A n).
intros H'0; rewrite <- H'0.
change
  (reduce Q (pX a l)
     (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a a
        Nza l l)) in |- *.
apply reducetop with (b := a) (nZb := Nza) (q := l); auto.
apply divP_on_eqT with (1 := cs); auto.
cut
 (eqP A eqA n
    (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a a
       Nza l l) (pO A n)).
intros H'0; inversion H'0; auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec l
            (mults (A:=A) multA (n:=n)
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) a (b:=a) Nza)
               l)); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec l
            (mults (A:=A) multA (n:=n) (T1 A1 n) l));
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec l l);
 auto.
apply minuspf_refl with (1 := cs); auto.
apply (canonical_nzeroP A A0 eqA n ltM) with (p := l); auto.
apply inPolySet_imp_canonical with (L := Q); auto.
Qed.

Theorem ltP_reduce :
 forall (Q : list (poly A0 eqA ltM)) (p q : list (Term A n)),
 reduce Q p q -> canonical A0 eqA ltM p -> ltP (A:=A) (n:=n) ltM q p.
Proof using plusA os cs.
intros Q p q H'; elim H'; auto.
2: intros a b p0 q0 H'0 H'1 H'2 H'3; apply ltP_tl; auto.
2: apply (eqT_sym A n); apply (eqTerm_imp_eqT A eqA n); auto.
2: apply H'1; try apply canonical_imp_canonical with (a := a); auto.
intros a b nZb p0; case p0; auto.
intros q0 r H'0 H'1 H'2 H'3.
change (ltP (A:=A) (n:=n) ltM r (pX a (pO A n))) in |- *.
apply (canonical_pX_ltP A A0 eqA); auto.
apply
 eqp_imp_canonical
  with
    (1 := cs)
    (p := pX a
            (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM
               ltM_dec a b nZb (pO A n) q0)); auto.
apply canonical_spminusf_full_t with (1 := cs); auto.
apply inPolySet_imp_canonical with (L := Q); auto.
intros t l q0 r H'0 H'1 H'2 H'3; apply ltP_trans with (y := pX a (pO A n));
 auto.
apply (canonical_pX_ltP A A0 eqA); auto.
apply
 eqp_imp_canonical
  with
    (1 := cs)
    (p := pX a
            (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM
               ltM_dec a b nZb (pX t l) q0)); auto.
apply canonical_spminusf_full_t with (1 := cs); auto.
apply inPolySet_imp_canonical with (L := Q); auto.
change (ltP (A:=A) (n:=n) ltM (pX a (pO A n)) (pX a (pX t l))) in |- *; auto.
Qed.

Theorem canonical_reduce :
 forall (Q : list (poly A0 eqA ltM)) (p q : list (Term A n)),
 reduce Q p q -> canonical A0 eqA ltM p -> canonical A0 eqA ltM q.
Proof using plusA os cs.
intros Q p q H'; elim H'; auto.
intros a b nZb p0 q0 r H'0 H'1 H'2 H'3.
apply
 eqp_imp_canonical
  with
    (1 := cs)
    (p := spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a
            b nZb p0 q0); auto.
apply canonical_spminusf with (1 := cs); auto.
apply canonical_imp_canonical with (a := a); auto.
apply canonical_imp_canonical with (a := b); auto.
apply inPolySet_imp_canonical with (L := Q); auto.
intros a b p0 q0 H'0 H'1 H'2 H'3.
apply eqp_imp_canonical with (1 := cs) (p := pX a q0); auto.
cut (canonical A0 eqA ltM p0);
 [ intros C1 | apply canonical_imp_canonical with (a := a) ];
 auto.
apply ltP_pX_canonical; auto.
apply canonical_nzeroP with (ltM := ltM) (p := p0); auto.
apply ltP_trans with (y := p0); auto.
apply ltP_reduce with (Q := Q); auto.
apply (canonical_pX_ltP A A0 eqA); auto.
Qed.

Theorem reduce_eqp_com :
 forall (Q : list (poly A0 eqA ltM)) (p q r s : list (Term A n)),
 reduce Q p q ->
 canonical A0 eqA ltM p -> eqP A eqA n p r -> eqP A eqA n q s -> reduce Q r s.
Proof using plusA os cs.
intros Q p q r s H'; generalize r s; clear r s; elim H'; auto.
intros a b nZb p0 q0 r H'0 H'1 H'2 r0 s H'3 H'4 H'5.
inversion_clear H'4.
apply reducetop with (b := b) (nZb := nZb) (q := q0); auto.
apply divP_eqTerm_comp with (1 := cs) (a := a); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a
            b nZb p0 q0); auto.
cut (canonical A0 eqA ltM p0);
 [ intros Cp0 | apply canonical_imp_canonical with (a := a); auto ].
apply eqp_spminusf_com with (1 := cs); auto.
apply eqp_imp_canonical with (1 := cs) (p := p0); auto.
apply canonical_imp_canonical with (a := b); auto.
apply inPolySet_imp_canonical with (L := Q); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply divP_eqTerm_comp with (1 := cs) (a := a); auto.
apply (eqp_trans _ _ _ _ _ _ _ _ _ cs n) with (2 := H'5); auto.
intros a b p0 q0 H'0 H'1 H'2 r s H'3 H'4 H'5.
inversion_clear H'4.
inversion_clear H'5.
apply reduceskip; auto.
apply H'1; auto.
apply canonical_imp_canonical with (a := a); auto.
apply (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n) with (y := a); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n) with (y := b); auto.
Qed.

Theorem reduce_inv :
 forall (Q : list (poly A0 eqA ltM)) (a b : Term A n) (p q : list (Term A n)),
 reduce Q (pX a p) (pX b q) ->
 eqTerm (A:=A) eqA (n:=n) a b ->
 canonical A0 eqA ltM (pX a p) -> reduce Q p q.
Proof using plusA os cs.
intros Q a b p q H'; inversion_clear H'; auto.
intros eq Cap.
elim (not_double_canonical A A0 eqA n ltM) with (a := b) (p := q); auto.
apply
 eqp_imp_canonical
  with
    (p := pX b
            (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM
               ltM_dec a b0 nZb p q0))
    (1 := cs); auto.
apply (canonical_pX_eqT A A0 eqA n ltM) with (a := a); auto.
apply canonical_spminusf_full_t with (1 := cs); auto.
apply inPolySet_imp_canonical with (L := Q); auto.
apply (eqTerm_imp_eqT A eqA n); auto.
apply nzeroP_comp_eqTerm with (1 := cs) (a := a); auto.
apply canonical_nzeroP with (p := p) (ltM := ltM); auto.
Qed.

Theorem reducetop_sp :
 forall (Q : list (poly A0 eqA ltM)) (a b : Term A n)
   (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b) (p q : list (Term A n)),
 inPolySet (pX b q) Q ->
 divP A A0 eqA multA divA n a b ->
 reduce Q (pX a p)
   (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a b nZb
      p q).
Proof using plusA cs.
intros Q a b nZb p q H' H'0.
apply reducetop with (b := b) (nZb := nZb) (q := q); auto.
Qed.

Local Hint Resolve reducetop_sp : core.

Theorem reduce_inv2 :
 forall (Q : list (poly A0 eqA ltM)) (p q : list (Term A n)),
 reduce Q p q ->
 canonical A0 eqA ltM p ->
 exists x : list (Term A n),
   (exists a : Term A n,
      ~ zeroP (A:=A) A0 eqA (n:=n) a /\
      inPolySet x Q /\
      canonical A0 eqA ltM x /\
      eqP A eqA n q
        (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec p
           (mults (A:=A) multA (n:=n) a x))).
Proof using plusA os cs.
intros Q p q H'; elim H'; auto.
intros a b nZb p0 q0 r H'0 H'1 H'2 H'3; cut (canonical A0 eqA ltM (pX b q0));
 [ intros C1 | apply inPolySet_imp_canonical with (L := Q); auto ];
 exists (pX b q0);
 exists (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) a (b:=b) nZb);
 split; [ idtac | split; [ idtac | split; [ idtac | idtac ] ] ];
 auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a
            b nZb p0 q0); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a
            b nZb (pX a p0) (pX b q0)); auto.
apply spminusf_extend with (1 := cs); auto.
intros a b p0 q0 H'0 H'1 H'2 H'3.
cut (canonical A0 eqA ltM p0);
 [ intros Op1 | apply canonical_imp_canonical with (a := a) ];
 auto.
cut (canonical A0 eqA ltM (pX a q0));
 [ intros Op2 | apply canonical_reduce with (Q := Q) (p := pX a p0) ];
 auto.
cut (canonical A0 eqA ltM q0);
 [ intros Op3 | apply canonical_imp_canonical with (a := a) ];
 auto.
elim H'1;
 [ intros x E; elim E; intros a0 E0; elim E0; intros H'4 H'5; elim H'5;
    intros H'6 H'7; elim H'7; intros H'8 H'9; clear H'7 H'5 E0 E H'1
 | clear H'1 ]; auto.
exists x; exists a0; split; [ idtac | split; [ idtac | split ] ]; auto.
apply (eqp_trans _ _ _ _ _ _ _ _ _ cs n) with (y := pX a q0);
 [ auto | apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n) ].
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
            (pX a p0)
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (mults (A:=A) multA (n:=n) a0 x)));
 [ auto | idtac ].
cut (~ zeroP (A:=A) A0 eqA (n:=n) a); [ intros Z0 | idtac ].
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 (pX a (pO A n)) p0)
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               (mults (A:=A) multA (n:=n) a0 x))).
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); apply eqp_pluspf_com with (1 := cs);
 auto.
apply plusTerm_is_pX with (1 := cs); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (pX a (pO A n))
            (pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM)
               ltM_dec p0
               (mults (A:=A) multA (n:=n)
                  (invTerm (A:=A) invA (n:=n) (T1 A1 n))
                  (mults (A:=A) multA (n:=n) a0 x))));
 [ auto | idtac ].
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := pluspf (A:=A) A0 (eqA:=eqA) plusA eqA_dec (n:=n) (ltM:=ltM) ltM_dec
            (pX a (pO A n))
            (minuspf A A0 A1 eqA invA minusA multA eqA_dec n ltM ltM_dec p0
               (mults (A:=A) multA (n:=n) a0 x))).
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
            (pX a (pO A n)) q0); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply plusTerm_is_pX with (1 := cs); auto.
apply canonical_nzeroP with (ltM := ltM) (p := q0); auto.
Qed.

Theorem mults_eqp_inv :
 forall (a : Term A n) (p q : list (Term A n)),
 eqP A eqA n (mults (A:=A) multA (n:=n) a p) (mults (A:=A) multA (n:=n) a q) ->
 ~ zeroP (A:=A) A0 eqA (n:=n) a -> eqP A eqA n p q.
Proof using plusA minusA invA divA cs A1.
intros a p; elim p; auto.
intros q; case q; simpl in |- *; auto.
intros t l H'; inversion_clear H'; auto.
intros a0 l H' q; case q; simpl in |- *; auto.
intros H'0; inversion_clear H'0; auto.
intros t l0 H'0; inversion_clear H'0; auto.
intros H'1.
change (eqP A eqA n (pX a0 l) (pX t l0)) in |- *.
apply eqpP1; auto.
apply multTerm_eqTerm_inv with (1 := cs) (a := a); auto.
Qed.

Theorem reduce_mults_invf :
 forall (a : Term A n) (nZa : ~ zeroP (A:=A) A0 eqA (n:=n) a),
 eqT a (T1 A1 n) ->
 forall (Q : list (poly A0 eqA ltM)) (p q : list (Term A n)),
 canonical A0 eqA ltM p ->
 reduce Q (mults (A:=A) multA (n:=n) a p) q ->
 reduce Q p
   (mults (A:=A) multA (n:=n)
      (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) (T1 A1 n) (b:=a) nZa) q).
Proof using plusA os cs.
intros a H' eq0 Q p; elim p; auto.
simpl in |- *; intros q H'0 H'1; inversion_clear H'1; auto.
intros a0 l H'0 q H'1 H'2.
cut (canonical A0 eqA ltM l);
 [ intros Op0 | apply canonical_imp_canonical with (a := a0) ];
 auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a0);
 [ intros Z0 | apply canonical_nzeroP with (ltM := ltM) (p := l) ];
 auto.
generalize H'0 H'1; inversion_clear H'2; clear H'0 H'1; auto.
intros H'0 H'1.
cut (canonical A0 eqA ltM (pX b q0));
 [ intros Op1 | apply inPolySet_imp_canonical with (L := Q) ];
 auto.
cut (canonical A0 eqA ltM q0);
 [ intros Op2 | apply canonical_imp_canonical with (a := b) ];
 auto.
cut (divP A A0 eqA multA divA n a0 b); [ intros d0 | idtac ].
apply
 reduce_eqp_com
  with
    (p := pX a0 l)
    (q := spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec
            a0 b nZb l q0); auto.
apply mults_eqp_inv with (a := a); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := mults (A:=A) multA (n:=n)
            (multTerm (A:=A) multA (n:=n) a
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                  (T1 A1 n) (b:=a) H')) q); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := mults (A:=A) multA (n:=n) (T1 A1 n) q);
 auto.
apply (eqp_trans _ _ _ _ _ _ _ _ _ cs n) with (y := q); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec
            (multTerm (A:=A) multA (n:=n) a a0) b nZb
            (mults (A:=A) multA (n:=n) a l) q0); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply spminusf_multTerm with (1 := cs); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply mults_comp with (1 := cs); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
            (multTerm (A:=A) multA (n:=n) a (T1 A1 n)) (b:=a) H');
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) a (b:=a) H');
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply divTerm_multTerm_l with (1 := cs); auto.
apply divTerm_on_eqT with (1 := cs); auto.
apply (eqT_sym A n); auto.
apply
 eqT_nzero_eqT_divP
  with (1 := cs) (c := multTerm (A:=A) multA (n:=n) a a0) (nZb := nZb);
 auto.
apply (eqTerm_imp_eqT A eqA n); auto.
apply (eqT_trans A n) with (y := multTerm (A:=A) multA (n:=n) (T1 A1 n) a0);
 auto.
apply (eqTerm_imp_eqT A eqA n); auto.
apply (eqT_sym A n); auto.
intros H'0 H'1.
change
  (reduce Q (pX a0 l)
     (pX
        (multTerm (A:=A) multA (n:=n)
           (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
              (T1 A1 n) (b:=a) H') b)
        (mults (A:=A) multA (n:=n)
           (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
              (T1 A1 n) (b:=a) H') q0))) in |- *.
apply reduceskip; auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multTerm (A:=A) multA (n:=n)
            (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
               (T1 A1 n) (b:=a) H') (multTerm (A:=A) multA (n:=n) a a0));
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multTerm (A:=A) multA (n:=n)
            (multTerm (A:=A) multA (n:=n)
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n)
                  (T1 A1 n) (b:=a) H') a) a0); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (y := multTerm (A:=A) multA (n:=n) (T1 A1 n) a0);
 auto.
apply eqTerm_multTerm_comp with (1 := cs); auto.
apply divTerm_on_eqT with (1 := cs); auto.
apply (eqT_sym A n); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply multTerm_assoc with (1 := cs); auto.
Qed.

Theorem reduce_mults :
 forall (Q : list (poly A0 eqA ltM)) (a : Term A n) (p q : list (Term A n)),
 reduce Q p q ->
 canonical A0 eqA ltM p ->
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 reduce Q (mults (A:=A) multA (n:=n) a p) (mults (A:=A) multA (n:=n) a q).
Proof using plusA os cs.
intros Q a p q H'; generalize a; elim H'; clear a H'; auto.
simpl in |- *; auto.
intros a b nZb p0 q0 r H' H'0 H'1 a0 H'2 H'3.
cut (~ zeroP (A:=A) A0 eqA (n:=n) (multTerm (A:=A) multA (n:=n) a0 a));
 [ intros nZ0 | idtac ]; auto.
apply reducetop with (b := b) (nZb := nZb) (q := q0); auto.
apply divTerm_def with (nZb := nZb); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multTerm (A:=A) multA (n:=n)
            (multTerm (A:=A) multA (n:=n) a0
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) a (b:=b) nZb))
            b); [ auto | idtac ].
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := multTerm (A:=A) multA (n:=n) a0
            (multTerm (A:=A) multA (n:=n)
               (divTerm (A:=A) (A0:=A0) (eqA:=eqA) divA (n:=n) a (b:=b) nZb)
               b)); [ auto | idtac ].
apply multTerm_assoc with (1 := cs); auto.
apply eqTerm_multTerm_comp with (1 := cs); auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply divTerm_multTerm_l with (1 := cs); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := mults (A:=A) multA (n:=n) a0
            (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM
               ltM_dec a b nZb p0 q0)); auto.
apply spminusf_multTerm with (1 := cs); auto.
apply canonical_imp_canonical with (a := a); auto.
apply canonical_imp_canonical with (a := b); auto.
apply inPolySet_imp_canonical with (L := Q); auto.
apply nzeroP_multTerm with (1 := cs); auto.
apply canonical_nzeroP with (ltM := ltM) (p := p0); auto.
intros a b p0 q0 H' H'0 H'1 a0 H'2 H'3.
simpl in |- *; apply reduceskip; auto.
apply H'0; auto.
apply canonical_imp_canonical with (a := a); auto.
Qed.

Local Hint Resolve reduce_mults : core.

Theorem reduce_mults_inv_lem :
 forall (Q : list (poly A0 eqA ltM)) (p q : list (Term A n)),
 reduce Q p q ->
 forall r : list (Term A n),
 canonical A0 eqA ltM r ->
 p = mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) r ->
 reduce Q r
   (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) q).
Proof using plusA os cs.
intros Q p q H'; elim H'; clear H'; auto.
2: intros a b p0 q0 H' H'0 H'1 r; case r; auto.
2: intros H'2 H'3; inversion_clear H'3; auto.
2: intros a0 l H'2 H'3.
2: change
     (reduce Q (pX a0 l)
        (pX
           (multTerm (A:=A) multA (n:=n)
              (invTerm (A:=A) invA (n:=n) (T1 A1 n)) b)
           (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
              q0))) in |- *.
2: apply reduceskip; auto.
2: apply H'0; auto.
2: apply canonical_imp_canonical with (a := a0); auto.
2: inversion_clear H'3; auto.
2: apply
    (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
     with
       (y := multTerm (A:=A) multA (n:=n)
               (invTerm (A:=A) invA (n:=n) (T1 A1 n)) a);
    auto.
2: replace a with
    (multTerm (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) a0);
    [ idtac | inversion H'3 ]; auto.
2: apply
    (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
     with (y := multTerm (A:=A) multA (n:=n) (T1 A1 n) a0);
    auto.
2: apply
    (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
     with
       (y := multTerm (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))) a0);
    apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
intros a b nZb p0 q0 r H' H'0 H'1 r0; case r0; auto.
intros; discriminate.
intros a0 l H'2 H'3.
change
  (pX a p0 =
   pX
     (multTerm (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) a0)
     (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) l))
 in H'3.
cut (canonical A0 eqA ltM l);
 try apply canonical_imp_canonical with (a := a0);
 auto; intros C0.
change (reduce Q (pX a0 l) (mults multA (invTerm invA (T1 A1 n)) r)) in |- *.
apply reducetop with (b := b) (nZb := nZb) (q := q0); auto.
apply divP_eqT with (1 := cs) (a := a); auto.
rewrite pX_invl with (1 := H'3); auto.
apply (eqT_sym A n);
 apply (eqT_trans A n) with (y := multTerm (A:=A) multA (n:=n) (T1 A1 n) a0);
 auto.
apply (eqTerm_imp_eqT A eqA n); auto.
apply canonical_nzeroP with (ltM := ltM) (p := l); auto.
cut (canonical A0 eqA ltM (pX b q0));
 try apply inPolySet_imp_canonical with (L := Q); auto;
 intros C1.
cut (canonical A0 eqA ltM q0);
 try apply canonical_imp_canonical with (a := b); auto;
 intros C2.
cut (canonical A0 eqA ltM (pX a p0)); [ intros C3 | idtac ]; auto.
cut (canonical A0 eqA ltM p0);
 try apply canonical_imp_canonical with (a := a); auto;
 intros C4.
cut (divP A A0 eqA multA divA n a0 b); [ intros divP0 | idtac ].
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
            (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM
               ltM_dec a b nZb p0 q0)).
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n);
 apply
  (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
   with
     (y := spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec
             (multTerm (A:=A) multA (n:=n)
                (invTerm (A:=A) invA (n:=n) (T1 A1 n)) a) b nZb
             (mults (A:=A) multA (n:=n)
                (invTerm (A:=A) invA (n:=n) (T1 A1 n)) p0) q0);
 auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n).
apply spminusf_multTerm with (1 := cs); auto.
apply
 (eqp_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (y := spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec
            a0 b nZb
            (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
               p0) q0); auto.
apply eqTerm_spminusf_com with (1 := cs); auto.
rewrite pX_invl with (1 := H'3); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (multTerm (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))) a0);
 auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (multTerm (A:=A) multA (n:=n) (T1 A1 n) a0);
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply divP_eqT with (1 := cs) (a := a); auto.
apply (eqT_trans A n) with (multTerm (A:=A) multA (n:=n) (T1 A1 n) a); auto.
apply (eqTerm_imp_eqT A eqA n); auto.
apply nzeroP_comp_eqTerm with (1 := cs) (a := invTerm (A:=A) invA (n:=n) a);
 auto.
apply nZero_invTerm_nZero with (1 := cs); auto.
apply canonical_nzeroP with (ltM := ltM) (p := p0); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (invTerm (A:=A) invA (n:=n) (multTerm (A:=A) multA (n:=n) (T1 A1 n) a));
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply eqp_spminusf_com with (1 := cs); auto.
rewrite pX_invr with (1 := H'3); 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))) l);
 auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
apply mults_comp with (1 := cs); auto.
apply divP_eqT with (1 := cs) (a := a); auto.
rewrite pX_invl with (1 := H'3); auto.
apply (eqT_sym A n);
 apply (eqT_trans A n) with (y := multTerm (A:=A) multA (n:=n) (T1 A1 n) a0);
 auto.
apply (eqTerm_imp_eqT A eqA n); auto.
apply nzeroP_comp_eqTerm with (1 := cs) (a := invTerm (A:=A) invA (n:=n) a);
 auto.
apply nZero_invTerm_nZero with (1 := cs); auto.
apply canonical_nzeroP with (ltM := ltM) (p := p0); auto.
rewrite pX_invl with (1 := H'3); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with
    (multTerm (A:=A) multA (n:=n)
       (invTerm (A:=A) invA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))) a0);
 auto.
apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n);
 apply mult_invTerm_com with (1 := cs); auto.
apply
 (eqTerm_trans _ _ _ _ _ _ _ _ _ cs n)
  with (multTerm (A:=A) multA (n:=n) (T1 A1 n) a0);
 apply (eqTerm_sym _ _ _ _ _ _ _ _ _ cs n); auto.
rewrite H'3;
 change
   (canonical A0 eqA ltM
      (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n))
         (pX a0 l))) in |- *; auto.
Qed.

Theorem reduce_mults_invr :
 forall (Q : list (poly A0 eqA ltM)) (p q : list (Term A n)),
 reduce Q
   (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) p) q ->
 canonical A0 eqA ltM p ->
 reduce Q p
   (mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) q).
Proof using plusA os cs.
intros Q p q H' H'0.
apply
 reduce_mults_inv_lem
  with
    (p := mults (A:=A) multA (n:=n) (invTerm (A:=A) invA (n:=n) (T1 A1 n)) p);
 auto.
Qed.

Definition irreducible (Q : list (poly A0 eqA ltM))
  (p : list (Term A n)) := forall q : list (Term A n), ~ reduce Q p q.

Lemma irreducible_inv_px_l :
 forall (Q : list (poly A0 eqA ltM)) (a : Term A n) (p : list (Term A n)),
 canonical A0 eqA ltM (pX a p) ->
 irreducible Q (pX a p) -> irreducible Q (pX a (pO A n)).
Proof using plusA cs.
unfold irreducible in |- *.
intros Q a p H' H'0 q; red in |- *; intros H'1.
inversion_clear H'1.
apply
 H'0
   with
     (q := spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec
             a b nZb p q0); auto.
inversion_clear H; auto.
Qed.

Lemma pO_irreducible :
 forall Q : list (poly A0 eqA ltM), irreducible Q (pO A n).
Proof.
unfold irreducible in |- *; auto.
intros Q q; red in |- *; intros H'; inversion H'.
Qed.

Local Hint Resolve pO_irreducible : core.

Theorem irreducible_eqp_com :
 forall (Q : list (poly A0 eqA ltM)) (p q : list (Term A n)),
 irreducible Q p ->
 canonical A0 eqA ltM p -> eqP A eqA n p q -> irreducible Q q.
Proof using plusA os cs.
unfold irreducible in |- *.
intros Q p q H' H'0 H'1 q0; red in |- *; intros H'2.
apply H' with (q := q0); auto.
apply reduce_eqp_com with (p := q) (q := q0); auto.
apply eqp_imp_canonical with (1 := cs) (p := p); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
Qed.

Inductive pickinSetp :
Term A n -> list (Term A n) -> list (poly A0 eqA ltM) -> Prop :=
  | pickinSeteqp :
      forall (a b : Term A n) (p : list (Term A n))
        (H : canonical A0 eqA ltM (pX b p)) (P : list (poly A0 eqA ltM)),
      divP A A0 eqA multA divA n a b ->
      pickinSetp a (pX b p)
        (exist (fun l0 : list (Term A n) => canonical A0 eqA ltM l0)
           (pX b p) H :: P)
  | pickinSetskip :
      forall (a b : Term A n) (p : list (Term A n))
        (q : poly A0 eqA ltM) (P : list (poly A0 eqA ltM)),
      pickinSetp a p P -> pickinSetp a p (q :: P).

Local Hint Resolve pickinSeteqp pickinSetskip : core.

Lemma pickin_is_pX :
 forall (a : Term A n) (p : list (Term A n)) (Q : list (poly A0 eqA ltM)),
 pickinSetp a p Q ->
 exists b : Term A n, (exists q : list (Term A n), p = pX b q).
Proof.
intros a p Q H'; elim H'; auto.
intros a0 b p0 H'0 H'1 H'2; exists b; exists p0; auto.
Qed.

Inductive reducehead (Q : list (poly A0 eqA ltM)) :
list (Term A n) -> list (Term A n) -> Prop :=
    reduceheadO :
      forall (a b : Term A n) (nZb : ~ zeroP (A:=A) A0 eqA (n:=n) b)
        (p q : list (Term A n)),
      pickinSetp a (pX b q) Q ->
      reducehead Q (pX a p)
        (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a
           b nZb p q).

Local Hint Resolve reduceheadO : core.

Lemma pick_inv_in :
 forall (Q : list (poly A0 eqA ltM)) (a : Term A n) (p : list (Term A n)),
 pickinSetp a p Q -> inPolySet p Q.
intros Q a p H'; elim H'; auto.
Qed.

Lemma pick_inv_eqT_lem :
 forall (Q : list (poly A0 eqA ltM)) (a : Term A n) (p : list (Term A n)),
 pickinSetp a p Q ->
 forall (b : Term A n) (q : list (Term A n)),
 p = pX b q -> divP A A0 eqA multA divA n a b.
Proof.
intros Q a p H'; elim H'; auto.
intros a0 b p0 H'0 H'1 H'2 b0 q H'3; injection H'3; auto.
intros H'4 H'5; rewrite <- H'5; auto.
Qed.

Lemma pick_inv_eqT :
 forall (Q : list (poly A0 eqA ltM)) (a b : Term A n) (p q : list (Term A n)),
 pickinSetp a (pX b q) Q -> divP A A0 eqA multA divA n a b.
Proof.
intros Q a b H' q H'0.
apply pick_inv_eqT_lem with (Q := Q) (p := pX b q) (q := q); auto.
Qed.

Theorem reducehead_imp_reduce :
 forall (Q : list (poly A0 eqA ltM)) (p q : list (Term A n)),
 reducehead Q p q -> reduce Q p q.
Proof using plusA cs.
intros Q p q H'; elim H'; auto.
intros a b nZb p0 q0 H'0.
apply reducetop with (b := b) (nZb := nZb) (q := q0); auto.
apply pick_inv_in with (a := a); auto.
apply pick_inv_eqT with (Q := Q) (q := q0); auto.
Qed.

Definition s2p : poly A0 eqA ltM -> list (Term A n).
intros H'; elim H'.
intros x H'0; exact x.
Defined.

Theorem In_inp_inPolySet :
 forall (Q : list (poly A0 eqA ltM)) (p : poly A0 eqA ltM),
 In p Q -> ~ eqP A eqA n (s2p p) (pO A n) -> inPolySet (s2p p) Q.
Proof.
intros Q; elim Q; simpl in |- *; auto.
intros p H'; elim H'.
intros a l H' p H'0; elim H'0;
 [ intros H'1; rewrite H'1; clear H'0 | intros H'1; clear H'0 ];
 auto.
case p; simpl in |- *; auto.
intros x; case x; simpl in |- *; auto.
intros c H'0; elim H'0; auto.
intros t l0 c H;
 change (inPolySet (pX t l0) (exist (canonical A0 eqA ltM) (pX t l0) c :: l))
  in |- *; apply incons.
Qed.

Theorem in_inPolySet :
 forall (P : list (poly A0 eqA ltM)) (p : poly A0 eqA ltM),
 In p P -> ~ eqP A eqA n (s2p p) (pO A n) -> inPolySet (s2p p) P.
Proof.
intros P; elim P; auto.
intros p H'; inversion H'.
simpl in |- *.
intros a l H' p H'0; elim H'0;
 [ intros H'1; rewrite <- H'1; clear H'0 | intros H'1; clear H'0 ];
 auto.
case a; simpl in |- *.
intros x; case x; auto.
intros c H'0; elim H'0; auto.
intros t l0 c H;
 change (inPolySet (pX t l0) (exist (canonical A0 eqA ltM) (pX t l0) c :: l))
  in |- *; apply incons.
Qed.

Theorem inPolySet_inv0 :
 forall (P : list (poly A0 eqA ltM)) (p : list (Term A n)),
 inPolySet p P -> ~ eqP A eqA n p (pO A n).
Proof.
intros P p H'; elim H'; auto.
intros a p0 H'0 H'1; red in |- *; intros H'2; inversion H'2.
Qed.

Theorem inPolySet_inv1 :
 forall (P : list (poly A0 eqA ltM)) (p : list (Term A n)),
 inPolySet p P -> exists q : poly A0 eqA ltM, In q P /\ p = s2p q.
Proof.
intros P p H'; elim H'; auto.
intros a p0 H P0.
exists (exist (canonical A0 eqA ltM) (a :: p0) H); split; simpl in |- *; auto.
intros a p0 P0 H'0 H'1; elim H'1; intros q E; elim E; intros H'2 H'3;
 clear E H'1.
exists q; split; simpl in |- *; auto.
Qed.

Theorem Incl_inp_inPolySet :
 forall P Q : list (poly A0 eqA ltM),
 incl P Q -> forall p : list (Term A n), inPolySet p P -> inPolySet p Q.
Proof.
intros P Q H' p H'0; auto.
elim (inPolySet_inv1 P p);
 [ intros q E; elim E; intros H'4 H'5; clear E | idtac ];
 auto.
rewrite H'5.
apply in_inPolySet; auto.
rewrite <- H'5; auto.
apply inPolySet_inv0 with (P := P); auto.
Qed.

End Preduce.


Require Import RelationClasses Setoid Morphisms.
Require Import ILogic ILInsts BILInsts ILQuantTac BILogic SepAlg.
Require Import Pure.

Set Implicit Arguments.
Unset Strict Implicit.
Set Maximal Implicit Insertion.

Section IBILogicSect.
  Context {A : Type} {ILOps : ILogicOps A} {BIOps: BILOperators A}.
  Context {BIL : BILogic A}.

  Class IBILogic := {
    ibil_bil :> BILogic A;
    emp_trueE : |-- empSP
  }.

End IBILogicSect.

Implicit Arguments IBILogic [[ILOps] [BIOps]].

Section IBILogicProperties.

  Context {A : Type} `{HIBI: IBILogic A}.

  Lemma sep_forget (p q : A) : p ** q |-- p.
  Proof.
    rewrite <- empSPR, sepSPA.
    rewrite ltrueR with (C := q ** empSP).
    rewrite emp_trueE, empSPR.
    reflexivity.
  Qed.

  Lemma ibilsepand (p q : A) : p ** q |-- p //\\ q.
  Proof.
  	apply landR; [|rewrite sepSPC]; apply sep_forget; reflexivity.
  Qed.

End IBILogicProperties.

Section IBISepAlg.
  Context {A} `{sa : SepAlg A}.
  Context {B} `{IL: ILogic B}.

  Program Instance SAIBIOps: BILOperators (ILPreFrm subheap B) := {
    empSP := mkILPreFrm (fun x => ltrue) _;
    sepSP P Q := mkILPreFrm (fun x => Exists x1, Exists x2, Exists H : sa_mul x1 x2 x,
                                                (ILPreFrm_pred P) x1 //\\ (ILPreFrm_pred Q) x2) _;
    wandSP P Q := mkILPreFrm (fun x => Forall x1, Forall x2, Forall H : sa_mul x x1 x2,
                                                 (ILPreFrm_pred P) x1 -->> (ILPreFrm_pred Q) x2) _
  }.
  Next Obligation.
    lexistsL x1 x2 H1.
    unfold subheap in H.
    destruct H as [t'' H].
    destruct (sa_mulA H1 H) as [ac [H2 H3]].
    lexistsR x1 ac. apply lexistsR. assumption. apply landR.
    + apply landL1; reflexivity.
    + apply landL2; apply ILPreFrm_closed; simpl.
      exists t''; assumption.
  Qed.
  Next Obligation.
    lforallR x1 x2 H1.
    destruct H as [t'' H].
    destruct (sa_mulA H H1) as [ac [H2 H3]].
    lforallL ac x2. apply lforallL; [assumption|].
    apply limplAdj. apply limplL.
    apply ILPreFrm_closed. exists t''. eapply sa_mulC. assumption.
    apply landL1. reflexivity.
  Qed.

  Local Existing Instance ILPre_Ops.
  Local Existing Instance ILPre_ILogic.
  Local Transparent ILPre_Ops.

  Definition SAIBILogic_aux : BILogic (ILPreFrm subheap B).
  Proof.
    split.
    + apply _.
    + intros P Q x; simpl.
      lexistsL x1 x2 H1. lexistsR x2 x1.
      apply lexistsR; [apply sa_mulC; assumption|intuition].
    + intros P Q R x; simpl.
      lexistsL x1 x2 Hx x3. lexistsL x4 Hx1.
      lexistsR x3.
      destruct (sa_mulA Hx1 Hx) as [x5 [Hx2 Hx5]].
      lexistsR x5 Hx5 x4. lexistsR x2 Hx2. rewrite landA. reflexivity.
    + intros P Q R; split; intros H x; simpl.
      - lforallR x1 x2 Hx1.
        apply limplAdj.
        specialize (H x2); simpl in H.
        rewrite <- H.
        lexistsR x x1 Hx1. reflexivity.
      - lexistsL x1 x2 Hx.
        specialize (H x1); simpl in H.
        setoid_rewrite H.
        lforallL x2 x Hx. apply landAdj; reflexivity.
    + intros P Q R H x; simpl.
      lexistsL x1 x2 Hx.
      lexistsR x1 x2 Hx; specialize (H x1); setoid_rewrite H.
      reflexivity.
    + intros P; split; intros x; simpl.
      - lexistsL x1 x2 H1. apply landL1.
        apply ILPreFrm_closed; simpl.
        exists x2. assumption.
      - destruct (sa_unit_ex x) as [u [H1 H2]]. lexistsR x u.
        lexistsR H2. apply landR; [reflexivity | apply ltrueR].
  Qed.

  Local Existing Instance SAIBILogic_aux.

  Definition SAIBILogic : IBILogic (ILPreFrm subheap B).
  Proof.
    split.
    + apply _.
    + simpl; intros _. apply ltrueR.
  Qed.
(*
  Local Existing Instance SAIBILogic.

  Require Import ILEmbed.
  Context {EO: EmbedOp Prop B} {Emb: Embed Prop B}.

  Definition supported (P : ILPreFrm subheap B) : B :=
  	Forall h, Forall h', P h //\\ P h' -->> Exists h'', embed (subheap h'' h) //\\ embed (subheap h'' h') //\\ P h''.

  Lemma supported_axiom (P : ILPreFrm subheap B) : supported P -|- Forall h, (Forall Q, Forall R, (P ** Q) //\\ (P ** R) -->> P ** ((Q ** ltrue) //\\ (R ** ltrue))) h.
  Proof.
    split.
    + apply lforallR; intro h. apply lforallR; intro Q. apply lforallR; intro R.
      assert ((((P ** Q) //\\ P ** R -->> P ** (Q ** ltrue) //\\ R ** ltrue) h) -|-
              ((((P ** Q) //\\ P ** R) h) -->> ((P ** (Q ** ltrue) //\\ R ** ltrue) h))) by admit.
      rewrite H.
      apply limplAdj.
      simpl. rewrite landC.
      apply landAdj.
      rewrite landexistsDL. apply lexistsL; intros h'.
	  rewrite landexistsDL; apply lexistsL; intros h''.
	  rewrite landexistsDL; apply lexistsL; intros Hsub1.
  	  rewrite landC.
	  rewrite landexistsDL; apply lexistsL; intros h'''.
	  rewrite landexistsDL; apply lexistsL; intros h''''.
      rewrite landexistsDL; apply lexistsL; intros Hsub2.
      apply limplAdj.
      unfold supported.
      rewrite landC.
      rewrite landforallDL; apply lforallL with h'.
      rewrite landforallDL; apply lforallL with h'''.
      apply limplL. apply landR. apply landL2. apply landL1. reflexivity.
      apply landL1. apply landL1. reflexivity.
      rewrite landexistsDL. apply lexistsL. intro h'''''.
      repeat rewrite landA.
      apply lpropandL. intros Hsub3.
      apply lpropandL. intros Hsub4.
      destruct Hsub3 as [h'''''' Hsub3].
      destruct Hsub4 as [h''''''' Hsub4].
      apply lexistsR with h'''''.
      destruct (sa_mulA Hsub3 Hsub1) as [x [Hsub5 Hsub6]].
      destruct (sa_mulA Hsub4 Hsub2) as [y [Hsub7 Hsub8]].
      Check (@sa_mul_proper _ e).
Require Import Setoid Morphisms RelationClasses OrderedType.
      assert (x === y) as Hxy by admit.
      apply lexistsR with x. apply lexistsR with Hsub6.
      repeat apply landR.
      * apply landL1. reflexivity.
      * apply lexistsR with h''. apply lexistsR with h''''''.
        apply lexistsR. apply sa_mulC. apply Hsub5.
        apply landR; [|apply ltrueR]. repeat apply landL2. reflexivity.
      * apply lexistsR with h''''. apply lexistsR with h'''''''.
        apply lexistsR. apply sa_mulC. rewrite Hxy. apply Hsub7.
        apply landR; [|apply ltrueR]. apply landL2. apply landL2. apply landL1. reflexivity.
    + unfold supported. apply lforallR; intro h. apply lforallR; intro h'.

*)
  Instance pureop_pure_ibi_sepalg : PureOp := {
    pure := fun (P : ILPreFrm subheap B) => forall h h', (ILPreFrm_pred P) h |-- (ILPreFrm_pred P) h'
  }.

  Instance pure_ibi_sepalg : Pure pureop_pure_ibi_sepalg.
  Proof.
    constructor.
    { intros.
      unfold pure in H; simpl in H; repeat split; intros;
      unfold pure in *; simpl in *; intros h; simpl.
      * destruct (sa_unit_ex h) as [u [H1 H2]].
        apply lexistsR with u. apply lexistsR with h.
        eapply lexistsR. apply sa_mulC; apply H2.
        apply landR; [apply landL1; apply H| apply landL2; reflexivity].
      * apply lexistsL; intros x1.
        apply lexistsL; intros x2.
        apply lexistsL; intros Hx.
        apply landR; [apply landL1; apply H | apply landL2; apply H0].
      * apply lexistsL; intros x1; apply lexistsL; intro x2; apply lexistsL; intros Hx.
        rewrite landA. apply landR; [apply landL1; apply H|].
        apply lexistsR with x1; apply lexistsR with x2; apply lexistsR with Hx.
        apply landL2. reflexivity.
      * rewrite landC. apply landAdj.
        apply lexistsL; intros x1; apply lexistsL; intro x2; apply lexistsL; intros Hx.
        apply limplAdj.
        apply lexistsR with x1. apply lexistsR with x2. apply lexistsR with Hx.
        rewrite landC, landA.
        apply landR; [apply landL1; apply H | apply landL2; reflexivity].
      * apply lforallR; intro x1; apply lforallR; intro Hx.
        destruct Hx as [x2 Hx].
        apply lforallL with x2; apply lforallL with x1. apply lforallL.
        - assumption.
        - apply limplAdj. apply limplL; [apply H | apply landL1; reflexivity].
      * apply lforallR; intro x1; apply lforallR; intro x2; apply lforallR; intro Hx.
        apply lforallL with h. apply lforallL; [reflexivity|].
        apply limplAdj. apply limplL; [apply H| apply landL1; apply H0]. }
    { unfold pure; simpl. do 2 red; intros.
      red in H. simpl in H.
      split; intro. intros.
      destruct H.
      rewrite H1. rewrite H0. rewrite H. reflexivity.
      intros. destruct H.
      rewrite H. rewrite H0. rewrite H1. reflexivity. }
  Qed.

End IBISepAlg.

Section IBILPre.
  Context T (ord: relation T) {ord_Pre: PreOrder ord}.
  Context {A : Type} `{HBI: IBILogic A}.
  Context {BIL : BILogic A} {IL : ILogic A}.

  Local Existing Instance ILPre_Ops.
  Local Existing Instance ILPre_ILogic.
  Local Existing Instance BILPre_Ops.

  Local Transparent ILPre_Ops.

  Definition IBILPreLogic : IBILogic (ILPreFrm ord A).
  Proof.
    split.
    apply BILPreLogic.
    intro x; simpl; apply emp_trueE.
  Qed.

End IBILPre.

Section IBILogic_Fun.
  Context (T: Type).
  Context {A : Type} `{BIL: IBILogic A}.

  Local Existing Instance ILFun_Ops.
  Local Existing Instance ILFun_ILogic.
  Local Existing Instance BILFun_Ops.

  Local Transparent ILFun_Ops.

  Definition IBILFunLogic : @IBILogic ((fun x y => x -> y) T A) (@ILFun_Ops T A _) (@BILFun_Ops T A _).
  Proof.
    split.
    apply BILFunLogic. apply BIL.
    apply _. intro x; simpl; apply emp_trueE.
  Qed.

End IBILogic_Fun.

Opaque SAIBIOps.


Require Import ZArith.
Require Import List.
Require Import FMapPositive.
Require Import String.
Open Scope string_scope.

Require Import domains.

(* Define the transition relation.
   This is split into a separate file because
   a bug in Proof General prevents interactively
   advancing past definitions as long as the
   Inductive block.
 *)

Set Implicit Arguments.

Notation exp_step step a b :=
  (forall env henv lenv,
     step (KCfg a env henv lenv)
          (KCfg b env henv lenv)) (only parsing).

Notation exp1_step step a b := (forall rest, exp_step step (kra a rest) (kra b rest)) (only parsing).

Inductive pat1 (A : Set) : Set :=
  | wild : pat1 A
  | read : A -> pat1 A
  | write : A -> A -> pat1 A.
Arguments wild {A}.

Inductive cell : Set :=
  | k_cell : pat1 (list kitem) -> cell
  | env_cell : pat1 (Map string Z) -> cell
  | heap_cell : pat1 (Map Z Z) -> cell
  | code_cell : pat1 (Map Z Stmt) -> cell
  .

Inductive pat : Set :=
  | KPat : pat1 (list kitem) -> pat1 (Map string Z) ->
           pat1 (Map Z Z) -> pat1 (Map Z Stmt) -> pat
  .

Definition ext (c : cell) (p : pat) : pat :=
  match p with
    | KPat k env heap code =>
      match c with
        | k_cell k => KPat k env heap code
        | env_cell env =>  KPat k env heap code
        | heap_cell heap =>  KPat k env heap code
        | code_cell code =>  KPat k env heap code
      end
  end.

Definition arg (A : Set) (p : pat1 A) (k : A -> A -> Prop) : Prop :=
  match p with
    | wild => forall x, k x x
    | read x => k x x
    | write x1 x2 => k x1 x2
  end.

Definition mk_step (step : kcfg -> kcfg -> Prop) (p : pat) : Prop :=
  match p with
    | KPat k env heap code =>
      arg k (fun k1 k2 =>
      arg env (fun e1 e2 =>
      arg heap (fun h1 h2 =>
      arg code (fun c1 c2 =>
        step (KCfg k1 e1 h1 c1) (KCfg k2 e2 h2 c2)))))
  end.

Fixpoint mkpat (step : kcfg -> kcfg -> Prop) (p : pat)
   (members : list cell) : Prop :=
  match members with
    | nil => mk_step step p
    | c :: cells' => mkpat step (ext c p) cells'
  end.

Definition krule (step : kcfg -> kcfg -> Prop) (members : list cell) : Prop :=
  mkpat step (KPat wild wild wild wild) members.

Notation "'[' x ';' .. ';' y ']'" := (cons x (.. (cons y nil) ..)).

Coercion KExp : Exp >-> kitem.
Coercion KBExp : BExp >-> kitem.
Coercion KStmt : Stmt >-> kitem.

Definition eval1 x y rest  := (k_cell (write (kra x rest)
                                           (kra y rest))).
Definition heat e h1 h2 rest := (k_cell (write (kra e rest)
                                               (kra h1 (kra h2 rest)))).

Definition kcell_step step k1 k2 :=
  forall env heap lenv,
    step (KCfg k1 env heap lenv)
         (KCfg k2 env heap lenv).

(* Definition heat_step step e h1 h2 rest :=
  krule step [heat e h1 h2 rest]. *)
Definition heat_step step e h1 h2 rest :=
  kcell_step step (kra e rest) (kra h1 (kra h2 rest)).

Definition heat_exp step e h1 h2 rest :=
  isEVal h1 = false -> heat_step step e h1 h2 rest.
Definition heat_bool step e h1 h2 rest :=
  isBool h1 = false -> heat_step step e h1 h2 rest.

Notation heat_exp_1 step con :=
  (forall rest x, heat_exp step (con x) x (KFreezeE con) rest).
Notation heat_exp_l step con :=
  (forall rest x y, heat_exp step (con x y) x (KFreezeE (fun x => con x y)) rest).
Notation heat_exp_r step con :=
  (forall rest x y, heat_exp step (con x y) y (KFreezeE (fun y => con x y)) rest).

Notation heat_bool_1 step con :=
  (forall rest x, heat_bool step (con x) x (KFreezeB con) rest).
Notation heat_bool_l step con :=
  (forall rest x y, heat_bool step (con x y) x (KFreezeB (fun x => con x y)) rest).
Notation heat_bool_r step con :=
  (forall rest x y, heat_bool step (con x y) y (KFreezeB (fun y => con x y)) rest).

(*
Notation eval_rule step e1 e2 :=
  (forall rest, krule step [eval1 e1 e2 rest]).
 *)
Notation eval_rule step e1 e2 :=
  (forall rest, kcell_step step (kra e1 rest) (kra e2 rest)).

Definition stmt1 s rest  := (k_cell (write (kra s rest) rest)).
Definition stmt_step s1 s2 rest  := (k_cell (write (kra s1 rest) (kra s2 rest))).

Generalizable Variables rest env erest henv hrest lenv x y i j v r e b s.
Inductive kstep : kcfg -> kcfg -> Prop :=
  (* evaluation rules *)
  (* evaluation in K *)
  | k_amb_left : `(eval_rule kstep (EAmb x y) x)
  | k_amb_right : `(eval_rule kstep (EAmb x y) y)
  | k_plus : `(eval_rule kstep (EPlus (ECon i) (ECon j)) (ECon (Zplus i j)))
  | k_minus : `(eval_rule kstep (EMinus (ECon i) (ECon j)) (ECon (Zminus i j)))
  | k_div : `(Zneq_bool 0%Z j = true ->
              eval_rule kstep (EDiv (ECon i) (ECon j)) (ECon (Zdiv i j)))
  | k_le : `(eval_rule kstep (BLe (ECon i) (ECon j)) (BCon (Zle_bool i j)))
  | k_eq : `(eval_rule kstep (BEq (ECon i) (ECon j)) (BCon (i =? j)%Z))
  | k_not : `(eval_rule kstep (BNot (BCon b)) (BCon (negb b)))
  | k_and_t : `(eval_rule kstep (BAnd (BCon true) b) b)
  | k_and_f : `(eval_rule kstep (BAnd (BCon false) b) (BCon false))

  | k_skip: `(kcell_step kstep (kra Skip rest) rest)
  | k_if_t : `(eval_rule kstep (SIf (BCon true) s1 s2) s1)
  | k_if_f : `(eval_rule kstep (SIf (BCon false) s1 s2) s2)
  | k_while : `(eval_rule kstep (SWhile b s)
                                (SIf b (Seq s (SWhile b s)) Skip))
  (* evaluation rules *)
  | k_lookup : `(env ~= (x |-> i :* erest) ->
                 krule kstep [eval1 (EVar x) (ECon 1) rest
                             ;env_cell (write env (x |-> i :* erest))])
  | k_load : `(henv ~= (i |-> j :* hrest) ->
                 krule kstep [eval1 (ELoad (ECon i)) (ECon j) rest
                             ;heap_cell (read henv)])
  | k_assign : `(env ~= (x |-> v :* erest) ->
                 krule kstep [stmt1 (SAssign x (ECon i)) rest
                             ;env_cell (write env (x |-> i :* erest))])
  | k_hassign : `(henv ~= (i |-> v :* hrest) ->
                 krule kstep [stmt1 (HAssign (ECon i) (ECon j)) rest
                             ;heap_cell (write henv (i |-> j :* hrest))])
  | k_jump : `(forall l,
                 lenv ~= (l |-> s :* erest) ->
                 krule kstep [k_cell (write (kra (Jump (ECon l)) rest)
                                            (kra (KStmt s) kdot))
                             ;code_cell (read lenv)])
  (* heating and cooling *)
  | k_cool_e : `(kcell_step kstep (kra (ECon i) (kra (KFreezeE e) rest))
                                  (kra (e (ECon i)) rest))
  | k_cool_b : `(kcell_step kstep (kra (BCon b) (kra (KFreezeB e) rest))
                                  (kra (e (BCon b)) rest))

  (* unary *)
  | k_heat_load : heat_exp_1 kstep ELoad
  (* plus *)
  | k_heat_plus_l : heat_exp_l kstep EPlus
  | k_heat_plus_r : heat_exp_r kstep EPlus
  (* minus *)
  | k_heat_minus_l : heat_exp_l kstep EMinus
  | k_heat_minus_r : heat_exp_r kstep EMinus
  (* div *)
  | k_heat_div_l : heat_exp_l kstep EDiv
  | k_heat_div_r : heat_exp_r kstep EDiv
  (* le is seqstrict *)
  | k_heat_le_l : heat_exp_l kstep BLe
  | k_heat_le_r : heat_exp_r kstep BLe
  (* eq is seqstrict *)
  | k_heat_eq_l : heat_exp_l kstep BEq
  | k_heat_eq_r : heat_exp_r kstep BEq
  (* and is only strict in left argument *)
  | k_heat_not : heat_bool_1 kstep BNot
  | k_heat_and : heat_bool_l kstep BAnd
  (* assign *)
  | k_heat_assign : heat_exp_r kstep SAssign
  (* hassign *)
  | k_heat_hassign_l : heat_exp_l kstep HAssign
  | k_heat_hassign_r : heat_exp_r kstep HAssign
  (* jump *)
  | k_heat_jump : heat_exp_1 kstep Jump
  (* if *)
  | k_heat_if : `(heat_bool kstep (SIf b s1 s2) b
                            (KFreezeB (fun c => SIf c s1 s2)) rest)
  (* seq *)
  | k_heat_seq : `(heat_step kstep (Seq s1 s2) s1 s2 rest)
  .


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

Set Automatic Coercions Import.
Set Implicit Arguments.
Unset Strict Implicit.
Require Export Module_util.
Require Export Module_facts.
Section Free_Module_def.
Variable R : RING.
Variable V : SET.

Inductive FMd : Type :=
  | Var : V -> FMd
  | Law : FMd -> FMd -> FMd
  | Unit : FMd
  | Inv : FMd -> FMd
  | Op : R -> FMd -> FMd.

Inductive eqFMd : FMd -> FMd -> Prop :=
  | eqFMd_Var : forall x y : V, Equal x y -> (eqFMd (Var x) (Var y):Prop)
  | eqFMd_law :
      forall x x' y y' : FMd,
      eqFMd x x' -> eqFMd y y' -> (eqFMd (Law x y) (Law x' y'):Prop)
  | eqFMd_law_assoc :
      forall x y z : FMd, eqFMd (Law (Law x y) z) (Law x (Law y z)):Prop
  | eqFMd_law0r : forall x : FMd, eqFMd (Law x Unit) x:Prop
  | eqFMd_inv : forall x y : FMd, eqFMd x y -> eqFMd (Inv x) (Inv y)
  | eqFMd_invr : forall x : FMd, eqFMd (Law x (Inv x)) Unit
  | eqFMd_refl : forall x : FMd, eqFMd x x:Prop
  | eqFMd_sym : forall x y : FMd, eqFMd x y -> (eqFMd y x:Prop)
  | eqFMd_trans :
      forall x y z : FMd, eqFMd x y -> eqFMd y z -> (eqFMd x z:Prop)
  | eqFMd_com : forall x y : FMd, eqFMd (Law x y) (Law y x)
  | eqFMd_op_comp :
      forall (a b : R) (x y : FMd),
      Equal a b -> eqFMd x y -> (eqFMd (Op a x) (Op b y):Prop)
  | eqFMd_oplin_l :
      forall (a b : R) (x : FMd),
      eqFMd (Op (sgroup_law R a b) x) (Law (Op a x) (Op b x))
  | eqFMd_oplin_r :
      forall (a : R) (x y : FMd),
      eqFMd (Op a (Law x y)) (Law (Op a x) (Op a y))
  | eqFMd_op_assoc :
      forall (a b : R) (x : FMd),
      eqFMd (Op a (Op b x)) (Op (ring_mult a b) x)
  | eqFMd_op_unit : forall x : FMd, eqFMd (Op (ring_unit R) x) x.
Hint Resolve eqFMd_Var eqFMd_law eqFMd_law_assoc eqFMd_law0r eqFMd_invr
  eqFMd_refl: algebra.
Hint Immediate eqFMd_sym: algebra.

Lemma eqFMd_Equiv : equivalence eqFMd.
red in |- *.
split; [ try assumption | idtac ].
exact eqFMd_refl.
red in |- *.
split; [ try assumption | idtac ].
exact eqFMd_trans.
exact eqFMd_sym.
Qed.

Definition FMd_set := Build_Setoid eqFMd_Equiv.

Definition FreeModule : MODULE R.
apply
 (BUILD_MODULE (R:=R) (E:=FMd_set) (genlaw:=Law) (e:=Unit) (geninv:=Inv)
    (gen_module_op:=Op)).
exact eqFMd_law.
exact eqFMd_law_assoc.
exact eqFMd_law0r.
exact eqFMd_inv.
exact eqFMd_invr.
exact eqFMd_com.
exact eqFMd_op_comp.
exact eqFMd_oplin_l.
exact eqFMd_oplin_r.
exact eqFMd_op_assoc.
exact eqFMd_op_unit.
Defined.
Section Universal_prop.
Variable Mod : MODULE R.
Variable f : Hom V Mod.

Fixpoint FMd_lift_fun (p : FreeModule) : Mod :=
  match p with
  | Var v => f v
  | Law p1 p2 => sgroup_law Mod (FMd_lift_fun p1) (FMd_lift_fun p2)
  | Unit => monoid_unit Mod
  | Inv p1 => group_inverse Mod (FMd_lift_fun p1)
  | Op a p1 => module_mult a (FMd_lift_fun p1)
  end.

Definition FMd_lift : Hom FreeModule Mod.
apply
 (BUILD_HOM_MODULE (R:=R) (Mod:=FreeModule) (Mod':=Mod) (ff:=FMd_lift_fun)).
intros x y H'; try assumption.
elim H'; simpl in |- *; auto with algebra.
intros x0 y0 z H'0 H'1 H'2 H'3; try assumption.
apply Trans with (FMd_lift_fun y0); auto with algebra.
simpl in |- *; auto with algebra.
simpl in |- *; auto with algebra.
simpl in |- *; auto with algebra.
Defined.

Definition FMd_var : Hom V FreeModule.
apply (Build_Map (A:=V) (B:=FreeModule) (Ap:=Var)).
red in |- *.
simpl in |- *; auto with algebra.
Defined.

Lemma FMd_comp_prop :
 Equal f (comp_hom (FMd_lift:Hom (FreeModule:SET) Mod) FMd_var).
simpl in |- *.
red in |- *.
red in |- *.
simpl in |- *.
intros x; try assumption.
exact (Refl (f x)).
Qed.
End Universal_prop.
End Free_Module_def.
Hint Resolve FMd_comp_prop: algebra.


Section Rule_Operators.

  Variable R R' : red_rule.

  Definition R_rst : red_rule :=
    fun e : env => clos_refl_sym_trans term (R e).

  Definition reunion : red_rule := fun e => union _ (R e) (R' e).

(* passage au contexte *)

  Inductive ctxt : env -> term -> term -> Prop :=
    | ctx_rule : forall (e : env) (x y : term), R e x y -> ctxt e x y
    | ctx_abs_l :
        forall (e : env) (M M' : term),
        ctxt e M M' -> forall N : term, ctxt e (Abs M N) (Abs M' N)
    | ctx_abs_r :
        forall (e : env) (M M' N : term),
        ctxt (Ax N :: e) M M' -> ctxt e (Abs N M) (Abs N M')
    | ctx_app_l :
        forall (e : env) (M1 N1 : term),
        ctxt e M1 N1 -> forall M2 : term, ctxt e (App M1 M2) (App N1 M2)
    | ctx_app_r :
        forall (e : env) (M2 N2 : term),
        ctxt e M2 N2 -> forall M1 : term, ctxt e (App M1 M2) (App M1 N2)
    | ctx_prod_l :
        forall (e : env) (M1 N1 : term),
        ctxt e M1 N1 -> forall M2 : term, ctxt e (Prod M1 M2) (Prod N1 M2)
    | ctx_prod_r :
        forall (e : env) (M2 N2 M1 : term),
        ctxt (Ax M1 :: e) M2 N2 -> ctxt e (Prod M1 M2) (Prod M1 N2).

End Rule_Operators.

  Hint Unfold R_rst reunion: pts.
  Hint Resolve ctx_rule ctx_abs_l ctx_abs_r ctx_app_l ctx_app_r ctx_prod_l
    ctx_prod_r: pts.

Section Context_Closure.

  Variable R : red_rule.

  Definition red := R_rt (ctxt R).
  Definition conv := R_rst (ctxt R).

  Hint Unfold red conv: pts.

  Lemma red_trans :
   forall (e : env) (x y z : term), red e x y -> red e y z -> red e x z.
Proof fun e : env => rt_trans term (ctxt R e).

  Lemma conv_trans :
   forall (e : env) (x y z : term), conv e x y -> conv e y z -> conv e x z.
Proof fun e : env => rst_trans term (ctxt R e).

  Lemma conv_sym : forall (e : env) (x y : term), conv e x y -> conv e y x.
Proof fun e : env => rst_sym term (ctxt R e).

  Lemma red_conv : forall (e : env) (x y : term), red e x y -> conv e x y.
Proof fun e : env => clos_rt_clos_rst term (ctxt R e).

  Lemma red_sym_conv : forall (e : env) (x y : term), red e x y -> conv e y x.
intros.
apply conv_sym; apply red_conv; auto with pts.
Qed.

  Lemma red_red_abs :
   forall (e : env) (A A' M M' : term),
   red e A A' -> red (Ax A' :: e) M M' -> red e (Abs A M) (Abs A' M').
intros.
apply red_trans with (Abs A' M).
elim H; simpl in |- *; intros; auto with pts.
apply red_trans with (Abs y M); auto with pts.

elim H0; intros; auto with pts.
apply red_trans with (Abs A' y); auto with pts.
Qed.

  Lemma red_red_app :
   forall (e : env) (u u' v v' : term),
   red e u u' -> red e v v' -> red e (App u v) (App u' v').
intros.
apply red_trans with (App u' v).
elim H; simpl in |- *; intros; auto with pts.
apply red_trans with (App y v); auto with pts.

elim H0; intros; auto with pts.
apply red_trans with (App u' y); auto with pts.
Qed.

  Lemma red_red_prod :
   forall (e : env) (A A' B B' : term),
   red e A A' -> red (Ax A' :: e) B B' -> red e (Prod A B) (Prod A' B').
intros.
apply red_trans with (Prod A' B).
elim H; simpl in |- *; intros; auto with pts.
apply red_trans with (Prod y B); auto with pts.

elim H0; intros; auto with pts.
apply red_trans with (Prod A' y); auto with pts.
Qed.

  Lemma conv_conv_abs :
   forall (e : env) (A A' M M' : term),
   conv e A A' -> conv (Ax A' :: e) M M' -> conv e (Abs A M) (Abs A' M').
intros.
apply conv_trans with (Abs A' M).
elim H; simpl in |- *; intros; auto with pts.
apply conv_trans with (Abs y M); auto with pts.

elim H0; intros; auto with pts.
apply conv_trans with (Abs A' y); auto with pts.
Qed.

  Lemma conv_conv_app :
   forall (e : env) (u u' v v' : term),
   conv e u u' -> conv e v v' -> conv e (App u v) (App u' v').
intros.
apply conv_trans with (App u' v).
elim H; simpl in |- *; intros; auto with pts.
apply conv_trans with (App y v); auto with pts.

elim H0; intros; auto with pts.
apply conv_trans with (App u' y); auto with pts.
Qed.

  Lemma conv_conv_prod :
   forall (e : env) (A A' B B' : term),
   conv e A A' -> conv (Ax A' :: e) B B' -> conv e (Prod A B) (Prod A' B').
intros.
apply conv_trans with (Prod A' B).
elim H; simpl in |- *; intros; auto with pts.
apply conv_trans with (Prod y B); auto with pts.

elim H0; intros; auto with pts.
apply conv_trans with (Prod A' y); auto with pts.
Qed.

End Context_Closure.

  Hint Unfold red conv: pts.

  Hint Resolve red_conv red_sym_conv red_red_abs red_red_app red_red_prod
    conv_conv_abs conv_conv_app conv_conv_prod: pts.

  Hint Immediate conv_sym: pts.

Section Properties.

  Variable R R' : red_rule.

Section Prop_R_lift.

  Hypothesis R_lifts : R_lift R.
  Hypothesis R_lifts' : R_lift R'.

  Lemma reunion_lift : R_lift (reunion R R').
Proof.
red in |- *.
simple destruct 1; eauto with pts.
Qed.

  Lemma ctxt_lift : R_lift (ctxt R).
red in |- *.
simple induction 1; simpl in |- *; auto with pts; intros.
apply ctx_rule.
apply R_lifts with (2 := H1); auto with pts.

apply ctx_abs_r.
apply H1.
replace (Ax (lift_rec 1 N k)) with (lift_decl 1 (Ax N) k); auto with pts.

apply ctx_prod_r.
apply H1.
replace (Ax (lift_rec 1 M1 k)) with (lift_decl 1 (Ax M1) k); auto with pts.
Qed.

  Lemma R_rt_lift : R_lift (R_rt R).
unfold R_lift, R_rt in |- *.
simple induction 1; intros; auto with pts.
apply rt_step.
apply R_lifts with (2 := H1); auto with pts.

apply rt_trans with (lift_rec 1 y k); auto with pts.
Qed.

  Lemma R_rst_lift : R_lift (R_rst R).
unfold R_lift, R_rst in |- *.
simple induction 1; intros; auto with pts.
apply rst_step.
apply R_lifts with (2 := H1); auto with pts.

apply rst_sym; auto with pts.

apply rst_trans with (lift_rec 1 y k); auto with pts.
Qed.

End Prop_R_lift.

Section Prop_R_subst.

  Hypothesis R_substs : R_subst R.
  Hypothesis R_substs' : R_subst R'.

  Lemma reunion_subst : R_subst (reunion R R').
Proof.
red in |- *.
simple destruct 1; intros.
elim R_substs with (1 := H0) (2 := H1); intros; auto 10 with pts.
red in |- *; apply rt_trans with y; trivial with pts.

elim R_substs' with (1 := H0) (2 := H1); intros; auto 10 with pts.
red in |- *; apply rt_trans with y; trivial with pts.
Qed.

  Lemma ctxt_subst : R_subst (ctxt R).
red in |- *; red in |- *.
simple induction 1; simpl in |- *; auto with pts; intros.
elim R_substs with (1 := H0) (2 := H1); intros; auto with pts.
apply rt_trans with y0; auto with pts.

elim H1 with n f; intros; auto with pts.
apply rt_trans with (Abs y (subst_rec s N (S n))); auto with pts.

elim H1 with (S n) (subst_decl s (Ax N) n :: f); intros; auto with pts.
apply rt_trans with (Abs (subst_rec s N n) y); auto with pts.

elim H1 with n f; auto with pts; intros.
apply rt_trans with (App y (subst_rec s M2 n)); auto with pts.

elim H1 with n f; auto with pts; intros.
apply rt_trans with (App (subst_rec s M1 n) y); auto with pts.

elim H1 with n f; intros; auto with pts.
apply rt_trans with (Prod y (subst_rec s M2 (S n))); auto with pts.

elim H1 with (S n) (subst_decl s (Ax M1) n :: f); auto with pts; intros.
apply rt_trans with (Prod (subst_rec s M1 n) y); auto with pts.
Qed.

  Lemma R_rt_subst : R_subst (R_rt R).
unfold R_subst, R_rt at 2 in |- *.
simple induction 1; intros; auto with pts.
apply rt_step.
apply R_substs with (2 := H1); auto with pts.

apply rt_trans with (subst_rec s y n); auto with pts.
Qed.

  Lemma R_rst_subst : R_subst (R_rst R).
unfold R_subst, R_rt in |- *.
simple induction 1; intros; auto with pts.
apply rt_step.
red in |- *.
apply (clos_rt_clos_rst term (R f) (subst_rec s x n)).
fold (R_rt R f) in |- *.
apply R_substs with (2 := H1); auto with pts.

elim H1 with (1 := H2); auto with pts; intros.
apply rt_trans with y0; auto with pts.

apply rt_trans with (subst_rec s y n); auto with pts.
Qed.

End Prop_R_subst.

Section Prop_R_stable_env.

  Hypothesis R_stable : R_stable_env R.
  Hypothesis R_stable' : R_stable_env R'.

  Lemma reunion_stable : R_stable_env (reunion R R').
Proof.
red in |- *.
simple destruct 1; eauto with pts.
Qed.

  Lemma ctxt_stable : R_stable_env (ctxt R).
red in |- *.
simple induction 1; intros; auto with pts.
apply ctx_rule.
apply R_stable with R'0 e0; auto with pts.
Qed.

  Lemma R_rt_stable : R_stable_env (R_rt R).
red in |- *; red in |- *.
simple induction 1; intros; auto with pts.
apply rt_step.
apply R_stable with R'0 e; auto with pts.

apply rt_trans with y0; auto with pts.
Qed.

  Lemma R_rst_stable : R_stable_env (R_rst R).
red in |- *; red in |- *.
simple induction 1; intros; auto with pts.
apply rst_step; auto with pts.
apply R_stable with R'0 e; auto with pts.

apply rst_sym; auto with pts.

apply rst_trans with y0; auto with pts.
Qed.

End Prop_R_stable_env.

End Properties.

  Hint Resolve ctxt_lift R_rt_lift R_rst_lift ctxt_subst R_rt_subst
    R_rst_subst: pts.

Section Prop_R_lift_subst.

  Variable R : red_rule.

  Hypothesis R_lifts : R_lift R.
  Hypothesis R_substs : R_subst R.

(* amenes a disparaitre... *)
  Lemma red_lift : R_lift (red R).
Proof R_rt_lift (ctxt R) (ctxt_lift R R_lifts).

  Lemma conv_lift : R_lift (conv R).
Proof R_rst_lift (ctxt R) (ctxt_lift R R_lifts).

  Lemma red_subst : R_subst (red R).
Proof R_rt_subst (ctxt R) (ctxt_subst R R_substs).

  Lemma conv_subst : R_subst (conv R).
Proof R_rst_subst (ctxt R) (ctxt_subst R R_substs).

  Lemma red_subst_l :
   forall (g : env) (u v : term),
   ctxt R g u v ->
   forall (t : term) (n : nat) (e : env),
   trunc n e g -> red R e (subst_rec u t n) (subst_rec v t n).
simple induction t; simpl in |- *; intros; auto with pts.
red in |- *; red in |- *.
elim (lt_eq_lt_dec n0 n); intros; auto with pts.
elim a; intros; auto with pts.
apply rt_step.
apply iter_R_lift with g; auto with pts.
Qed.

  Lemma red_red_subst :
   forall (e : env) (x y t u T : term),
   red R (Ax T :: e) t u -> red R e x y -> red R e (subst x t) (subst y u).
intros.
unfold subst in |- *.
apply red_trans with (subst_rec x u 0); auto with pts.
elim
 red_subst
  with
    (g := e)
    (s := x)
    (d1 := Ax T)
    (e := Ax T :: e)
    (t := t)
    (u := u)
    (n := 0)
    (f := e); intros; auto with pts.
apply red_trans with y0; auto with pts.

elim H0; intros; auto with pts.
apply red_subst_l with e; auto with pts.

apply red_trans with (subst_rec y0 u 0); auto with pts.
Qed.

End Prop_R_lift_subst.

  Hint Resolve red_lift conv_lift red_subst conv_subst: pts.

  Definition R_rt_basic_rule : Basic_rule -> Basic_rule.
intros (R, Rlift, Rsubst, Rstable).
constructor 1 with (R_rt R); auto with pts.
intros.
apply R_rt_stable; auto with pts.
Defined.

  Definition R_rst_basic_rule : Basic_rule -> Basic_rule.
intros (R, Rlift, Rsubst, Rstable).
constructor 1 with (R_rst R); auto with pts.
intros.
apply R_rst_stable; auto with pts.
Defined.

  Definition ctxt_basic_rule : Basic_rule -> Basic_rule.
intros (R, Rlift, Rsubst, Rstable).
constructor 1 with (ctxt R); auto with pts.
intros.
apply ctxt_stable; auto with pts.
Defined.

  Definition union_basic_rule : Basic_rule -> Basic_rule -> Basic_rule.
intros (R0, Rlift0, Rsubst0, Rstable0) (R1, Rlift1, Rsubst1, Rstable1).
constructor 1 with (reunion R0 R1).
red in |- *; intros.
elim H; intros.
left.
apply Rlift0 with (2 := H0); auto with pts.

right.
apply Rlift1 with (2 := H0); auto with pts.

red in |- *; red in |- *; intros.
elim H; intros.
elim Rsubst0 with (1 := H1) (2 := H0); intros; auto with pts.
apply rt_trans with y; auto with pts.

elim Rsubst1 with (1 := H1) (2 := H0); intros; auto with pts.
apply rt_trans with y; auto with pts.

red in |- *; intros.
elim H; intros.
left.
apply Rstable0 with R' e; auto with pts.

right.
apply Rstable1 with R' e; auto with pts.
Defined.

(* Given a Basic_rule, the reflexive transitive closure is a
 * Subtyping_rule
 *)
  Definition canonical_subtyping : Basic_rule -> Subtyping_rule.
intro.
constructor 1 with (R_rt_basic_rule X).
generalize X; intros (R, Rlift, Rsubst, Rstable) e; simpl in |- *.
unfold R_rt in |- *.
apply Build_preorder; auto with pts.
red in |- *; intros.
apply rt_trans with y; auto with pts.
Defined.