Require Import Rupicola.Lib.Api.

Section with_parameters.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.

  Definition example (x: word) (y: word) :=
    let/n x := word.and (word.add y (word.of_Z 1))
                       (word.xor (word.add (word.sub x y) x)
                                 (word.of_Z 0)) in
    x.

  Implicit Type R : mem -> Prop.
  Instance spec_of_example : spec_of "example" :=
    fnspec! "example" (x y: word) ~> z,
    { requires tr mem := True;
      ensures tr' mem' :=
        tr = tr' /\
        mem = mem' /\
        z = example x y }.

  Derive example_br2fn SuchThat
         (defn! "example"("x", "y") ~> "x"
              { example_br2fn },
          implements example)
         As example_br2fn_ok.
  Proof.
    compile.
  Qed.

  Definition exZ (x: Z) (y: Z) :=
    let t := y + x in
    let t1 := ((1 - x) * (Z.land y 1) - x) * (Z.land y 1) in
    let/n t1 := t1 - (Z.lxor (Z.lxor 0 1) (Z.lxor 0 t)) in
    let t2 := ((y + 3) - (1 - y)) * (y + 3) in
    let/n t2 := Z.lor x (t * 3 + 1) in
    let t3 := t - (Z.lxor (Z.lxor t 1) 1) in
    let t3 := (1 - t3) * (((1 - t3) * (y + t3)) + t3) in
    let/n t3 := Z.lor (Z.lor x (t3 * 3 + 1)) (Z.lxor 0 (t3 * 3 + 1)) in
    let t4 := (Z.land (y + 1) (Z.lxor (t - y + t) 0)) in
    let/n t4 := Z.lor (1 + t4) (1 - t4) in
    let t5 := 3 * ((t + 8) + (t - 8)) in
    let/n x := t1 + t2 - t3 + t4 - t5 in
    x.

  Instance spec_of_exZ : spec_of "exZ" :=
    fnspec! "exZ" (x y: word) ~> z,
    { requires tr mem := True;
      ensures tr' mem' :=
        tr = tr' /\
        mem = mem' /\
        z = word.of_Z (exZ (word.unsigned x) (word.unsigned y)) }.

  Derive exZ_br2fn SuchThat
         (defn! "exZ"("x", "y") ~> "x"
              { exZ_br2fn },
          implements exZ)
         As exZ_br2fn_ok.
  Proof.
    compile.
  Qed.

  (* Compute exZ_br2fn. *)

  Fixpoint overwrite_chain (n: nat) (w0 w1: word) :=
    match n with
    | O => w1
    | S n => let/n w1 := word.add w0 w1 in
            overwrite_chain n w0 w1
    end.

  Definition chain (w0: word) :=
    Eval simpl in
    let/n w1 := word.of_Z 1 in
    overwrite_chain 5 w0 w1.

  Instance spec_of_chain : spec_of "chain" :=
    fnspec! "chain" (w0: word) ~> w1,
    { requires tr mem := True;
      ensures tr' mem' :=
        tr = tr' /\
        mem = mem' /\
        w1 = chain w0 }.

  Derive chain_br2fn SuchThat
         (defn! "chain"("w0") ~> "w1"
              { chain_br2fn },
          implements chain)
         As chain_br2fn_ok.
  Proof.
    compile.
  Qed.

  (* Compute chain_br2fn. *)
End with_parameters.


Require Import PreAutoSep.
Require Import TimeAbstract.

(** * A trivial example to make sure the separation logic proof automation isn't completely borked *)

Definition readS : spec := SPEC("x") reserving 1
  Al v,
  PRE[V] V "x" =*> v
  POST[R] [| R = v |] * V "x" =*> v.

Definition read := bmodule "read" {{
  bfunction "read"("x", "y") [readS]
    "y" <-* "x";;
    If ("y" = 0) {
      "x" *<- 0
    } else {
      "x" *<- "y"
    } ;;
    "y" <-* "x";;
    Return "y"
  end
}}.

Theorem readOk : moduleOk read.
(*TIME  Clear Timing Profile. *)
(*TIME  (time "vcgen:all" *) vcgen
(*TIME ) *); time_abstract ltac:(sep_auto).
(*TIME  Print Timing Profile. *)
Qed.


Require Import HoTT.HIT.quotient
  HoTT.Basics.PathGroupoids
  HoTT.Types.Universe
  HoTT.Basics.Trunc
  HoTT.Basics.Decidable
  HoTT.Types.Prod
  HoTT.Types.Arrow
  HoTT.Types.Sum
  HoTT.TruncType.
Require Import
  HoTT.Classes.implementations.peano_naturals
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.orders
  HoTT.Classes.interfaces.naturals
  HoTT.Classes.interfaces.integers
  HoTT.Classes.theory.rings
  HoTT.Classes.theory.groups
  HoTT.Classes.theory.apartness
  HoTT.Classes.orders.sum
  HoTT.Classes.orders.rings
  HoTT.Classes.tactics.ring_tac
  HoTT.Classes.interfaces.naturals
  HoTT.Classes.theory.naturals.

Generalizable Variables B.

Import ring_quote.Quoting.Instances.
Local Set Universe Minimization ToSet.

Module NatPair.

Module Import PairT.

Record T (N : Type) := C { pos : N ; neg : N }.
Arguments C {N} _ _.
Arguments pos {N} _.
Arguments neg {N} _.

Section contents.
Universe UN UNalt.
Context (N : Type@{UN}) `{Naturals@{UN UN UN UN UN UN UN UNalt} N}.

Global Instance T_set : IsHSet (T N).
Proof.
assert (E : sigT (fun _ : N => N) <~> (T N)).
- issig.
- apply (trunc_equiv' _ E).
Qed.

Global Instance inject : Cast N (T N) := fun x => C x 0.

Definition equiv := fun x y => pos x + neg y = pos y + neg x.

Global Instance equiv_is_equiv_rel@{} : EquivRel equiv.
Proof.
split.
- hnf. reflexivity.
- hnf. unfold equiv.
  intros ??;apply symmetry.
- hnf. unfold equiv.
  intros a b c E1 E2.
  apply (left_cancellation (+) (neg b)).
  rewrite (plus_assoc (neg b) (pos a)).
  rewrite (plus_comm (neg b) (pos a)), E1.
  rewrite (plus_comm (pos b)). rewrite <-plus_assoc.
  rewrite E2. rewrite (plus_comm (pos c) (neg b)).
  rewrite plus_assoc. rewrite (plus_comm (neg a)).
  rewrite <-plus_assoc. rewrite (plus_comm (neg a)).
  reflexivity.
Qed.

Instance pl : Plus (T N) := fun x y => C (pos x + pos y) (neg x + neg y).

Instance ml : Mult (T N) := fun x y =>
  C (pos x * pos y + neg x * neg y) (pos x * neg y + neg x * pos y).

Instance opp : Negate (T N) := fun x => C (neg x) (pos x).

Instance SR0 : Zero (T N) := C 0 0.

Instance SR1 : One (T N) := C 1 0.

Lemma pl_respects : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 ->
  equiv (q1 + r1) (q2 + r2).
Proof.
unfold equiv;simpl.
intros q1 q2 Eq r1 r2 Er.
rewrite (plus_assoc _ (neg q2)).
rewrite <-(plus_assoc (pos q1)).
rewrite (plus_comm (pos r1)).
rewrite (plus_assoc (pos q1)). rewrite Eq.
rewrite <-(plus_assoc _ (pos r1)). rewrite Er.
rewrite plus_assoc. rewrite <-(plus_assoc (pos q2)).
rewrite (plus_comm (neg q1)). rewrite !plus_assoc.
reflexivity.
Qed.

Lemma ml_respects : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 ->
  equiv (q1 * r1) (q2 * r2).
Proof.
intros q1 q2 Eq r1 r2 Er. transitivity (q1 * r2);unfold equiv in *;simpl.
- transitivity (pos q1 * (pos r1 + neg r2) + neg q1 * (neg r1 + pos r2)).
  + rewrite 2!plus_mult_distr_l.
    rewrite <-2!plus_assoc.
    apply ap.
    rewrite 2!plus_assoc. rewrite (plus_comm (neg q1 * neg r1)).
    reflexivity.
  + rewrite Er. rewrite plus_mult_distr_l.
    rewrite (plus_comm (neg r1)).
    rewrite <-Er. rewrite plus_mult_distr_l.
    rewrite <-2!plus_assoc. apply ap.
    rewrite (plus_comm (neg q1 * pos r1)).
    rewrite 2!plus_assoc.
    rewrite (plus_comm (pos q1 * neg r1)). reflexivity.
- transitivity ((pos q1 + neg q2) * pos r2 + (neg q1 + pos q2) * neg r2).
  + rewrite 2!plus_mult_distr_r.
    rewrite <-2!plus_assoc;apply ap.
    rewrite (plus_comm (pos q2 * neg r2)).
    rewrite 2!plus_assoc. rewrite (plus_comm (neg q1 * neg r2)).
    reflexivity.
  + rewrite Eq,plus_mult_distr_r.
    rewrite (plus_comm (neg q1)),<-Eq,plus_mult_distr_r.
    rewrite <-2!plus_assoc. apply ap.
    rewrite plus_assoc,(plus_comm (neg q1 * pos r2)).
    apply plus_comm.
Qed.

Lemma opp_respects : forall q1 q2, equiv q1 q2 -> equiv (opp q1) (opp q2).
Proof.
unfold equiv;simpl.
intros q1 q2 E.
rewrite !(plus_comm (neg _)). symmetry. apply E.
Qed.

Definition Tle : Le (T N)
  := fun a b => pos a + neg b <= pos b + neg a.
Definition Tlt : Lt (T N)
  := fun a b => pos a + neg b < pos b + neg a.
Definition Tapart : Apart (T N)
  := fun a b => apart (pos a + neg b) (pos b + neg a).

Global Instance Tle_hprop@{}
  : is_mere_relation (T N) Tle.
Proof.
intros;unfold Tle.
apply full_pseudo_srorder_le_hprop.
Qed.

Global Instance Tlt_hprop@{}
  : is_mere_relation (T N) Tlt.
Proof.
intros;unfold Tlt;apply _.
Qed.

Local Existing Instance pseudo_order_apart.
Global Instance Tapart_hprop@{} : is_mere_relation (T N) Tapart.
Proof.
intros;unfold Tapart;apply _.
Qed.

Lemma le_respects_aux@{} : forall q1 q2, equiv q1 q2 ->
  forall r1 r2, equiv r1 r2 ->
  Tle q1 r1 -> Tle q2 r2.
Proof.
unfold equiv,Tle;intros [pa na] [pb nb] Eq [pc nc] [pd nd] Er E;simpl in *.
apply (order_reflecting (+ (pc + na))).
assert (Erw : pb + nd + (pc + na)
  = (pb + na) + (pc + nd)) by ring_with_nat.
rewrite Erw,<-Eq,Er;clear Erw.
assert (Erw : pa + nb + (pd + nc) = pd + nb + (pa + nc)) by ring_with_nat.
rewrite Erw.
apply (order_preserving _), E.
Qed.

Lemma le_respects@{} : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 ->
  Tle q1 r1 <~> Tle q2 r2.
Proof.
intros. apply equiv_iff_hprop_uncurried.
split;apply le_respects_aux;
trivial;apply symmetry;trivial.
Qed.

Lemma lt_respects_aux@{} : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 ->
  Tlt q1 r1 -> Tlt q2 r2.
Proof.
unfold equiv,Tlt;intros [pa na] [pb nb] Eq [pc nc] [pd nd] Er E;simpl in *.
apply (strictly_order_reflecting (+ (pc + na))).
assert (Erw : pb + nd + (pc + na)
  = (pb + na) + (pc + nd)) by ring_with_nat.
rewrite Erw,<-Eq,Er;clear Erw.
assert (Erw : pa + nb + (pd + nc) = pd + nb + (pa + nc)) by ring_with_nat.
rewrite Erw.
apply (strictly_order_preserving _), E.
Qed.

Lemma lt_respects@{} : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 ->
  Tlt q1 r1 <~> Tlt q2 r2.
Proof.
intros. apply equiv_iff_hprop_uncurried.
split;apply lt_respects_aux;
trivial;apply symmetry;trivial.
Qed.

Lemma apart_cotrans@{} : CoTransitive Tapart.
Proof.
hnf.
unfold Tapart. intros q1 q2 Eq r.
apply (strong_left_cancellation (+) (neg r)) in Eq.
apply (merely_destruct (cotransitive Eq (pos r + neg q1 + neg q2)));
intros [E|E];apply tr.
- left. apply (strong_extensionality (+ (neg q2))).
  assert (Hrw : pos q1 + neg r + neg q2
    = neg r + (pos q1 + neg q2)) by ring_with_nat.
  rewrite Hrw;clear Hrw.
  trivial.
- right. apply (strong_extensionality (+ (neg q1))).
  assert (Hrw : pos r + neg q2 + neg q1 = pos r + neg q1 + neg q2)
  by ring_with_nat.
  rewrite Hrw;clear Hrw.
  assert (Hrw : pos q2 + neg r + neg q1 = neg r + (pos q2 + neg q1))
  by ring_with_nat.
  rewrite Hrw;clear Hrw.
  trivial.
Qed.
Existing Instance apart_cotrans.

Instance : Symmetric Tapart.
Proof.
hnf.
unfold Tapart.
intros ??;apply symmetry.
Qed.

Lemma apart_respects_aux@{}
  : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 ->
  Tapart q1 r1 -> Tapart q2 r2.
Proof.
assert (forall q1 q2, equiv q1 q2 -> forall r, Tapart q1 r -> Tapart q2 r)
  as E.
- intros q1 q2 Eq r Er.
  unfold Tapart,equiv in *.
  apply (strong_extensionality (+ (neg q1))).
  assert (Hrw : pos q2 + neg r + neg q1 = (pos q2 + neg q1) + neg r)
  by ring_with_nat.
  rewrite Hrw;clear Hrw.
  rewrite <-Eq.
  assert (Hrw : pos q1 + neg q2 + neg r = neg q2 + (pos q1 + neg r))
  by ring_with_nat.
  rewrite Hrw;clear Hrw.
  assert (Hrw : pos r + neg q2 + neg q1 = neg q2 + (pos r + neg q1))
  by ring_with_nat;rewrite Hrw;clear Hrw.
  apply (strong_left_cancellation _ _),Er.
- intros ?? Eq ?? Er E'.
  apply E with q1;trivial.
  apply symmetry;apply E with r1;apply symmetry;trivial.
  apply symmetry;trivial.
Qed.

Lemma apart_respects : forall q1 q2, equiv q1 q2 -> forall r1 r2, equiv r1 r2 ->
  Tapart q1 r1 <~> Tapart q2 r2.
Proof.
intros ?? Eq ?? Er.
apply equiv_iff_hprop_uncurried.
split;apply apart_respects_aux;
trivial;apply symmetry;trivial.
Qed.

Section to_ring.
Context {B : Type@{UNalt} } `{IsRing@{UNalt} B}.

Definition to_ring@{} : T N -> B.
Proof.
intros p.
exact (naturals_to_semiring N B (pos p) - naturals_to_semiring N B (neg p)).
Defined.

Lemma to_ring_respects@{} : forall a b, equiv a b ->
  to_ring a = to_ring b.
Proof.
unfold equiv;intros [pa na] [pb nb] E.
unfold to_ring;simpl in *.
apply (left_cancellation (+)
  (naturals_to_semiring N B na + naturals_to_semiring N B nb)).
path_via (naturals_to_semiring N B pa + naturals_to_semiring N B nb + 0);
[rewrite <-(plus_negate_r (naturals_to_semiring N B na));ring_with_nat
|rewrite plus_0_r].
path_via (naturals_to_semiring N B pb + naturals_to_semiring N B na + 0);
[rewrite plus_0_r|
rewrite <-(plus_negate_r (naturals_to_semiring N B nb));ring_with_nat].
rewrite <-2!preserves_plus. apply ap,E.
Qed.

End to_ring.

End contents.

Arguments equiv {_ _} _ _.
Arguments Tle {_ _ _} _ _.
Arguments Tlt {_ _ _} _ _.
Arguments Tapart {_ _ _} _ _.
Arguments to_ring N {_} B {_ _ _ _ _ _} / _.

End PairT.

Section contents.
Universe UN UNalt.
Context `{Funext} `{Univalence} (N : Type@{UN})
  `{Naturals@{UN UN UN UN UN UN UN UNalt} N}.

(* Add Ring SR : (rings.stdlib_semiring_theory SR). *)
Instance N_fullpartial : FullPartialOrder Ale Alt
  := fullpseudo_fullpartial@{UN UN UN UN UN UN UN Ularge}.

Definition Z@{} : Type@{UN} := @quotient _ PairT.equiv@{UN UNalt} _.

Global Instance Z_of_pair : Cast (PairT.T N) Z := class_of _.

Global Instance Z_of_N : Cast N Z := Compose Z_of_pair (PairT.inject@{UN UNalt} _).

Definition Z_path {x y} : PairT.equiv x y -> Z_of_pair x = Z_of_pair y
  := related_classes_eq _.

Definition related_path {x y} : Z_of_pair x = Z_of_pair y -> PairT.equiv x y
  := classes_eq_related@{UN UN Ularge Ularge Uhuge} _ _ _.

Definition Z_rect@{i} (P : Z -> Type@{i}) {sP : forall x, IsHSet (P x)}
  (dclass : forall x : PairT.T N, P (' x))
  (dequiv : forall x y E, (Z_path E) # (dclass x) = (dclass y))
  : forall q, P q
  := quotient_ind PairT.equiv P dclass dequiv.

Definition Z_compute P {sP} dclass dequiv x
 : @Z_rect P sP dclass dequiv (Z_of_pair x) = dclass x := 1.

Definition Z_compute_path P {sP} dclass dequiv q r (E : PairT.equiv q r)
  : apD (@Z_rect P sP dclass dequiv) (Z_path E) = dequiv q r E
  := quotient_ind_compute_path _ _ _ _ _ _ _ _.

Definition Z_ind@{i} (P : Z -> Type@{i}) {sP : forall x : Z, IsHProp (P x)}
  (dclass : forall x : PairT.T N, P (cast (PairT.T N) Z x)) : forall x : Z, P x.
Proof.
apply (Z_rect@{i} P dclass).
intros;apply path_ishprop@{i}.
Defined.

Definition Z_ind2 (P : Z -> Z -> Type) {sP : forall x y, IsHProp (P x y)}
  (dclass : forall x y : PairT.T N, P (' x) (' y)) : forall x y, P x y.
Proof.
apply (Z_ind (fun x => forall y, _));intros x.
apply (Z_ind _);intros y.
apply dclass.
Defined.

Definition Z_ind3@{i j} (P : Z -> Z -> Z -> Type@{i})
  {sP : forall x y z : Z, IsHProp (P x y z)}
  (dclass : forall x y z : PairT.T N, P (' x) (' y) (' z))
  : forall x y z : Z, P x y z.
Proof.
apply (@Z_ind (fun x => forall y z, _));intros x.
2:apply (Z_ind2@{i j} _);auto.
apply (@Forall.trunc_forall@{UN j j} _).
intros. apply Forall.trunc_forall@{UN i j}.
Defined.

Definition Z_rec@{i} {T : Type@{i} } {sT : IsHSet T}
  : forall (dclass : PairT.T N -> T)
  (dequiv : forall x y, PairT.equiv x y -> dclass x = dclass y),
  Z -> T
  := quotient_rec _.

Definition Z_rec_compute T sT dclass dequiv x
  : @Z_rec T sT dclass dequiv (' x) = dclass x
  := 1.

Definition Z_rec2@{i j} {T:Type@{i} } {sT : IsHSet T}
  : forall (dclass : PairT.T N -> PairT.T N -> T)
  (dequiv : forall x1 x2, PairT.equiv x1 x2 -> forall y1 y2, PairT.equiv y1 y2 ->
    dclass x1 y1 = dclass x2 y2),
  Z -> Z -> T
  := @quotient_rec2@{UN UN j i} _ _ _ _ _ (BuildhSet _).

Definition Z_rec2_compute {T sT} dclass dequiv x y
  : @Z_rec2 T sT dclass dequiv (' x) (' y) = dclass x y
  := 1.

Lemma dec_Z_of_pair `{DecidablePaths N} : forall q r : PairT.T N,
  Decidable (' q = ' r).
Proof.
intros q r.
destruct (dec (PairT.equiv q r)) as [E|E].
- left. apply Z_path,E.
- right. intros E'.
  apply E. apply (related_path E').
Defined.

Global Instance R_dec `{DecidablePaths N}
  : DecidablePaths Z.
Proof.
hnf. apply (Z_ind2 _).
apply dec_Z_of_pair.
Defined.

(* Relations, operations and constants *)

Global Instance Z0 : Zero Z := ' 0.
Global Instance Z1 : One Z := ' 1.

Global Instance Z_plus@{} : Plus Z.
Proof.
refine (Z_rec2 (fun x y => ' (PairT.pl@{UN UNalt} _ x y)) _).
intros;apply Z_path;eapply PairT.pl_respects;trivial.
Defined.

Definition Z_plus_compute q r : (' q) + (' r) = ' (PairT.pl _ q r)
  := 1.

Global Instance Z_mult@{} : Mult Z.
Proof.
refine (Z_rec2 (fun x y => ' (PairT.ml@{UN UNalt} _ x y)) _).
intros;apply Z_path;eapply PairT.ml_respects;trivial.
Defined.

Definition Z_mult_compute q r : (' q) * (' r) = ' (PairT.ml _ q r)
  := 1.

Global Instance Z_negate@{} : Negate Z.
Proof.
red. apply (Z_rec (fun x => ' (PairT.opp@{UN UNalt} _ x))).
intros;apply Z_path;eapply PairT.opp_respects;trivial.
Defined.

Definition Z_negate_compute q : - (' q) = ' (PairT.opp _ q)
  := 1.

Lemma Z_ring@{} : IsRing Z.
Proof.
repeat split;try apply _;
first [change sg_op with mult; change mon_unit with 1|
       change sg_op with plus; change mon_unit with 0];hnf.
- apply (Z_ind3 _).
  intros a b c;apply Z_path;red;simpl.
  rewrite !plus_assoc. reflexivity.
- apply (Z_ind _).
  intros a;apply Z_path;red;simpl.
  rewrite !plus_0_l. reflexivity.
- apply (Z_ind _).
  intros a;apply Z_path;red;simpl.
  rewrite !plus_0_r. reflexivity.
- apply (Z_ind _).
  intros a;apply Z_path;red;simpl.
  rewrite plus_0_l,plus_0_r. apply plus_comm.
- apply (Z_ind _).
  intros a;apply Z_path;red;simpl.
  rewrite plus_0_l,plus_0_r. apply plus_comm.
- apply (Z_ind2 _).
  intros a b;apply Z_path;red;simpl.
  apply ap011;apply plus_comm.
- apply (Z_ind3 _).
  intros [pa na] [pb nb] [pc nc];apply Z_path;red;simpl.
  ring_with_nat.
- apply (Z_ind _).
  intros;apply Z_path;red;simpl.
  ring_with_nat.
- apply (Z_ind _).
  intros;apply Z_path;red;simpl.
  ring_with_nat.
- apply (Z_ind2 _).
  intros;apply Z_path;red;simpl.
  ring_with_nat.
- apply (Z_ind3 _).
  intros [pa na] [pb nb] [pc nc];apply Z_path;red;simpl.
  ring_with_nat.
Qed.

(* A final word about inject *)
Lemma Z_of_N_morphism@{} : IsSemiRingPreserving (cast N Z).
Proof.
repeat (constructor; try apply _).
- intros x y.
  apply Z_path. red. simpl. ring_with_nat.
- intros x y. apply Z_path. red;simpl.
  ring_with_nat.
Qed.
Global Existing Instance Z_of_N_morphism.

Global Instance Z_of_N_injective@{} : IsInjective (cast N Z).
Proof.
intros x y E. apply related_path in E.
red in E. simpl in E. rewrite 2!plus_0_r in E. trivial.
Qed.

Lemma Npair_splits@{} : forall n m : N, ' (PairT.C n m) = ' n + - ' m.
Proof.
intros.
apply Z_path;red;simpl.
ring_with_nat.
Qed.

Definition Zle_hProp@{} : Z -> Z -> hProp@{UN}.
Proof.
apply (@Z_rec2@{Ularge Ularge} _ (@istrunc_trunctype@{UN Ularge Uhuge} _ _)
  (fun q r => BuildhProp (PairT.Tle q r))).
intros. apply path_hprop@{UN Ularge Uhuge}. simpl.
apply (PairT.le_respects _);trivial.
Defined.

Global Instance Zle@{} : Le Z := fun x y => Zle_hProp x y.

Global Instance ishprop_Zle : is_mere_relation _ Zle.
Proof. unfold Zle;exact _. Qed.

Lemma Zle_def@{} : forall a b : PairT.T N,
  @paths@{Uhuge} Type@{UN} (' a <= ' b) (PairT.Tle@{UN UNalt} a b).
Proof. intros; exact idpath. Qed.

Lemma Z_partial_order' : PartialOrder Zle.
Proof.
split;[apply _|apply _|split|].
- hnf. apply (Z_ind _).
  intros. change (PairT.Tle x x). red. reflexivity.
- hnf. apply (Z_ind3 (fun _ _ _ => _ -> _ -> _)).
  intros [pa na] [pb nb] [pc nc]. rewrite !Zle_def;unfold PairT.Tle;simpl.
  intros E1 E2.
  apply (order_reflecting (+ (nb + pb))).
  assert (Hrw : pa + nc + (nb + pb) = (pa + nb) + (pb + nc))
    by abstract ring_with_nat.
  rewrite Hrw;clear Hrw.
  assert (Hrw : pc + na + (nb + pb) = (pb + na) + (pc + nb))
    by abstract ring_with_nat.
  rewrite Hrw;clear Hrw.
  apply plus_le_compat;trivial.
- hnf. apply (Z_ind2 (fun _ _ => _ -> _ -> _)).
  intros [pa na] [pb nb];rewrite !Zle_def;unfold PairT.Tle;simpl.
  intros E1 E2;apply Z_path;red;simpl.
  apply (antisymmetry le);trivial.
Qed.

(* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *)
Instance Z_partial_order@{} : PartialOrder Zle
  := ltac:(first [exact Z_partial_order'@{Ularge Ularge Ularge Ularge Ularge}|
                  exact Z_partial_order']).

Lemma Zle_cast_embedding' : OrderEmbedding (cast N Z).
Proof.
split;red.
- intros. rewrite Zle_def. unfold PairT.Tle. simpl.
  rewrite 2!plus_0_r;trivial.
- intros ??. rewrite Zle_def. unfold PairT.Tle. simpl.
  rewrite 2!plus_0_r;trivial.
Qed.

(* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *)
Global Instance Zle_cast_embedding@{} : OrderEmbedding (cast N Z)
  := ltac:(first [exact Zle_cast_embedding'@{Ularge Ularge}|
                  exact Zle_cast_embedding']).

Lemma Zle_plus_preserving_l' : forall z : Z, OrderPreserving ((+) z).
Proof.
red.
apply (Z_ind3 (fun _ _ _ => _ -> _)).
intros [pc nc] [pa na] [pb nb]. rewrite !Zle_def;unfold PairT.Tle;simpl.
intros E.
assert (Hrw : pc + pa + (nc + nb) = (pc + nc) + (pa + nb)) by ring_with_nat.
rewrite Hrw;clear Hrw.
assert (Hrw : pc + pb + (nc + na) = (pc + nc) + (pb + na)) by ring_with_nat.
rewrite Hrw;clear Hrw.
apply (order_preserving _),E.
Qed.

(* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *)
Instance Zle_plus_preserving_l@{} : forall z : Z, OrderPreserving ((+) z)
  := ltac:(first [exact Zle_plus_preserving_l'@{Ularge Ularge}|
                  exact Zle_plus_preserving_l']).

Lemma Zmult_nonneg' : forall x y : Z, PropHolds (0 ≤ x) -> PropHolds (0 ≤ y) ->
  PropHolds (0 ≤ x * y).
Proof.
unfold PropHolds.
apply (Z_ind2 (fun _ _ => _ -> _ -> _)).
intros [pa na] [pb nb]. rewrite !Zle_def;unfold PairT.Tle;simpl.
rewrite !plus_0_l,!plus_0_r.
intros E1 E2.
destruct (decompose_le E1) as [a [Ea1 Ea2]], (decompose_le E2) as [b [Eb1 Eb2]].
rewrite Ea2, Eb2.
apply compose_le with (a * b).
- apply nonneg_mult_compat;trivial.
- ring_with_nat.
Qed.

(* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *)
Instance Zmult_nonneg@{} : forall x y : Z, PropHolds (0 ≤ x) -> PropHolds (0 ≤ y) ->
  PropHolds (0 ≤ x * y)
  := ltac:(first [exact Zmult_nonneg'@{Ularge Ularge Ularge}|
                  exact Zmult_nonneg']).

Global Instance Z_order@{} : SemiRingOrder Zle.
Proof. pose proof Z_ring; apply rings.from_ring_order; apply _. Qed.

(* Make this computable? Would need to compute through Z_ind2. *)
Global Instance Zle_dec `{forall x y : N, Decidable (x <= y)}
  : forall x y : Z, Decidable (x <= y).
Proof.
apply (Z_ind2 _).
intros a b. change (Decidable (PairT.Tle a b)).
unfold PairT.Tle. apply _.
Qed.

Definition Zlt_hProp@{} : Z -> Z -> hProp@{UN}.
Proof.
apply (@Z_rec2@{Ularge Ularge} _ (@istrunc_trunctype@{UN Ularge Uhuge} _ _)
  (fun q r => BuildhProp (PairT.Tlt q r))).
intros. apply path_hprop@{UN Ularge Uhuge}. simpl.
apply (PairT.lt_respects _);trivial.
Defined.

Global Instance Zlt@{} : Lt Z := fun x y => Zlt_hProp x y.

Global Instance ishprop_Zlt : is_mere_relation _ Zlt.
Proof. unfold Zlt;exact _. Qed.

Lemma Zlt_def' : forall a b, ' a < ' b = PairT.Tlt a b.
Proof. reflexivity. Qed.

(* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *)
Definition Zlt_def@{i} := ltac:(first [exact Zlt_def'@{Uhuge i}|exact Zlt_def'@{i}]).

Lemma Zlt_strict' : StrictOrder Zlt.
Proof.
split.
- apply _.
- (* we need to change so that it sees Empty,
     needed to figure out IsHProp (using Funext) *)
  change (forall x, x < x -> Empty). apply (Z_ind (fun _ => _ -> _)).
  intros [pa na];rewrite Zlt_def;unfold PairT.Tlt;simpl.
  apply irreflexivity,_.
- hnf. apply (Z_ind3 (fun _ _ _ => _ -> _ -> _)).
  intros [pa na] [pb nb] [pc nc];rewrite !Zlt_def;unfold PairT.Tlt;simpl.
  intros E1 E2.
  apply (strictly_order_reflecting (+ (nb + pb))).
  assert (Hrw : pa + nc + (nb + pb) = (pa + nb) + (pb + nc)) by ring_with_nat.
  rewrite Hrw;clear Hrw.
  assert (Hrw : pc + na + (nb + pb) = (pb + na) + (pc + nb)) by ring_with_nat.
  rewrite Hrw;clear Hrw.
  apply plus_lt_compat;trivial.
Qed.

Instance Zlt_strict@{} : StrictOrder Zlt
  := ltac:(first [exact Zlt_strict'@{Ularge Ularge Ularge Ularge Ularge}|
                  exact Zlt_strict'@{}]).

Lemma plus_strict_order_preserving_l'
  : forall z : Z, StrictlyOrderPreserving ((+) z).
Proof.
red; apply (Z_ind3 (fun _ _ _ => _ -> _)).
intros [pa na] [pb nb] [pc nc].
rewrite !Zlt_def;unfold PairT.Tlt;simpl.
intros E.
assert (Hrw : pa + pb + (na + nc) = (pa + na) + (pb + nc)) by ring_with_nat.
rewrite Hrw;clear Hrw.
assert (Hrw : pa + pc + (na + nb) = (pa + na) + (pc + nb)) by ring_with_nat.
rewrite Hrw;clear Hrw.
apply (strictly_order_preserving _),E.
Qed.

Instance Zplus_strict_order_preserving_l@{}
  : forall z : Z, StrictlyOrderPreserving ((+) z)
  := ltac:(first [exact plus_strict_order_preserving_l'@{Ularge Ularge}|
                  exact plus_strict_order_preserving_l'@{}]).

Lemma Zmult_pos' : forall x y : Z, PropHolds (0 < x) -> PropHolds (0 < y) ->
  PropHolds (0 < x * y).
Proof.
unfold PropHolds.
apply (Z_ind2 (fun _ _ => _ -> _ -> _)).
intros [pa na] [pb nb]. rewrite !Zlt_def;unfold PairT.Tlt;simpl.
rewrite !plus_0_l,!plus_0_r.
intros E1 E2.
destruct (decompose_lt E1) as [a [Ea1 Ea2]], (decompose_lt E2) as [b [Eb1 Eb2]].
rewrite Ea2, Eb2.
apply compose_lt with (a * b).
- apply pos_mult_compat;trivial.
- ring_with_nat.
Qed.

Instance Zmult_pos@{} : forall x y : Z, PropHolds (0 < x) -> PropHolds (0 < y) ->
  PropHolds (0 < x * y)
  := ltac:(first [exact Zmult_pos'@{Ularge Ularge Ularge}|
                  exact Zmult_pos'@{}]).

Global Instance Z_strict_srorder : StrictSemiRingOrder Zlt.
Proof. pose proof Z_ring; apply from_strict_ring_order; apply _. Qed.

Global Instance Zlt_dec `{forall x y : N, Decidable (x < y)}
  : forall x y : Z, Decidable (x < y).
Proof.
apply (Z_ind2 _).
intros a b. change (Decidable (PairT.Tlt a b)).
unfold PairT.Tlt.
apply _.
Qed.

Local Existing Instance pseudo_order_apart.

Definition Zapart_hProp@{} : Z -> Z -> hProp@{UN}.
Proof.
apply (@Z_rec2@{Ularge Ularge} _ (@istrunc_trunctype@{UN Ularge Uhuge} _ _)
  (fun q r => BuildhProp (PairT.Tapart q r))).
intros. apply path_hprop@{UN Ularge Uhuge}. simpl.
apply (PairT.apart_respects _);trivial.
Defined.

Global Instance Zapart@{} : Apart Z := fun x y => Zapart_hProp x y.

Lemma Zapart_def' : forall a b, apart (' a) (' b) = PairT.Tapart a b.
Proof. reflexivity. Qed.

(* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *)
Definition Zapart_def@{i} := ltac:(first [exact Zapart_def'@{Uhuge i}|
                                          exact Zapart_def'@{i}]).

Global Instance ishprop_Zapart : is_mere_relation _ Zapart.
Proof. unfold Zapart;exact _. Qed.

Lemma Z_trivial_apart' `{!TrivialApart N}
  : TrivialApart Z.
Proof.
split;[exact _|idtac].
apply (Z_ind2 _).
intros [pa na] [pb nb];rewrite Zapart_def;unfold PairT.Tapart;simpl.
split;intros E1.
- intros E2. apply related_path in E2.
  red in E2;simpl in E2.
  apply trivial_apart in E1. auto.
- apply trivial_apart. intros E2.
  apply E1,Z_path. red;simpl. trivial.
Qed.

Global Instance Z_trivial_apart@{} `{!TrivialApart N}
  : TrivialApart Z
  := ltac:(first [exact Z_trivial_apart'@{Ularge}|
                  exact Z_trivial_apart'@{}]).

Lemma Z_is_apart' : IsApart Z.
Proof.
split.
- apply _.
- apply _.
- hnf. apply (Z_ind2 (fun _ _ => _ -> _)).
  intros [pa na] [pb nb];rewrite !Zapart_def;unfold PairT.Tapart;simpl.
  apply symmetry.
- hnf. intros x y E z;revert x y z E.
  apply (Z_ind3 (fun _ _ _ => _ -> _)).
  intros a b c;rewrite !Zapart_def;unfold PairT.Tapart;simpl.
  intros E1.
  apply (strong_left_cancellation (+) (PairT.neg c)) in E1.
  eapply (merely_destruct (cotransitive E1 _));intros [E2|E2];apply tr.
  + left. apply (strong_extensionality (+ (PairT.neg b))).
    assert (Hrw : PairT.pos a + PairT.neg c + PairT.neg b =
      PairT.neg c + (PairT.pos a + PairT.neg b))
    by ring_with_nat;rewrite Hrw;exact E2.
  + right. apply (strong_extensionality (+ (PairT.neg a))).
    assert (Hrw : PairT.pos c + PairT.neg b + PairT.neg a =
      PairT.pos c + PairT.neg a + PairT.neg b)
    by ring_with_nat;rewrite Hrw;clear Hrw.
    assert (Hrw : PairT.pos b + PairT.neg c + PairT.neg a =
      PairT.neg c + (PairT.pos b + PairT.neg a))
    by ring_with_nat;rewrite Hrw;clear Hrw.
    trivial.
- apply (Z_ind2 _).
  intros a b;rewrite Zapart_def;unfold PairT.Tapart.
  split;intros E.
  + apply Z_path;red.
    apply tight_apart,E.
  + apply related_path in E. apply tight_apart,E.
Qed.

Instance Z_is_apart@{} : IsApart Z
  := ltac:(first [exact Z_is_apart'@{Ularge Ularge Ularge Ularge Ularge
                                     Ularge}|
                  exact Z_is_apart'@{}]).

Lemma Z_full_psorder' : FullPseudoOrder Zle Zlt.
Proof.
split;[apply _|split;try apply _|].
- apply (Z_ind2 _).
  intros a b;rewrite !Zlt_def;unfold PairT.Tlt.
  apply pseudo_order_antisym.
- hnf. intros a b E c;revert a b c E.
  apply (Z_ind3 (fun _ _ _ => _ -> _)).
  intros [pa na] [pb nb] [pc nc];rewrite !Zlt_def;unfold PairT.Tlt.
  intros E1.
  apply (strictly_order_preserving (+ nc)) in E1.
  eapply (merely_destruct (cotransitive E1 _));intros [E2|E2];apply tr.
  + left. apply (strictly_order_reflecting ((nb) +)).
    assert (Hrw : nb + (pa + nc) = pa + nb + nc)
    by ring_with_nat;rewrite Hrw;exact E2.
  + right. apply (strictly_order_reflecting ((na) +)).
    assert (Hrw : na + (pc + nb) = nb + (pc + na))
    by ring_with_nat;rewrite Hrw;clear Hrw.
    assert (Hrw : na + (pb + nc) = pb + na + nc)
    by ring_with_nat;rewrite Hrw;clear Hrw.
    trivial.
- apply @Z_ind2.
  + intros a b.
    apply @trunc_prod;[|apply _].
    apply (@trunc_arrow _).
    apply ishprop_sum;try apply _.
    intros E1 E2;apply (irreflexivity lt a).
    transitivity b;trivial.
  + intros a b;rewrite Zapart_def,!Zlt_def;unfold PairT.Tapart,PairT.Tlt.
    apply apart_iff_total_lt.
- apply (Z_ind2 _).
  intros a b;rewrite Zle_def,Zlt_def;unfold PairT.Tlt,PairT.Tle.
  apply le_iff_not_lt_flip.
Qed.

(* Coq pre 8.8 produces phantom universes, see GitHub Coq/Coq#1033. *)
Instance Z_full_psorder@{} : FullPseudoOrder Zle Zlt
  := ltac:(first [exact Z_full_psorder'@{Ularge Ularge Ularge Ularge Ularge
                                                Ularge Ularge Ularge Ularge}|
                  exact Z_full_psorder'@{Ularge Ularge Ularge Ularge Ularge
                                         Ularge Ularge Ularge Ularge Ularge}|
                  exact Z_full_psorder'@{}]).

Lemma Zmult_strong_ext_l' : forall z : Z, StrongExtensionality (z *.).
Proof.
red;apply (Z_ind3 (fun _ _ _ => _ -> _)).
intros [zp zn] [xp xn] [yp yn];rewrite !Zapart_def;unfold PairT.Tapart;simpl.
intros E1.
refine (merely_destruct (strong_binary_extensionality (+)
     (zp * (xp + yn)) (zn * (yp + xn)) (zp * (yp + xn)) (zn * (xp + yn)) _) _).
- assert (Hrw : zp * (xp + yn) + zn * (yp + xn)
  = zp * xp + zn * xn + (zp * yn + zn * yp))
  by ring_with_nat;rewrite Hrw;clear Hrw.
  assert (Hrw : zp * (yp + xn) + zn * (xp + yn)
  = zp * yp + zn * yn + (zp * xn + zn * xp))
  by ring_with_nat;rewrite Hrw;exact E1.
- intros [E2|E2].
  + apply (strong_extensionality (zp *.)).
    trivial.
  + apply symmetry;apply (strong_extensionality (zn *.)).
    trivial.
Qed.

Instance Zmult_strong_ext_l@{} : forall z : Z, StrongExtensionality (z *.)
  := ltac:(first [exact Zmult_strong_ext_l'@{Ularge Ularge}|
                  exact Zmult_strong_ext_l'@{}]).

Instance Z_full_pseudo_srorder@{}
  : FullPseudoSemiRingOrder Zle Zlt.
Proof.
pose proof Z_ring.
first [apply from_full_pseudo_ring_order@{UN UN UN UN UN UN UN Ularge}|
       apply from_full_pseudo_ring_order]; try apply _.
apply apartness.strong_binary_setoid_morphism_commutative.
Qed.

Goal FullPseudoSemiRingOrder Zle Zlt.
Proof.
Fail exact Z_full_pseudo_srorder@{i}.
Abort.

Global Instance Z_to_ring@{} : IntegersToRing@{UN UNalt} Z.
Proof.
red. intros R ??????.
eapply Z_rec.
apply (PairT.to_ring_respects N).
Defined.

Lemma Z_to_ring_morphism' `{IsRing B} : IsSemiRingPreserving (integers_to_ring Z B).
Proof.
split;split;red.
- change (@sg_op B _) with (@plus B _);
  change (@sg_op Z _) with (@plus Z _).
  apply (Z_ind2 _).
  intros [pa na] [pb nb].
  unfold integers_to_ring;simpl.
  rewrite !(preserves_plus (f:=naturals_to_semiring N B)).
  rewrite negate_plus_distr. ring_with_nat.
- change (@mon_unit B _) with (@zero B _);
  change (@mon_unit Z _) with (@zero Z _).
  unfold integers_to_ring;simpl.
  rewrite (preserves_0 (f:=naturals_to_semiring N B)).
  rewrite negate_0,plus_0_r;trivial.
- change (@sg_op B _) with (@mult B _);
  change (@sg_op Z _) with (@mult Z _).
  apply (Z_ind2 _).
  intros [pa na] [pb nb].
  unfold integers_to_ring;simpl.
  rewrite !(preserves_plus (f:=naturals_to_semiring N B)).
  rewrite !(preserves_mult (f:=naturals_to_semiring N B)).
  rewrite (preserves_plus (f:=naturals_to_semiring N B)).
  rewrite !(preserves_mult (f:=naturals_to_semiring N B)).
  rewrite negate_plus_distr.
  rewrite negate_mult_distr_r,negate_mult_distr_l.
  rewrite <-(negate_mult_negate (naturals_to_semiring N B na)
    (naturals_to_semiring N B nb)).
  ring_with_nat.
- change (@mon_unit B _) with (@one B _);
  change (@mon_unit Z _) with (@one Z _).
  unfold integers_to_ring;simpl.
  rewrite (preserves_1 (f:=naturals_to_semiring N B)).
  rewrite (preserves_0 (f:=naturals_to_semiring N B)).
  rewrite negate_0,plus_0_r;trivial.
Qed.

Instance Z_to_ring_morphism@{} `{IsRing B} : IsSemiRingPreserving (integers_to_ring Z B)
  := ltac:(first [exact Z_to_ring_morphism'@{Ularge}|
                  exact Z_to_ring_morphism'@{}]).

Lemma Z_to_ring_unique@{} `{IsRing B} (h : Z -> B) `{!IsSemiRingPreserving h}
  : forall x : Z, integers_to_ring Z B x = h x.
Proof.
pose proof Z_ring.
apply (Z_ind _).
intros [pa na];unfold integers_to_ring;simpl.
rewrite Npair_splits.
rewrite (preserves_plus (f:=h)),(preserves_negate (f:=h)).
change (h (' pa)) with (Compose h (cast N Z) pa).
change (h (' na)) with (Compose h (cast N Z) na).
rewrite 2!(naturals_initial (h:=Compose h (cast N Z))).
trivial.
Qed.

Global Instance Z_integers@{} : Integers Z.
Proof.
split;try apply _.
- apply Z_ring.
- apply @Z_to_ring_unique.
Qed.

Context `{!NatDistance N}.

Lemma Z_abs_aux_0@{} : forall a b z : N, a + z = b -> z = 0 ->
  naturals_to_semiring N Z 0 = ' {| PairT.pos := a; PairT.neg := b |}.
Proof.
intros a b z E E'.
rewrite (preserves_0 (A:=N)).
rewrite E',plus_0_r in E. rewrite E.
apply Z_path. red;simpl. apply plus_comm.
Qed.

Lemma Z_abs_aux_neg@{} : forall a b z : N, a + z = b ->
  naturals_to_semiring N Z z = - ' {| PairT.pos := a; PairT.neg := b |}.
Proof.
intros a b z E.
rewrite <-(naturals.to_semiring_unique (cast N Z)).
apply Z_path. red;simpl. rewrite plus_0_r,plus_comm;trivial.
Qed.

Lemma Z_abs_aux_pos@{} : forall a b z : N, b + z = a ->
  naturals_to_semiring N Z z = ' {| PairT.pos := a; PairT.neg := b |}.
Proof.
intros a b z E.
rewrite <-(naturals.to_semiring_unique (cast N Z)).
apply Z_path;red;simpl. rewrite plus_0_r,plus_comm;trivial.
Qed.

(* We use decidability of equality on N
   to make sure we always go left when the inputs are equal.
   Otherwise we would have to truncate IntAbs. *)
Definition Z_abs_def@{} : forall x : PairT.T N,
  (exists n : N, naturals_to_semiring N Z n = ' x)
  |_| (exists n : N, naturals_to_semiring N Z n = - ' x).
Proof.
intros [a b].
destruct (nat_distance_sig a b) as [[z E]|[z E]].
- destruct (dec (z = 0)) as [E'|_].
  + left. exists 0. apply Z_abs_aux_0 with z;trivial.
  + right. exists z. apply Z_abs_aux_neg;trivial.
- left. exists z. apply Z_abs_aux_pos;trivial.
Defined.

Lemma Z_abs_respects' : forall (x y : PairT.T N) (E : PairT.equiv x y),
  transport
    (fun q : Z =>
     (exists n : N, naturals_to_semiring N Z n = q)
     |_| (exists n : N, naturals_to_semiring N Z n = - q)) (Z_path E) (Z_abs_def x)
  = Z_abs_def y.
Proof.
intros [pa pb] [na nb] E.
red in E; simpl in E.
unfold Z_abs_def.
destruct (nat_distance_sig pa pb) as [[z1 E1] | [z1 E1]];simpl.
- destruct (dec (z1 = 0)) as [E2 | E2].
  + rewrite Sum.transport_sum. rewrite Sigma.transport_sigma.
    destruct (nat_distance_sig na nb) as [[z2 E3] | [z2 E3]];
    [destruct (dec (z2 = 0)) as [E4 | E4]|];simpl.
    * apply ap.
      apply Sigma.path_sigma_hprop;simpl.
      apply PathGroupoids.transport_const.
    * destruct E4.
      rewrite <-E1,<-E3,E2,plus_0_r,<-(plus_0_r (na+pa)) in E.
      rewrite plus_assoc,(plus_comm pa) in E.
      apply (left_cancellation plus _) in E. trivial.
    * apply ap. apply Sigma.path_sigma_hprop. simpl.
      rewrite PathGroupoids.transport_const.
      rewrite E2,plus_0_r in E1.
      rewrite <-E3,E1 in E.
      apply (left_cancellation plus (pb + nb)).
      rewrite plus_0_r. etransitivity;[apply E|].
      ring_with_nat.
  + rewrite Sum.transport_sum,Sigma.transport_sigma.
    destruct (nat_distance_sig na nb) as [[z2 E3] | [z2 E3]];
    [destruct (dec (z2 = 0)) as [E4 | E4]|];simpl.
    * destruct E2.
      rewrite E4,plus_0_r in E3;rewrite <-E1,<-E3 in E.
      apply (left_cancellation plus (pa+na)).
      rewrite (plus_comm pa na),plus_0_r,<-plus_assoc.
      rewrite (plus_comm na pa). symmetry;trivial.
    * apply ap. apply Sigma.path_sigma_hprop.
      simpl. rewrite PathGroupoids.transport_const.
      rewrite <-E1,<-E3 in E.
      apply (left_cancellation plus (pa + na)).
      rewrite <-(plus_assoc pa na z2),(plus_comm pa na),<-plus_assoc.
      symmetry;trivial.
    * destruct E2.
      rewrite <-E1,<-E3 in E.
      assert (Erw : nb + z2 + (pa + z1) = (pa + nb) + (z2 + z1))
      by ring_with_nat.
      rewrite <-(plus_0_r (pa+nb)),Erw in E.
      apply (left_cancellation plus _),symmetry,naturals.zero_sum in E.
      apply E.
- rewrite Sum.transport_sum,Sigma.transport_sigma. simpl.
  destruct (nat_distance_sig na nb) as [[z2 E3] | [z2 E3]];
  [destruct (dec (z2 = 0)) as [E4 | E4]|];simpl.
  + apply ap. apply Sigma.path_sigma_hprop. simpl.
    rewrite PathGroupoids.transport_const.
    rewrite <-E1,<-E3,E4,plus_0_r in E.
    apply (left_cancellation plus (na+pb)).
    rewrite plus_0_r.
    path_via (pb + z1 + na). ring_with_nat.
  + destruct E4.
    rewrite <-E1,<-E3 in E.
    assert (Hrw : pb + z1 + (na + z2) = (na + pb) + (z1 + z2))
    by ring_with_nat.
    rewrite <-(plus_0_r (na+pb)),Hrw in E.
    apply (left_cancellation _ _),naturals.zero_sum in E.
    apply E.
  + apply ap,Sigma.path_sigma_hprop. simpl.
    rewrite PathGroupoids.transport_const.
    rewrite <-E1,<-E3 in E.
    apply (left_cancellation plus (pb+nb)).
    path_via (pb + z1 + nb);[|path_via (nb + z2 + pb)];ring_with_nat.
Qed.

Lemma Z_abs' : IntAbs Z N.
Proof.
red. apply (Z_rect _ Z_abs_def).
exact Z_abs_respects'.
Qed.

Global Instance Z_abs@{} : IntAbs@{UN UN UN UN UN
  UN UN UN UN UN
  UN UN UN UN UN
  UN UN} Z N
  := ltac:(first [exact Z_abs'@{Ularge Ularge Ularge Ularge Ularge
                                Ularge Ularge}|
                  exact Z_abs'@{Ularge Ularge Ularge Ularge Ularge
                                Ularge}]).

Notation n_to_z := (naturals_to_semiring N Z).

Definition zero_product_aux a b :
  n_to_z a * n_to_z b = 0 -> n_to_z a = 0 |_| n_to_z b = 0.
Proof.
rewrite <-rings.preserves_mult.
rewrite <-!(naturals.to_semiring_unique (cast N Z)).
intros E.
change 0 with (' 0) in E. apply (injective _) in E.
apply zero_product in E.
destruct E as [E|E];rewrite E;[left|right];apply preserves_0.
Qed.

Lemma Z_zero_product' : ZeroProduct Z.
Proof.
intros x y E.
destruct (int_abs_sig Z N x) as [[a Ea]|[a Ea]],
  (int_abs_sig Z N y) as [[b Eb]|[b Eb]].
- rewrite <-Ea,<-Eb in E.
  apply zero_product_aux in E.
  rewrite <-Ea,<-Eb.
  trivial.
- apply (ap negate) in E. rewrite negate_mult_distr_r in E.
  rewrite <-Ea,<-Eb in E.
  rewrite negate_0 in E.
  apply zero_product_aux in E.
  destruct E as [E|E].
  + left;rewrite <-Ea;trivial.
  + right.
    apply (injective negate).
    rewrite negate_0,<-Eb;trivial.
- apply (ap negate) in E. rewrite negate_mult_distr_l in E.
  rewrite <-Ea,<-Eb in E.
  rewrite negate_0 in E.
  apply zero_product_aux in E.
  destruct E as [E|E].
  + left.
    apply (injective negate).
    rewrite negate_0,<-Ea;trivial.
  + right;rewrite <-Eb;trivial.
- rewrite <-negate_mult_negate,<-Ea,<-Eb in E.
  apply zero_product_aux in E.
  destruct E as [E|E].
  + left.
    apply (injective negate).
    rewrite negate_0,<-Ea;trivial.
  + right.
    apply (injective negate).
    rewrite negate_0,<-Eb;trivial.
Qed.

Global Instance Z_zero_product@{} : ZeroProduct Z
  := ltac:(first [exact Z_zero_product'@{Ularge Ularge}|
                  exact Z_zero_product'@{}]).

End contents.

Module Instances.
  Global Existing Instances
    T_set inject Tle_hprop Tlt_hprop Tapart_hprop Z_of_pair Z_of_N R_dec Z0 Z1 Z_plus Z_mult Z_negate Z_of_N_injective Zle ishprop_Zle Zle_cast_embedding Z_order Zle_dec Zlt ishprop_Zlt Z_strict_srorder Zlt_dec Zapart ishprop_Zapart Z_trivial_apart Z_to_ring Z_integers Z_abs Z_zero_product Z_of_N_morphism.
End Instances.

End NatPair.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Cat.Cat.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations.
From Categories Require Import NatTrans.NatTrans NatTrans.Operations NatTrans.Func_Cat
        NatTrans.NatIso.

(** Facts about products of acategories involving natural transformations. *)

Local Obligation Tactic := idtac.

Section Prod_Functor_NatTrans.
  Context {C D : Category}
          {F G : (C --> D)%functor}
          (N : (F --> G)%nattrans)
          {C' D' : Category}
          {F' G' : (C' --> D')%functor}
          (N' : (F' --> G')%nattrans).

  Program Definition Prod_Functor_NatTrans :
    ((Prod_Functor F F') --> (Prod_Functor G G'))%nattrans :=
    {| Trans := fun c => (Trans N (fst c), Trans N' (snd c)) |}.
  Next Obligation.
    basic_simpl.
    do 2 rewrite Trans_com; trivial.
  Qed.
  Next Obligation.
    symmetry.
    apply Prod_Functor_NatTrans_obligation_1.
  Qed.

End Prod_Functor_NatTrans.

Section Prod_Functor_NatTrans_id.
  Context {C D : Category} (F : (C --> D)%functor)
          {C' D' : Category} {F' : (C' --> D')%functor}.

  Theorem Prod_Functor_NatTrans_id :
    Prod_Functor_NatTrans (NatTrans_id F) (NatTrans_id F') =
    NatTrans_id (Prod_Functor F F').
  Proof. apply NatTrans_eq_simplify; trivial. Qed.

End Prod_Functor_NatTrans_id.

Section Prod_Functor_NatTrans_compose.
  Context {C D : Category}
          {F G H : (C --> D)%functor}
          (N1 : (F --> G)%nattrans)
          (N2 : (G --> H)%nattrans)
          {C' D' : Category}
          {F' G' H' : (C' --> D')%functor}
          (N1' : (F' --> G')%nattrans)
          (N2' : (G' --> H')%nattrans).

  Theorem Prod_Functor_NatTrans_compose :
    ((Prod_Functor_NatTrans N2 N2') ∘ (Prod_Functor_NatTrans N1 N1') =
     Prod_Functor_NatTrans (N2 ∘ N1) (N2' ∘ N1'))%nattrans.
  Proof. apply NatTrans_eq_simplify; trivial. Qed.

End Prod_Functor_NatTrans_compose.

Section Prod_Functor_NatIso.
  Context {C D : Category}
          {F G : (C --> D)%functor}
          (N : (F ≃ G)%natiso)
          {C' D' : Category}
          {F' G' : (C' --> D')%functor}
          (N' : (F' ≃ G')%natiso)
  .

  Program Definition Prod_Functor_NatIso :
    ((Prod_Functor F F') ≃ (Prod_Functor G G'))%natiso :=
    {|
      iso_morphism := Prod_Functor_NatTrans (iso_morphism N) (iso_morphism N');
      inverse_morphism :=
        Prod_Functor_NatTrans (inverse_morphism N) (inverse_morphism N')
    |}.

  Next Obligation.
    cbn.
    rewrite Prod_Functor_NatTrans_compose.
    change ((N ⁻¹)%morphism ∘ (iso_morphism N))%nattrans
      with (N⁻¹ ∘ N)%morphism.
    change ((N' ⁻¹)%morphism ∘ (iso_morphism N'))%nattrans
      with (N'⁻¹ ∘ N')%morphism.
    do 2 rewrite (left_inverse).
    apply Prod_Functor_NatTrans_id.
  Qed.

  Next Obligation.
    cbn.
    rewrite Prod_Functor_NatTrans_compose.
    change ((iso_morphism N) ∘ (N ⁻¹)%morphism)%nattrans with
        (N ∘ N⁻¹)%morphism.
    change ((iso_morphism N') ∘ (N' ⁻¹)%morphism)%nattrans with
        (N' ∘ N'⁻¹)%morphism.
    do 2 rewrite (right_inverse).
    apply Prod_Functor_NatTrans_id.
  Qed.

End Prod_Functor_NatIso.

Section Fix_Bi_Func_1_NatTrans.
  Context {B C D E : Category}
          {F F' : (((Func_Cat C D) × B) --> E)%functor}
          (N : (F --> F')%nattrans)
          (G : (C --> D)%functor).

  Program Definition Fix_Bi_Func_1_NatTrans :
    ((@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F)
       --> (@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F'))%nattrans
    :=
    {| Trans := fun c => Trans N (G, c) |}.
  Next Obligation.
  Proof.
    intros c c' h.
    apply (@Trans_com _ _ _ _ N (G, c) (G, c') (NatTrans_id _, h)).
  Qed.
  Next Obligation.
  Proof.
    intros c c' h.
    apply (@Trans_com_sym _ _ _ _ N (G, c) (G, c') (NatTrans_id _, h)).
  Qed.

End Fix_Bi_Func_1_NatTrans.

Section Fix_Bi_Func_1_NatIso.
  Context {B C D E : Category}
          {F F' : (((Func_Cat C D) × B) --> E)%functor}
          (N : (F ≃ F')%natiso)
          (G : (C --> D)%functor).

  Program Definition Fix_Bi_Func_1_NatIso :
    ((@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F)
       ≃ (@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F'))%natiso
    :=
    {|
      iso_morphism := Fix_Bi_Func_1_NatTrans (iso_morphism N) G;
      inverse_morphism := Fix_Bi_Func_1_NatTrans (inverse_morphism N) G
    |}.
  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c.
    cbn.
    change (Trans (inverse_morphism N) (G, c) ∘
            Trans (iso_morphism N) (G, c))%morphism with
        (Trans ((inverse_morphism N) ∘ (iso_morphism N)) (G, c)).
    cbn_rewrite (left_inverse N); trivial.
  Qed.
  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c; cbn.
    change (Trans (iso_morphism N) (G, c) ∘
            Trans (inverse_morphism N) (G, c))%morphism with
        (Trans ((iso_morphism N) ∘ (inverse_morphism N)) (G, c)).
    cbn_rewrite (right_inverse N); trivial.
  Qed.

End Fix_Bi_Func_1_NatIso.

Section Fix_Bi_Func_2_NatTrans.
  Context {B C D E : Category}
          {F F' : ((B × (Func_Cat C D)) --> E)%functor}
          (N : (F --> F')%nattrans)
          (G : (C --> D)%functor).

  Program Definition Fix_Bi_Func_2_NatTrans :
    ((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F) -->
     (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F'))%nattrans
    :=
    {| Trans := fun c => Trans N (c, G) |}.
  Next Obligation.
  Proof. intros; apply (@Trans_com _ _ _ _ N). Qed.
  Next Obligation.
  Proof. intros; apply (@Trans_com_sym _ _ _ _ N). Qed.

End Fix_Bi_Func_2_NatTrans.

Section Fix_Bi_Func_2_NatIso.
  Context {B C D E : Category}
          {F F' : ((B × (Func_Cat C D)) --> E)%functor}
          (N : (F ≃ F')%natiso)
          (G : (C --> D)%functor).

  Program Definition Fix_Bi_Func_2_NatIso :
    ((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F) ≃
     (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F'))%natiso
    :=
      {|
        iso_morphism := Fix_Bi_Func_2_NatTrans (iso_morphism N) G;
        inverse_morphism := Fix_Bi_Func_2_NatTrans (inverse_morphism N) G
      |}.
  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c.
    cbn.
    change (Trans (inverse_morphism N) (c, G) ∘
                  Trans (iso_morphism N) (c, G))%morphism
    with (Trans ((inverse_morphism N) ∘ (iso_morphism N)) (c, G)).
    cbn_rewrite (left_inverse N); trivial.
  Qed.
  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c.
    cbn.
    change (Trans (iso_morphism N) (c, G) ∘
                  Trans (inverse_morphism N) (c, G))%morphism
    with (Trans ((iso_morphism N) ∘ (inverse_morphism N)) (c, G)).
    cbn_rewrite (right_inverse N); trivial.
  Qed.

End Fix_Bi_Func_2_NatIso.

Section Fix_Bi_Func_1_Functor_id_swap_NatIso.
  Context {B B' C D E E' : Category}
          (F : (B --> B')%functor)
          (F' : (((Func_Cat C D) × B') --> E)%functor)
          (G : (C --> D)%functor).

  Local Obligation Tactic := cbn; auto.

  Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn : core.

  Program Definition Fix_Bi_Func_1_Functor_id_swap_NatIso :
    ((@Fix_Bi_Func_1
        (Func_Cat _ _) _ _ G ( F' ∘ (Prod_Functor (Functor_id _) F)))%functor ≃
    ((@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F') ∘ F)%functor)%natiso :=
    {|
      iso_morphism :=
        {|
          Trans := fun c => id
        |};
      inverse_morphism :=
        {|
          Trans := fun c => id
        |}
    |}.

End Fix_Bi_Func_1_Functor_id_swap_NatIso.

Section Fix_Bi_Func_2_Functor_id_swap_NatIso.
  Context {B B' C D E E' : Category}
          (F : (B --> B')%functor)
          (F' : ((B' × (Func_Cat C D)) --> E)%functor)
          (G : (C --> D)%functor).

  Local Obligation Tactic := cbn; auto.

  Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn : core.

  Program Definition Fix_Bi_Func_2_Functor_id_swap_NatIso :
    (((@Fix_Bi_Func_2
         _ (Func_Cat _ _) _ G (F' ∘ (Prod_Functor F (Functor_id _))))%functor) ≃
    ((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F') ∘ F)%functor)%natiso :=
    {|
      iso_morphism :=
        {|
          Trans := fun c => id
        |};
      inverse_morphism :=
        {|
          Trans := fun c => id
        |}
    |}.

End Fix_Bi_Func_2_Functor_id_swap_NatIso.

Section Fix_Bi_1_Func_Prod_Func_NatIso.
  Context {A B C D E : Category}
          (F : (A --> C)%functor)
          (F' : (B --> D)%functor)
          (G : ((C × D) --> E)%functor)
          (x : A).

  Local Obligation Tactic := cbn; auto.

  Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn : core.

  Program Definition Fix_Bi_1_Func_Prod_Func_NatIso :
    (((Fix_Bi_Func_1 x (G ∘ (Prod_Functor F F')))%functor) ≃
    ((Fix_Bi_Func_1 (F _o x) (G ∘ (Prod_Functor (Functor_id C) F'))))%functor
    )%natiso :=
    {|
      iso_morphism := {|Trans := fun c => id|};
      inverse_morphism := {|Trans := fun c => id|}
    |}.

End Fix_Bi_1_Func_Prod_Func_NatIso.

Section Fix_Bi_2_Func_Prod_Func_NatIso.
  Context {A B C D E : Category}
          (F : (A --> C)%functor)
          (F' : (B --> D)%functor)
          (G : ((C × D) --> E)%functor)
          (x : B).

  Local Obligation Tactic := cbn; auto.

  Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn : core.

  Program Definition Fix_Bi_2_Func_Prod_Func_NatIso :
    (((Fix_Bi_Func_2 x (G ∘ (Prod_Functor F F')))%functor) ≃
      (Fix_Bi_Func_2 (F' _o x) (G ∘  (Prod_Functor F (Functor_id D))))%functor)
      %natiso :=
    {|
      iso_morphism := {|Trans := fun c => id|};
      inverse_morphism := {|Trans := fun c => id|}
    |}.

End Fix_Bi_2_Func_Prod_Func_NatIso.

Section Func_Prod_of_ids_NatIso.
  Context {C D E : Category} (F : ((C × D) --> E)%functor).

  Local Obligation Tactic := cbn; auto.

  Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn : core.

  Program Definition Func_Prod_of_ids_NatIso :
    ((F ∘ (Prod_Functor (Functor_id C) (Functor_id D)))%functor ≃ F )%natiso :=
    {|
      iso_morphism := {|Trans := fun c => id|};
      inverse_morphism := {|Trans := fun c => id|}
    |}.

End Func_Prod_of_ids_NatIso.

Section Fix_Bi_Func_1_object_NatTrans.
  Context {B C D E : Category}
          (F : (((Func_Cat C D) × B) --> E)%functor)
          {G G' : (C --> D)%functor}
          (N : (G --> G')%nattrans).

  Program Definition Fix_Bi_Func_1_object_NatTrans :
    ((@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F) -->
     (@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G' F))%nattrans
     :=
    {| Trans := fun c => (F @_a (G, c) (G', c) (N, id))%morphism |}.
  Next Obligation.
  Proof.
    intros c c' h.
    cbn.
    repeat rewrite <- F_compose.
    cbn.
    rewrite NatTrans_id_unit_left, NatTrans_id_unit_right.
    auto.
  Qed.
  Next Obligation.
  Proof.
    symmetry.
    apply Fix_Bi_Func_1_object_NatTrans_obligation_1.
  Qed.

End Fix_Bi_Func_1_object_NatTrans.

Section Fix_Bi_Func_1_object_NatIso.
  Context {B C D E : Category}
          (F : (((Func_Cat C D) × B) --> E)%functor)
          {G G' : (C --> D)%functor}
          (N : (G ≃ G')%natiso).

  Program Definition Fix_Bi_Func_1_object_NatIso :
    (
      ((@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G F)%functor) ≃
       (@Fix_Bi_Func_1 (Func_Cat _ _) _ _ G' F)%functor)%natiso :=
    {|
      iso_morphism := Fix_Bi_Func_1_object_NatTrans F (iso_morphism N);
      inverse_morphism := Fix_Bi_Func_1_object_NatTrans F (inverse_morphism N)
    |}.
  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c; cbn.
    rewrite <- F_compose; cbn.
    cbn_rewrite (left_inverse N).
    simpl_ids.
    change (NatTrans_id G, id) with (id ((Func_Cat _ _) × B) (G, c)).
    auto.
  Qed.
  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c; cbn.
    rewrite <- F_compose; cbn.
    cbn_rewrite (right_inverse N).
    simpl_ids.
    change (NatTrans_id G', id) with (id ((Func_Cat _ _) × B) (G', c)).
    auto.
  Qed.

End Fix_Bi_Func_1_object_NatIso.

Section Fix_Bi_Func_2_object_NatTrans.
  Context {B C D E : Category} (F : ((B × (Func_Cat C D)) --> E)%functor)
          {G G' : (C --> D)%functor}
          (N : (G --> G')%nattrans).

  Program Definition Fix_Bi_Func_2_object_NatTrans :
    ((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F) -->
     (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G' F))%nattrans
    :=
    {| Trans := fun c => (F @_a (c, G) (c, G') (id, N))%morphism |}.
  Next Obligation.
  Proof.
    intros c c' h; cbn.
    repeat rewrite <- F_compose; cbn.
    rewrite NatTrans_id_unit_left, NatTrans_id_unit_right.
    auto.
  Qed.
  Next Obligation.
  Proof.
    symmetry.
    apply Fix_Bi_Func_2_object_NatTrans_obligation_1.
  Qed.

End Fix_Bi_Func_2_object_NatTrans.

Section Fix_Bi_Func_2_object_NatIso.
  Context {B C D E : Category}
          (F : ((B × (Func_Cat C D)) --> E)%functor)
          {G G' : (C --> D)%functor}
          (N : (G ≃ G')%natiso).

  Program Definition Fix_Bi_Func_2_object_NatIso :
    (((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G F)%functor) ≃
      (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ G' F)%functor)%natiso :=
    {|
      iso_morphism := Fix_Bi_Func_2_object_NatTrans F (iso_morphism N);
      inverse_morphism := Fix_Bi_Func_2_object_NatTrans F (inverse_morphism N)
    |}.
  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c; cbn.
    rewrite <- F_compose; cbn.
    simpl_ids.
    cbn_rewrite (left_inverse N).
    change (id, NatTrans_id G) with (id (B × (Func_Cat _ _)) (c, G)).
    auto.
  Qed.
  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality c; cbn.
    rewrite <- F_compose; cbn.
    simpl_ids.
    cbn_rewrite (right_inverse N).
    change (id, NatTrans_id G') with (id (B × (Func_Cat _ _)) (c, G')).
    auto.
  Qed.

End Fix_Bi_Func_2_object_NatIso.


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

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              Nov 25th 1994                               *)
(*                                                                          *)
(****************************************************************************)
(*                             determinePC_SL.v                             *)
(****************************************************************************)

(*****************************************************************************)
(*          Projet Coq  - Calculus of Inductive Constructions V5.8           *)
(*****************************************************************************)
(*                                                                           *)
(*      Meta-theory of the explicit substitution calculus lambda-env         *)
(*      Amokrane Saibi                                                       *)
(*                                                                           *)
(*      September 1993                                                       *)
(*                                                                           *)
(*****************************************************************************)

    (* confluence locale de sigma-lift: determination des paires critiques *)

  (* L'idee est:
     partant d'un terme-substitution X, trouver tous ses "reduits" possibles
     par la relation sigma-lift (SL), c.a.d. tous les Y tq: X--SL-->Y.
     on prendra notamment pour X tous les membres gauches des regles de
     sigma-lift, ceci nous indique les paires critiques (PC) a resoudre     *)

Require Import TS.
Require Import sur_les_relations.
Require Import egaliteTS.
Require Import sigma_lift.
Require Import inversionSL.

(*** (var n) SL ? ***)

Goal forall (n : nat) (M : terms), ~ e_relSL _ (var n) M.
red in |- *; intros n M H; cut (e_invSL _ (var n) M).
2: auto.
simple induction 1.
Save case_SLvar.

(*** (app a b) SL ? ***)

Goal
forall (P : terms -> Prop) (a b : terms),
(forall a' : terms, e_relSL _ a a' -> P (app a' b)) ->
(forall b' : terms, e_relSL _ b b' -> P (app a b')) ->
forall M : terms, e_relSL _ (app a b) M -> P M.
intros P a b H H0 M H1; cut (e_invSL _ (app a b) M).
2: auto.
pattern M in |- *; apply terms_ind.
(* var *)
simple induction 1.
(* app *)
simple induction 3; simple induction 1; intros.
elim H7; apply H; assumption.
elim H6; apply H0; assumption.
(* lam *)
simple induction 2.
(* env *)
simple induction 2.
(* X *)
simple induction 1.
Save case_SLapp.

(*** (lambda a) SL ? ***)

Goal
forall (P : terms -> Prop) (a : terms),
(forall a' : terms, e_relSL _ a a' -> P (lambda a')) ->
forall M : terms, e_relSL _ (lambda a) M -> P M.
intros P a H M H0; cut (e_invSL _ (lambda a) M).
2: auto.
pattern M in |- *; apply terms_ind.
(* var *)
simple induction 1.
(* app *)
simple induction 3.
(* lambda *)
unfold e_invSL at 2 in |- *; intros; apply H; assumption.
(* env *)
simple induction 2.
(* X *)
simple induction 1.
Save case_SLlambda.

(*** (env a s) SL ? ***)

Goal
forall (P : terms -> sub_explicits -> terms -> Prop)
  (a : terms) (s : sub_explicits),
(forall a1 b1 : terms, P (app a1 b1) s (app (env a1 s) (env b1 s))) ->
(forall a1 : terms, P (lambda a1) s (lambda (env a1 (lift s)))) ->
(forall (a1 : terms) (s1 : sub_explicits),
 P (env a1 s1) s (env a1 (comp s1 s))) ->
(forall n : nat, P (var n) shift (var (S n))) ->
(forall (n : nat) (s1 : sub_explicits),
 P (var n) (comp shift s1) (env (var (S n)) s1)) ->
(forall (a1 : terms) (s1 : sub_explicits), P (var 0) (cons a1 s1) a1) ->
(forall s1 : sub_explicits, P (var 0) (lift s1) (var 0)) ->
(forall s1 s2 : sub_explicits, P (var 0) (comp (lift s1) s2) (env (var 0) s2)) ->
(forall (n : nat) (a1 : terms) (s1 : sub_explicits),
 P (var (S n)) (cons a1 s1) (env (var n) s1)) ->
(forall (n : nat) (s1 : sub_explicits),
 P (var (S n)) (lift s1) (env (var n) (comp s1 shift))) ->
(forall (n : nat) (s1 s2 : sub_explicits),
 P (var (S n)) (comp (lift s1) s2) (env (var n) (comp s1 (comp shift s2)))) ->
P a id a ->
(forall a' : terms, e_relSL _ a a' -> P a s (env a' s)) ->
(forall s' : sub_explicits, e_relSL _ s s' -> P a s (env a s')) ->
forall M : terms, e_relSL _ (env a s) M -> P a s M.
intros P a s; intros; cut (e_invSL _ (env a s) M).
2: auto.
pattern M in |- *; apply terms_ind.
(* var *)
simple induction 1.
 (* varshift1 *)
do 2 simple induction 1; simple induction 2; intros.
rewrite H20; rewrite H19; rewrite H17; apply H2.
 (* fvarlift1 *)
simple induction 1.
do 2 simple induction 1; simple induction 2; intros.
rewrite H21; rewrite H20; rewrite H18; apply H5.
 (* fvarcons *)
simple induction 1.
do 2 simple induction 1; intros.
rewrite H20; rewrite H19; apply H4.
 (* id *)
simple induction 1; intros.
elim H18; rewrite H19; apply H10.
(* app *)
 (* app *)
simple induction 3.
do 3 simple induction 1; simple induction 2; intros.
rewrite H23; rewrite H22; rewrite H20; apply H.
 (* fvarcons *)
simple induction 1.
do 2 simple induction 1; intros.
rewrite H21; rewrite H20; apply H4.
 (* id *)
simple induction 1; intros.
rewrite H20; elim H19; apply H10.
(* lam *)
 (* lambda *)
simple induction 2.
do 2 simple induction 1; intros.
rewrite H19; rewrite H18; apply H0.
 (* fvarcons *)
simple induction 1.
do 2 simple induction 1; intros.
rewrite H20; rewrite H19; apply H4.
 (* id *)
simple induction 1; intros.
rewrite H19; elim H18; apply H10.
(* env *)
 (* clos *)
simple induction 2.
do 2 simple induction 1; intros.
rewrite H19; rewrite H18; apply H1.
 (* varshift2 *)
simple induction 1.
do 2 simple induction 1; simple induction 2; intros.
rewrite H22; rewrite H21; rewrite H19; apply H3.
 (* fvarcons *)
simple induction 1.
do 2 simple induction 1; intros.
rewrite H21; rewrite H20; apply H4.
 (* favrlift2 *)
simple induction 1.
do 2 simple induction 1; simple induction 2; intros.
rewrite H24; rewrite H23; rewrite H21; apply H6.
 (* rvarcons *)
simple induction 1.
do 3 simple induction 1; simple induction 2; intros.
rewrite H26; rewrite H25; rewrite H23; apply H7.
 (* rvarlift1 *)
simple induction 1.
do 3 simple induction 1; do 2 simple induction 2; intros.
rewrite H29; rewrite H28; rewrite H26; rewrite H24; apply H8.
 (* rvarlift2 *)
simple induction 1.
do 4 simple induction 1; do 2 simple induction 2; intros.
rewrite H31; rewrite H30; rewrite H28; rewrite H26; apply H9.
 (* id *)
simple induction 1.
simple induction 1; intros.
rewrite H25; elim H24; apply H10.
 (* contexte droit *)
simple induction 1.
simple induction 1; intros.
elim H26; apply H11; assumption.
 (* contexte gauche *)
simple induction 1.
simple induction 1; intros.
elim H25; apply H12; assumption.
(* X *)
simple induction 1.
 (* fvarcons *)
do 2 simple induction 1; intros.
rewrite H18; rewrite H17; apply H4.
 (* id *)
simple induction 1; intros.
elim H16; rewrite H17; assumption.
Save case_SLenv.

(*** id SL ? ***)

Goal forall M : sub_explicits, ~ e_relSL _ id M.
red in |- *; intros M H; cut (e_invSL _ id M).
2: auto.
simple induction 1.
Save case_SLid.

(*** shift SL ? ***)

Goal forall M : sub_explicits, ~ e_relSL _ shift M.
red in |- *; intros M H; cut (e_invSL _ shift M).
2: auto.
simple induction 1.
Save case_SLshift.

(*** (cons a s) SL ? ***)

Goal
forall (P : sub_explicits -> Prop) (a : terms) (s : sub_explicits),
(forall a' : terms, e_relSL _ a a' -> P (cons a' s)) ->
(forall s' : sub_explicits, e_relSL _ s s' -> P (cons a s')) ->
forall M : sub_explicits, e_relSL _ (cons a s) M -> P M.
intros P a s H H0 M H1; cut (e_invSL _ (cons a s) M).
2: auto.
pattern M in |- *; apply sub_explicits_ind.
(* id *)
simple induction 1.
(* | *)
simple induction 1.
(* . *)
simple induction 2; simple induction 1; intros.
elim H6; apply H; assumption.
elim H5; apply H0; assumption.
(* o *)
simple induction 3.
(* || *)
simple induction 2.
(* x *)
simple induction 1.
Save case_SLcons.

(*** (comp s t) SL ? ***)

Goal
forall (P : sub_explicits -> sub_explicits -> sub_explicits -> Prop)
  (s t : sub_explicits),
(forall s1 s2 : sub_explicits, P (comp s1 s2) t (comp s1 (comp s2 t))) ->
(forall (a : terms) (s1 : sub_explicits),
 P (cons a s1) t (cons (env a t) (comp s1 t))) ->
(forall (a : terms) (t1 : sub_explicits), P shift (cons a t1) t1) ->
(forall t1 : sub_explicits, P shift (lift t1) (comp t1 shift)) ->
(forall t1 t2 : sub_explicits,
 P shift (comp (lift t1) t2) (comp t1 (comp shift t2))) ->
(forall s1 t1 : sub_explicits, P (lift s1) (lift t1) (lift (comp s1 t1))) ->
(forall s1 t1 t2 : sub_explicits,
 P (lift s1) (comp (lift t1) t2) (comp (lift (comp s1 t1)) t2)) ->
(forall (a : terms) (s1 t1 : sub_explicits),
 P (lift s1) (cons a t1) (cons a (comp s1 t1))) ->
P id t t ->
P s id s ->
(forall s' : sub_explicits, e_relSL _ s s' -> P s t (comp s' t)) ->
(forall t' : sub_explicits, e_relSL _ t t' -> P s t (comp s t')) ->
forall M : sub_explicits, e_relSL _ (comp s t) M -> P s t M.
intros P s t; intros; cut (e_invSL _ (comp s t) M).
2: auto.
pattern M in |- *; apply sub_explicits_ind.
(* id *)
 (* shiftcons *)
simple induction 1.
do 2 simple induction 1; intros.
rewrite H15; rewrite H16; apply H1.
 (* idr, idl *)
simple induction 1; intros.
rewrite H14; pattern id at 2 in |- *; elim H15; apply H7.
(* | *)
simple induction 1.
do 2 simple induction 1; intros.
rewrite H15; rewrite H16; apply H1.
 (* idl *)
simple induction 1.
simple induction 1; intros.
rewrite H15; elim H16; apply H7.
 (* idr *)
simple induction 1; intros.
rewrite H16; elim H15; apply H8.
(* cons *)
 (* mapenv *)
simple induction 2.
do 3 simple induction 1; simple induction 2; intros.
rewrite H17; rewrite H20; rewrite H19; apply H0.
 (* shiftcons *)
simple induction 1.
do 2 simple induction 1; intros.
rewrite H17; rewrite H18; apply H1.
 (* liftenv *)
simple induction 1.
do 3 simple induction 1; simple induction 2; intros.
rewrite H22; rewrite H21; rewrite H19; apply H6.
 (* idl *)
simple induction 1.
simple induction 1; intros.
rewrite H18; elim H19; apply H7.
 (* idr *)
simple induction 1; intros.
rewrite H19; elim H18; apply H8.
(* comp *)
simple induction 3.
 (* assenv *)
do 2 simple induction 1; intros.
rewrite H18; rewrite H17; apply H.
 (* shiftcons *)
simple induction 1.
do 2 simple induction 1; intros.
rewrite H18; rewrite H19; apply H1.
 (* shiftlift1 *)
simple induction 1.
simple induction 1; simple induction 2; intros.
rewrite H21; rewrite H20; rewrite H18; apply H2.
 (* shiftlift2 *)
simple induction 1.
do 2 simple induction 1; simple induction 2; intros.
rewrite H23; rewrite H22; rewrite H20; apply H3.
 (* lift2 *)
simple induction 1.
do 3 simple induction 1; simple induction 2; intros.
rewrite H25; rewrite H24; rewrite H22; apply H5.
 (* idl *)
simple induction 1.
simple induction 1; intros.
rewrite H21; elim H22; apply H7.
 (* idr *)
simple induction 1.
simple induction 1; intros.
rewrite H23; elim H22; apply H8.
 (* contexte gauche *)
simple induction 1.
simple induction 1; intros.
elim H24; apply H9; assumption.
 (* contexte droit *)
simple induction 1; intros.
elim H23; apply H10; assumption.
(* lift *)
simple induction 2.
 (* shiftcons *)
do 2 simple induction 1; intros.
rewrite H17; rewrite H16; apply H1.
 (* lift1 *)
simple induction 1.
do 3 simple induction 1; simple induction 2; intros.
rewrite H21; rewrite H20; rewrite H18; apply H4.
 (* idl *)
simple induction 1.
simple induction 1; intros.
rewrite H17; elim H18; apply H7.
 (* idr *)
simple induction 1; intros.
rewrite H18; elim H17; apply H8.
(* x *)
simple induction 1.
do 2 simple induction 1; intros.
rewrite H15; rewrite H16; apply H1.
 (* idl *)
simple induction 1.
simple induction 1; intros.
rewrite H15; elim H16; apply H7.
 (* idr *)
simple induction 1; intros.
rewrite H16; elim H15; apply H8.
Save case_SLcomp.

(*** (lift s) SL ? ***)

Goal
forall (P : sub_explicits -> sub_explicits -> Prop) (s : sub_explicits),
P id id ->
(forall s' : sub_explicits, e_relSL _ s s' -> P s (lift s')) ->
forall M : sub_explicits, e_relSL _ (lift s) M -> P s M.
intros P s H H0 M H1; cut (e_invSL _ (lift s) M).
2: auto.
pattern M in |- *; apply sub_explicits_ind.
(* id *)
simpl in |- *; intro H2; rewrite H2; assumption.
(* | *)
simple induction 1.
(* . *)
simple induction 2.
(* o *)
simple induction 3.
(* || *)
unfold e_invSL at 2 in |- *; intros; apply H0; assumption.
(* x *)
simple induction 1.
Save case_SLlift.

(*** (env (lambda a) s) SL ? ***)

Goal
forall (P : sub_explicits -> terms -> Prop) (a : terms) (s : sub_explicits),
P s (lambda (env a (lift s))) ->
P id (lambda a) ->
(forall x' : terms, e_relSL _ (lambda a) x' -> P s (env x' s)) ->
(forall s' : sub_explicits, e_relSL _ s s' -> P s (env (lambda a) s')) ->
forall M : terms, e_relSL _ (env (lambda a) s) M -> P s M.
intros.
cut (lambda a = lambda a).
2: auto.
pattern (lambda a) at 1, s, M in |- *; apply case_SLenv; intros.
15: assumption.
(* app *)elim (diff_app_lambda a1 b1 a H4).
(* lambda *)
rewrite (proj_lambda a1 a H4); assumption.
(* clos *)elim (diff_lambda_env a a1 s1 (sym_equal H4)).
(* varshift1 *)elim (diff_var_lambda n a H4).
(* varshift2 *)elim (diff_var_lambda n a H4).
(* fvarcons *)elim (diff_var_lambda 0 a H4).
(* fvarlift1 *)elim (diff_var_lambda 0 a H4).
(* fvarlift2 *)elim (diff_var_lambda 0 a H4).
(* rvarcons *)elim (diff_var_lambda (S n) a H4).
(* rvarlift1 *)elim (diff_var_lambda (S n) a H4).
(* rvarlift2 *)elim (diff_var_lambda (S n) a H4).
(* id *)
assumption.
(* contexte gauche*)
apply H1; assumption.
(* contexte droit *)
apply H2; assumption.
Save case_SL_reg_lambda.

(*** (env (app a b) s) SL ? ***)

Goal
forall (P : sub_explicits -> terms -> Prop) (a b : terms) (s : sub_explicits),
P s (app (env a s) (env b s)) ->
P id (app a b) ->
(forall x' : terms, e_relSL _ (app a b) x' -> P s (env x' s)) ->
(forall s' : sub_explicits, e_relSL _ s s' -> P s (env (app a b) s')) ->
forall M : terms, e_relSL _ (env (app a b) s) M -> P s M.
intros.
cut (app a b = app a b).
2: auto.
pattern (app a b) at 1, s, M in |- *; apply case_SLenv; intros.
15: assumption.
(* app *)
rewrite (proj_app1 a1 b1 a b H4); rewrite (proj_app2 a1 b1 a b H4);
 assumption.
(* lambda *)elim (diff_app_lambda a b a1 (sym_equal H4)).
(* clos *)elim (diff_app_env a b a1 s1 (sym_equal H4)).
(* varshift1 *)elim (diff_var_app n a b H4).
(* varshift2 *)elim (diff_var_app n a b H4).
(* fvarcons *)elim (diff_var_app 0 a b H4).
(* fvarlift1 *)elim (diff_var_app 0 a b H4).
(* fvarlift2 *)elim (diff_var_app 0 a b H4).
(* rvarcons *)elim (diff_var_app (S n) a b H4).
(* rvarlift1 *)elim (diff_var_app (S n) a b H4).
(* rvarlift2 *)elim (diff_var_app (S n) a b H4).
(* id *)
assumption.
(* contexte gauche*)
apply H1; assumption.
(* contexte droit *)
apply H2; assumption.
Save case_SL_reg_app.

(*** (env (env a s) t) SL ? ***)

Goal
forall (P : sub_explicits -> terms -> Prop) (a : terms) (s t : sub_explicits),
P t (env a (comp s t)) ->
P id (env a s) ->
(forall x' : terms, e_relSL _ (env a s) x' -> P t (env x' t)) ->
(forall t' : sub_explicits, e_relSL _ t t' -> P t (env (env a s) t')) ->
forall M : terms, e_relSL _ (env (env a s) t) M -> P t M.
intros.
cut (env a s = env a s).
2: auto.
pattern (env a s) at 1, t, M in |- *; apply case_SLenv; intros.
15: assumption.
(* app *)elim (diff_app_env a1 b1 a s H4).
(* lambda *)elim (diff_lambda_env a1 a s H4).
(* clos *)
rewrite (proj_env1 a1 a s1 s H4); rewrite (proj_env2 a1 a s1 s H4).
assumption.
(* varshift1 *)elim (diff_var_env n a s H4).
(* varshift2 *)elim (diff_var_env n a s H4).
(* fvarcons *)elim (diff_var_env 0 a s H4).
(* fvarlift1 *)elim (diff_var_env 0 a s H4).
(* fvarlift2 *)elim (diff_var_env 0 a s H4).
(* rvarcons *)elim (diff_var_env (S n) a s H4).
(* rvarlift1 *)elim (diff_var_env (S n) a s H4).
(* rvarlift2 *)elim (diff_var_env (S n) a s H4).
(* id *)
assumption.
(* contexte gauche*)
apply H1; assumption.
(* contexte droit *)
apply H2; assumption.
Save case_SL_clos.

(*** (env (var n) shift) SL ? ***)

Goal
forall (P : terms -> Prop) (n : nat),
P (var (S n)) -> forall M : terms, e_relSL _ (env (var n) shift) M -> P M.
intros.
cut (var n = var n).
2: auto.
cut (shift = shift).
2: auto.
pattern (var n) at 1, shift at 1, M in |- *; apply case_SLenv; intros.
15: assumption.
(* app *)elim (diff_var_app n a1 b1 (sym_equal H2)).
(* lambda *)elim (diff_var_lambda n a1 (sym_equal H2)).
(* clos *)elim (diff_var_env n a1 s1 (sym_equal H2)).
(* varshift1 *)
rewrite (proj_var n0 n H2); assumption.
(* varshift2 *)elim (diff_shift_comp shift s1 (sym_equal H1)).
(* fvarcons *)elim (diff_shift_cons a1 s1 (sym_equal H1)).
(* fvarlift1 *)elim (diff_shift_lift s1 (sym_equal H1)).
(* fvarlift2 *)elim (diff_shift_comp (lift s1) s2 (sym_equal H1)).
(* rvarcons *)elim (diff_shift_cons a1 s1 (sym_equal H1)).
(* rvarlift1 *)elim (diff_shift_lift s1 (sym_equal H1)).
(* rvarlift2 *)elim (diff_shift_comp (lift s1) s2 (sym_equal H1)).
(* id *)elim (diff_id_shift H1).
(* contexte gauche*)elim (case_SLvar n a' H1).
(* contexte droit *)elim (case_SLshift s' H1).
Save case_SL_varshift1.

(*** (comp shift s) SL ? ***)

Goal
forall (P : sub_explicits -> sub_explicits -> Prop) (s : sub_explicits),
(forall (a : terms) (s1 : sub_explicits), P (cons a s1) s1) ->
(forall s1 : sub_explicits, P (lift s1) (comp s1 shift)) ->
(forall s1 t : sub_explicits, P (comp (lift s1) t) (comp s1 (comp shift t))) ->
P id shift ->
(forall s' : sub_explicits, e_relSL _ s s' -> P s (comp shift s')) ->
forall M : sub_explicits, e_relSL _ (comp shift s) M -> P s M.
intros.
cut (shift = shift).
2: auto.
pattern shift at 1, s, M in |- *; apply case_SLcomp; intros.
13: assumption.
(* assenv *)elim (diff_shift_comp s1 s2 (sym_equal H5)).
(* mapenv *)elim (diff_shift_cons a s1 (sym_equal H5)).
(* shiftcons *)
apply H.
(* shiftlift1 *)
apply H0.
(* shiftlift2 *)
apply H1.
(* lift1 *)elim (diff_shift_lift s1 (sym_equal H5)).
(* lift2 *)elim (diff_shift_lift s1 (sym_equal H5)).
(* liftenv *)elim (diff_shift_lift s1 (sym_equal H5)).
(* idl *)elim (diff_id_shift H5).
(* idr *)
assumption.
(* contexte gauche *)elim (case_SLshift s' H5).
(* contexte droit *)
apply H3; assumption.
Save case_SLcomp1.

(*** (env (var n) (comp shift s)) SL ? ***)

Goal
forall (P : terms -> Prop) (n : nat) (s : sub_explicits),
P (env (var (S n)) s) ->
(forall x' : sub_explicits, e_relSL _ (comp shift s) x' -> P (env (var n) x')) ->
forall M : terms, e_relSL _ (env (var n) (comp shift s)) M -> P M.
intros.
cut (var n = var n).
2: auto.
cut (comp shift s = comp shift s).
2: auto.
pattern (var n) at 1, (comp shift s) at 1, M in |- *; apply case_SLenv;
 intros.
15: assumption.
(* app *)elim (diff_var_app n a1 b1 (sym_equal H3)).
(* lambda *)elim (diff_var_lambda n a1 (sym_equal H3)).
(* clos *)elim (diff_var_env n a1 s1 (sym_equal H3)).
(* varshift1 *)elim (diff_shift_comp shift s H2).
(* varshift2 *)
rewrite (proj_var n0 n H3); rewrite (proj_comp2 shift shift s1 s H2);
 assumption.
(* fvarcons *)elim (diff_cons_comp a1 s1 shift s H2).
(* fvarlift1 *)elim (diff_comp_lift shift s s1 (sym_equal H2)).
(* fvarlift2 *)elim
                (diff_shift_lift s1
                   (sym_equal (proj_comp1 (lift s1) shift s2 s H2))).
(* rvarcons *)elim (diff_cons_comp a1 s1 shift s H2).
(* rvarlift1 *)elim (diff_comp_lift shift s s1 (sym_equal H2)).
(* rvarlift2 *)elim
                (diff_shift_lift s1
                   (sym_equal (proj_comp1 (lift s1) shift s2 s H2))).
(* id *)elim (diff_id_comp shift s H2).
(* contexte gauche*)elim (case_SLvar n a' H2).
(* contexte droit *)apply H0; assumption.
Save case_SL_varshift2.

(*** (env (var O) (cons a s)) SL ? ***)

Goal
forall (P : terms -> Prop) (a : terms) (s : sub_explicits),
P a ->
(forall x' : sub_explicits, e_relSL _ (cons a s) x' -> P (env (var 0) x')) ->
forall M : terms, e_relSL _ (env (var 0) (cons a s)) M -> P M.
intros.
cut (var 0 = var 0).
2: auto.
cut (cons a s = cons a s).
2: auto.
pattern (var 0) at 1, (cons a s) at 1, M in |- *; apply case_SLenv; intros.
15: assumption.
(* app *)elim (diff_var_app 0 a1 b1 (sym_equal H3)).
(* lambda *)elim (diff_var_lambda 0 a1 (sym_equal H3)).
(* clos *)elim (diff_var_env 0 a1 s1 (sym_equal H3)).
(* varshift1 *)elim (diff_shift_cons a s H2).
(* varshift2 *)elim (diff_cons_comp a s shift s1 (sym_equal H2)).
(* fvarcons *)rewrite (proj_cons1 a1 a s1 s H2); assumption.
(* fvarlift1 *)elim (diff_cons_lift a s s1 (sym_equal H2)).
(* fvarlift2 *)elim (diff_cons_comp a s (lift s1) s2 (sym_equal H2)).
(* rvarcons *)elim (O_S n (sym_equal (proj_var (S n) 0 H3))).
(* rvarlift1 *)elim (diff_cons_lift a s s1 (sym_equal H2)).
(* rvarlift2 *)elim (O_S n (sym_equal (proj_var (S n) 0 H3))).
(* id *)elim (diff_id_cons a s H2).
(* contexte gauche*)elim (case_SLvar 0 a' H2).
(* contexte droit *)apply H0; assumption.
Save case_SL_fvarcons.

(*** (env (var O) (lift s)) SL ? ***)

Goal
forall (P : terms -> Prop) (s : sub_explicits),
P (var 0) ->
(forall x' : sub_explicits, e_relSL _ (lift s) x' -> P (env (var 0) x')) ->
forall M : terms, e_relSL _ (env (var 0) (lift s)) M -> P M.
intros.
cut (var 0 = var 0).
2: auto.
cut (lift s = lift s).
2: auto.
pattern (var 0) at 1, (lift s) at 1, M in |- *; apply case_SLenv; intros.
15: assumption.
(* app *)elim (diff_var_app 0 a1 b1 (sym_equal H3)).
(* lambda *)elim (diff_var_lambda 0 a1 (sym_equal H3)).
(* clos *)elim (diff_var_env 0 a1 s1 (sym_equal H3)).
(* varshift1 *)elim (diff_shift_lift s H2).
(* varshift2 *)elim (diff_comp_lift shift s1 s H2).
(* fvarcons *)elim (diff_cons_lift a1 s1 s H2).
(* fvarlift1 *)assumption.
(* fvarlift2 *)elim (diff_comp_lift (lift s1) s2 s H2).
(* rvarcons *)elim (diff_cons_lift a1 s1 s H2).
(* rvarlift1 *)elim (O_S n (sym_equal (proj_var (S n) 0 H3))).
(* rvarlift2 *)elim (diff_comp_lift (lift s1) s2 s H2).
(* id *)elim (diff_id_lift s H2).
(* contexte gauche*)elim (case_SLvar 0 a' H2).
(* contexte droit *)apply H0; assumption.
Save case_SL_fvarlift1.

(*** (comp (lift s) t) SL ? ***)

Goal
forall (P : sub_explicits -> sub_explicits -> Prop) (s t : sub_explicits),
(forall t1 : sub_explicits, P (lift t1) (lift (comp s t1))) ->
(forall t1 t2 : sub_explicits,
 P (comp (lift t1) t2) (comp (lift (comp s t1)) t2)) ->
(forall (a : terms) (t1 : sub_explicits), P (cons a t1) (cons a (comp s t1))) ->
P id (lift s) ->
(forall x' : sub_explicits, e_relSL _ (lift s) x' -> P t (comp x' t)) ->
(forall t' : sub_explicits, e_relSL _ t t' -> P t (comp (lift s) t')) ->
forall M : sub_explicits, e_relSL _ (comp (lift s) t) M -> P t M.
intros.
cut (lift s = lift s).
2: auto.
pattern (lift s) at 1, t, M in |- *; apply case_SLcomp; intros.
13: assumption.
(* assenv *)elim (diff_comp_lift s1 s2 s H6).
(* mapenv *)elim (diff_cons_lift a s1 s H6).
(* shiftcons *)elim (diff_shift_lift s H6).
(* shiftlift1 *)elim (diff_shift_lift s H6).
(* shiftlift2 *)elim (diff_shift_lift s H6).
(* lift1 *)
rewrite (proj_lift s1 s H6); apply H.
(* lift2 *)
rewrite (proj_lift s1 s H6); apply H0.
(* liftenv *)
rewrite (proj_lift s1 s H6); apply H1.
(* idl *)elim (diff_id_lift s H6).
(* idr *)
assumption.
(* contexte gauche *)
apply H3; assumption.
(* contexte droit *)
apply H4; assumption.
Save case_SLcomp2.

(*** (env (var O) (comp (lift s) t)) SL ? ***)

Goal
forall (P : terms -> Prop) (s t : sub_explicits),
P (env (var 0) t) ->
(forall x' : sub_explicits,
 e_relSL _ (comp (lift s) t) x' -> P (env (var 0) x')) ->
forall M : terms, e_relSL _ (env (var 0) (comp (lift s) t)) M -> P M.
intros.
cut (var 0 = var 0).
2: auto.
cut (comp (lift s) t = comp (lift s) t).
2: auto.
pattern (var 0) at 1, (comp (lift s) t) at 1, M in |- *; apply case_SLenv;
 intros.
15: assumption.
(* app *)elim (diff_var_app 0 a1 b1 (sym_equal H3)).
(* lambda *)elim (diff_var_lambda 0 a1 (sym_equal H3)).
(* clos *)elim (diff_var_env 0 a1 s1 (sym_equal H3)).
(* varshift1 *)elim (diff_shift_comp (lift s) t H2).
(* varshift2 *)elim (diff_shift_lift s (proj_comp1 shift (lift s) s1 t H2)).
(* fvarcons *)elim (diff_cons_comp a1 s1 (lift s) t H2).
(* fvarlift1 *)elim (diff_comp_lift (lift s) t s1 (sym_equal H2)).
(* fvarlift2 *)
rewrite (proj_comp2 (lift s1) (lift s) s2 t H2); assumption.
(* rvarcons *)elim (diff_cons_comp a1 s1 (lift s) t H2).
(* rvarlift1 *)elim (diff_comp_lift (lift s) t s1 (sym_equal H2)).
(* rvarlift2 *)elim (O_S n (sym_equal (proj_var (S n) 0 H3))).
(* id *)elim (diff_id_comp (lift s) t H2).
(* contexte gauche*)elim (case_SLvar 0 a' H2).
(* contexte droit *)apply H0; assumption.
Save case_SL_fvarlift2.

(*** (env (var (S n)) (cons a s)) SL ? ***)

Goal
forall (P : terms -> Prop) (n : nat) (a : terms) (s : sub_explicits),
P (env (var n) s) ->
(forall x' : sub_explicits, e_relSL _ (cons a s) x' -> P (env (var (S n)) x')) ->
forall M : terms, e_relSL _ (env (var (S n)) (cons a s)) M -> P M.
intros P n a s H H0 M H1.
cut (var (S n) = var (S n)).
2: auto.
cut (cons a s = cons a s).
2: auto.
pattern (var (S n)) at 1, (cons a s) at 1, M in |- *; apply case_SLenv;
 intros.
15: assumption.
(* app *)elim (diff_var_app (S n) a1 b1 (sym_equal H3)).
(* lambda *)elim (diff_var_lambda (S n) a1 (sym_equal H3)).
(* clos *)elim (diff_var_env (S n) a1 s1 (sym_equal H3)).
(* varshift1 *)elim (diff_shift_cons a s H2).
(* varshift2 *)elim (diff_cons_comp a s shift s1 (sym_equal H2)).
(* fvarcons *)elim (O_S n (proj_var 0 (S n) H3)).
(* fvarlift1 *)elim (diff_cons_lift a s s1 (sym_equal H2)).
(* fvarlift2 *)elim (diff_cons_comp a s (lift s1) s2 (sym_equal H2)).
(* rvarcons *)
rewrite (eq_add_S n0 n (proj_var (S n0) (S n) H3)).
rewrite (proj_cons2 a1 a s1 s H2); assumption.
(* rvarlift1 *)elim (diff_cons_lift a s s1 (sym_equal H2)).
(* rvarlift2 *)elim (diff_cons_comp a s (lift s1) s2 (sym_equal H2)).
(* id *)elim (diff_id_cons a s H2).
(* contexte gauche*)elim (case_SLvar (S n) a' H2).
(* contexte droit *)apply H0; assumption.
Save case_SL_rvarcons.

(*** (env (var (S n)) (lift s)) SL ? ***)

Goal
forall (P : terms -> Prop) (n : nat) (s : sub_explicits),
P (env (var n) (comp s shift)) ->
(forall x' : sub_explicits, e_relSL _ (lift s) x' -> P (env (var (S n)) x')) ->
forall M : terms, e_relSL _ (env (var (S n)) (lift s)) M -> P M.
intros P n s H H0 M H1.
cut (var (S n) = var (S n)).
2: auto.
cut (lift s = lift s).
2: auto.
pattern (var (S n)) at 1, (lift s) at 1, M in |- *; apply case_SLenv; intros.
15: assumption.
(* app *)elim (diff_var_app (S n) a1 b1 (sym_equal H3)).
(* lambda *)elim (diff_var_lambda (S n) a1 (sym_equal H3)).
(* clos *)elim (diff_var_env (S n) a1 s1 (sym_equal H3)).
(* varshift1 *)elim (diff_shift_lift s H2).
(* varshift2 *)elim (diff_comp_lift shift s1 s H2).
(* fvarcons *)elim (O_S n (proj_var 0 (S n) H3)).
(* fvarlift1 *)elim (O_S n (proj_var 0 (S n) H3)).
(* fvarlift2 *)elim (O_S n (proj_var 0 (S n) H3)).
(* rvarcons *)elim (diff_cons_lift a1 s1 s H2).
(* rvarlift1 *)
rewrite (eq_add_S n0 n (proj_var (S n0) (S n) H3)).
rewrite (proj_lift s1 s H2); assumption.
(* rvarlift2 *)elim (diff_comp_lift (lift s1) s2 s H2).
(* id *)elim (diff_id_lift s H2).
(* contexte gauche*)elim (case_SLvar (S n) a' H2).
(* contexte droit *)apply H0; assumption.
Save case_SL_rvarlift1.

(*** (env (var (S n)) (comp (lift s) t)) SL ? ***)

Goal
forall (P : terms -> Prop) (n : nat) (s t : sub_explicits),
P (env (var n) (comp s (comp shift t))) ->
(forall x' : sub_explicits,
 e_relSL _ (comp (lift s) t) x' -> P (env (var (S n)) x')) ->
forall M : terms, e_relSL _ (env (var (S n)) (comp (lift s) t)) M -> P M.
intros P n s t H H0 M H1.
cut (var (S n) = var (S n)).
2: auto.
cut (comp (lift s) t = comp (lift s) t).
2: auto.
pattern (var (S n)) at 1, (comp (lift s) t) at 1, M in |- *; apply case_SLenv;
 intros.
15: assumption.
(* app *)elim (diff_var_app (S n) a1 b1 (sym_equal H3)).
(* lambda *)elim (diff_var_lambda (S n) a1 (sym_equal H3)).
(* clos *)elim (diff_var_env (S n) a1 s1 (sym_equal H3)).
(* varshift1 *)elim (diff_shift_comp (lift s) t H2).
(* varshift2 *)elim (diff_shift_lift s (proj_comp1 shift (lift s) s1 t H2)).
(* fvarcons *)elim (diff_cons_comp a1 s1 (lift s) t H2).
(* fvarlift1 *)elim (diff_comp_lift (lift s) t s1 (sym_equal H2)).
(* fvarlift2 *)elim (O_S n (proj_var 0 (S n) H3)).
(* rvarcons *)elim (diff_cons_comp a1 s1 (lift s) t H2).
(* rvarlift1 *)elim (diff_comp_lift (lift s) t s1 (sym_equal H2)).
(* rvarlift2 *)
rewrite (eq_add_S n0 n (proj_var (S n0) (S n) H3)).
rewrite (proj_lift s1 s (proj_comp1 (lift s1) (lift s) s2 t H2)).
rewrite (proj_comp2 (lift s1) (lift s) s2 t H2); assumption.
(* id *)elim (diff_id_comp (lift s) t H2).
(* contexte gauche*)elim (case_SLvar (S n) a' H2).
(* contexte droit *)apply H0; assumption.
Save case_SL_rvarlift2.

(*** (comp (comp s t) u) SL ? ***)

Goal
forall (P : sub_explicits -> sub_explicits -> Prop) (s t u : sub_explicits),
P u (comp s (comp t u)) ->
P id (comp s t) ->
(forall x' : sub_explicits, e_relSL _ (comp s t) x' -> P u (comp x' u)) ->
(forall u' : sub_explicits, e_relSL _ u u' -> P u (comp (comp s t) u')) ->
forall M : sub_explicits, e_relSL _ (comp (comp s t) u) M -> P u M.
intros P s t u H H0 H1 H2 M H3.
cut (comp s t = comp s t).
2: auto.
pattern (comp s t) at 1, u, M in |- *; apply case_SLcomp; intros.
13: assumption.
(* assenv *)
rewrite (proj_comp1 s1 s s2 t H4).
rewrite (proj_comp2 s1 s s2 t H4); assumption.
(* mapenv *)elim (diff_cons_comp a s1 s t H4).
(* shiftcons *)elim (diff_shift_comp s t H4).
(* shiftlift1 *)elim (diff_shift_comp s t H4).
(* shiftlift2 *)elim (diff_shift_comp s t H4).
(* lift1 *)elim (diff_comp_lift s t s1 (sym_equal H4)).
(* lift2 *)elim (diff_comp_lift s t s1 (sym_equal H4)).
(* liftenv *)elim (diff_comp_lift s t s1 (sym_equal H4)).
(* idl *)elim (diff_id_comp s t H4).
(* idr *)
assumption.
(* contexte gauche *)
apply H1; assumption.
(* contexte droit *)
apply H2; assumption.
Save case_SL_assenv.

(*** (comp (cons a s) t) SL ? ***)

Goal
forall (P : sub_explicits -> sub_explicits -> Prop)
  (a : terms) (s t : sub_explicits),
P t (cons (env a t) (comp s t)) ->
P id (cons a s) ->
(forall x' : sub_explicits, e_relSL _ (cons a s) x' -> P t (comp x' t)) ->
(forall t' : sub_explicits, e_relSL _ t t' -> P t (comp (cons a s) t')) ->
forall M : sub_explicits, e_relSL _ (comp (cons a s) t) M -> P t M.
intros P a s t H H0 H1 H2 M H3.
cut (cons a s = cons a s).
2: auto.
pattern (cons a s) at 1, t, M in |- *; apply case_SLcomp; intros.
13: assumption.
(* assenv *)elim (diff_cons_comp a s s1 s2 (sym_equal H4)).
(* mapenv *)
rewrite (proj_cons1 a0 a s1 s H4).
rewrite (proj_cons2 a0 a s1 s H4); assumption.
(* shiftcons *)elim (diff_shift_cons a s H4).
(* shiftlift1 *)elim (diff_shift_cons a s H4).
(* shiftlift2 *)elim (diff_shift_cons a s H4).
(* lift1 *)elim (diff_cons_lift a s s1 (sym_equal H4)).
(* lift2 *)elim (diff_cons_lift a s s1 (sym_equal H4)).
(* liftenv *)elim (diff_cons_lift a s s1 (sym_equal H4)).
(* idl *)elim (diff_id_cons a s H4).
(* idr *)
assumption.
(* contexte gauche *)
apply H1; assumption.
(* contexte droit *)
apply H2; assumption.
Save case_SL_mapenv.

(*** (comp shift (cons a s)) SL ? ***)

Goal
forall (P : sub_explicits -> Prop) (a : terms) (s : sub_explicits),
P s ->
(forall x' : sub_explicits, e_relSL _ (cons a s) x' -> P (comp shift x')) ->
forall M : sub_explicits, e_relSL _ (comp shift (cons a s)) M -> P M.
intros P a s H H0 M H1.
cut (cons a s = cons a s).
2: auto.
pattern (cons a s) at 1, M in |- *; apply case_SLcomp1; intros.
6: assumption.
(* shiftcons *)
rewrite (proj_cons2 a0 a s1 s H2); assumption.
(* shiftlift1 *)elim (diff_cons_lift a s s1 (sym_equal H2)).
(* shiftlift2 *)elim (diff_cons_comp a s (lift s1) t (sym_equal H2)).
(* idl *)elim (diff_id_cons a s H2).
(* contexte gauche *)
apply H0; assumption.
Save case_SL_shiftcons.

(*** (comp shift (lift s)) SL ? ***)

Goal
forall (P : sub_explicits -> Prop) (s : sub_explicits),
P (comp s shift) ->
(forall x' : sub_explicits, e_relSL _ (lift s) x' -> P (comp shift x')) ->
forall M : sub_explicits, e_relSL _ (comp shift (lift s)) M -> P M.
intros P s H H0 M H1.
cut (lift s = lift s).
2: auto.
pattern (lift s) at 1, M in |- *; apply case_SLcomp1; intros.
6: assumption.
(* shiftcons *)elim (diff_cons_lift a s1 s H2).
(* shiftlift1 *)
rewrite (proj_lift s1 s H2); assumption.
(* shiftlift2 *)elim (diff_comp_lift (lift s1) t s H2).
(* idl *)elim (diff_id_lift s H2).
(* contexte gauche *)
apply H0; assumption.
Save case_SL_shiflift1.

(*** (comp shift (comp (lift s) t)) SL ? ***)

Goal
forall (P : sub_explicits -> Prop) (s t : sub_explicits),
P (comp s (comp shift t)) ->
(forall x' : sub_explicits,
 e_relSL _ (comp (lift s) t) x' -> P (comp shift x')) ->
forall M : sub_explicits, e_relSL _ (comp shift (comp (lift s) t)) M -> P M.
intros P s t H H0 M H1.
cut (comp (lift s) t = comp (lift s) t).
2: auto.
pattern (comp (lift s) t) at 1, M in |- *; apply case_SLcomp1; intros.
6: assumption.
(* shiftcons *)elim (diff_cons_comp a s1 (lift s) t H2).
(* shiftlift1 *)elim (diff_comp_lift (lift s) t s1 (sym_equal H2)).
(* shiftlift2 *)
rewrite (proj_lift s1 s (proj_comp1 (lift s1) (lift s) t0 t H2)).
rewrite (proj_comp2 (lift s1) (lift s) t0 t H2); assumption.
(* idl *)elim (diff_id_comp (lift s) t H2).
(* contexte gauche *)
apply H0; assumption.
Save case_SL_shiflift2.

(*** (comp (lift s) (lift t)) SL ? ***)

Goal
forall (P : sub_explicits -> Prop) (s t : sub_explicits),
P (lift (comp s t)) ->
(forall x' : sub_explicits, e_relSL _ (lift s) x' -> P (comp x' (lift t))) ->
(forall x' : sub_explicits, e_relSL _ (lift t) x' -> P (comp (lift s) x')) ->
forall M : sub_explicits, e_relSL _ (comp (lift s) (lift t)) M -> P M.
intros P s t H H0 H1 M H2.
cut (lift t = lift t).
2: auto.
pattern (lift t) at 1, M in |- *; apply case_SLcomp2 with s; intros.
7: assumption.
(* lift1 *)
rewrite (proj_lift t1 t H3); assumption.
(* lift2 *)elim (diff_comp_lift (lift t1) t2 t H3).
(* liftenv *)elim (diff_cons_lift a t1 t H3).
(* idr *)elim (diff_id_lift t H3).
(* contexte gauche *)
apply H0; assumption.
(* contexte droit *)
apply H1; assumption.
Save case_SL_lift1.

(*** (comp (lift s) (comp (lift t) u)) SL ? ***)

Goal
forall (P : sub_explicits -> Prop) (s t u : sub_explicits),
P (comp (lift (comp s t)) u) ->
(forall x' : sub_explicits,
 e_relSL _ (lift s) x' -> P (comp x' (comp (lift t) u))) ->
(forall x' : sub_explicits,
 e_relSL _ (comp (lift t) u) x' -> P (comp (lift s) x')) ->
forall M : sub_explicits,
e_relSL _ (comp (lift s) (comp (lift t) u)) M -> P M.
intros P s t u H H0 H1 M H2.
cut (comp (lift t) u = comp (lift t) u).
2: auto.
pattern (comp (lift t) u) at 1, M in |- *; apply case_SLcomp2 with s; intros.
7: assumption.
(* lift1 *)elim (diff_comp_lift (lift t) u t1 (sym_equal H3)).
(* lift2 *)
rewrite (proj_lift t1 t (proj_comp1 (lift t1) (lift t) t2 u H3)).
rewrite (proj_comp2 (lift t1) (lift t) t2 u H3); assumption.
(* liftenv *)elim (diff_cons_comp a t1 (lift t) u H3).
(* idr *)elim (diff_id_comp (lift t) u H3).
(* contexte gauche *)
apply H0; assumption.
(* contexte droit *)
apply H1; assumption.
Save case_SL_lift2.

(*** (comp (lift s) (cons a t)) SL ? ***)

Goal
forall (P : sub_explicits -> Prop) (a : terms) (s t : sub_explicits),
P (cons a (comp s t)) ->
(forall x' : sub_explicits, e_relSL _ (lift s) x' -> P (comp x' (cons a t))) ->
(forall x' : sub_explicits, e_relSL _ (cons a t) x' -> P (comp (lift s) x')) ->
forall M : sub_explicits, e_relSL _ (comp (lift s) (cons a t)) M -> P M.
intros P a s t H H0 H1 M H2.
cut (cons a t = cons a t).
2: auto.
pattern (cons a t) at 1, M in |- *; apply case_SLcomp2 with s; intros.
7: assumption.
(* lift1 *)elim (diff_cons_lift a t t1 (sym_equal H3)).
(* lift2 *)elim (diff_cons_comp a t (lift t1) t2 (sym_equal H3)).
(* liftenv *)
rewrite (proj_cons1 a0 a t1 t H3).
rewrite (proj_cons2 a0 a t1 t H3); assumption.
(* idr *)elim (diff_id_cons a t H3).
(* contexte gauche *)
apply H0; assumption.
(* contexte droit *)
apply H1; assumption.
Save case_SL_liftenv.

(*** (comp id s) SL ? ***)

Goal
forall (P : sub_explicits -> sub_explicits -> Prop) (s : sub_explicits),
P s s ->
P id id ->
(forall s' : sub_explicits, e_relSL _ s s' -> P s (comp id s')) ->
forall M : sub_explicits, e_relSL _ (comp id s) M -> P s M.
intros P s H H0 H1 M H2.
cut (id = id).
2: auto.
cut (s = s).
2: auto.
pattern id at 1, s at 1, M in |- *; apply case_SLcomp; intros.
13: assumption.
(* assenv *)elim (diff_id_comp s1 s2 (sym_equal H4)).
(* mapenv *)elim (diff_id_cons a s1 (sym_equal H4)).
(* shiftcons *)elim (diff_id_shift (sym_equal H4)).
(* shiftlift1 *)elim (diff_id_shift (sym_equal H4)).
(* shiftlift2 *)elim (diff_id_shift (sym_equal H4)).
(* lift1 *)elim (diff_id_lift s1 (sym_equal H4)).
(* lift2 *)elim (diff_id_lift s1 (sym_equal H4)).
(* liftenv *)elim (diff_id_lift s1 (sym_equal H4)).
(* idl *)
assumption.
(* idr *)
elim H3; assumption.
(* contexte gauche *)
elim (case_SLid s' H3).
(* contexte droit *)
apply H1; assumption.
Save case_SL_idl.

(*** (comp s id) SL ? ***)

Goal
forall (P : sub_explicits -> sub_explicits -> Prop) (s : sub_explicits),
P s s ->
(forall s1 s2 : sub_explicits, P (comp s1 s2) (comp s1 (comp s2 id))) ->
(forall (a : terms) (s1 : sub_explicits),
 P (cons a s1) (cons (env a id) (comp s1 id))) ->
P id id ->
(forall s' : sub_explicits, e_relSL _ s s' -> P s (comp s' id)) ->
forall M : sub_explicits, e_relSL _ (comp s id) M -> P s M.
intros P s H H0 H1 H2 H3 M H4.
cut (id = id).
2: auto.
cut (s = s).
2: auto.
pattern s at 1, id at 1, M in |- *; apply case_SLcomp; intros.
13: assumption.
(* assenv *)
elim H5; apply H0.
(* mapenv *)
elim H5; apply H1.
(* shiftcons *)elim (diff_id_cons a t1 (sym_equal H6)).
(* shiftlift1 *)elim (diff_id_lift t1 (sym_equal H6)).
(* shiftlift2 *)elim (diff_id_comp (lift t1) t2 (sym_equal H6)).
(* lift1 *)elim (diff_id_lift t1 (sym_equal H6)).
(* lift2 *)elim (diff_id_comp (lift t1) t2 (sym_equal H6)).
(* liftenv *)elim (diff_id_cons a t1 (sym_equal H6)).
(* idl *)
elim H5; assumption.
(* idr *)
assumption.
(* contexte gauche *)
apply H3; assumption.
(* contexte droit *)
elim (case_SLid t' H5).
Save case_SL_idr.

(*** (lift id ) SL ? ***)

Goal
forall P : sub_explicits -> Prop,
P id -> forall M : sub_explicits, e_relSL _ (lift id) M -> P M.
intros P H M H0.
cut (id = id).
2: auto.
pattern id at 1, M in |- *; apply case_SLlift; intros.
3: assumption.
(* liftid *)
assumption.
(* contexte *)elim (case_SLid s' H1).
Save case_SL_liftid.

(*** (env a id) SL ? ***)

Goal
forall (P : terms -> terms -> Prop) (a : terms),
P a a ->
(forall a1 b1 : terms, P (app a1 b1) (app (env a1 id) (env b1 id))) ->
(forall a1 : terms, P (lambda a1) (lambda (env a1 (lift id)))) ->
(forall (a1 : terms) (s : sub_explicits), P (env a1 s) (env a1 (comp s id))) ->
(forall a' : terms, e_relSL _ a a' -> P a (env a' id)) ->
forall M : terms, e_relSL _ (env a id) M -> P a M.
intros P a H H0 H1 H2 H3 M H4.
cut (id = id).
2: auto.
pattern a, id at 2, M in |- *; apply case_SLenv; intros.
15: assumption.
(* app *)
apply H0.
(* lambda *)
apply H1.
(* clos *)
apply H2.
(* varshift1 *)elim (diff_id_shift H5).
(* varshift2 *)elim (diff_id_comp shift s1 H5).
(* fvarcons *)elim (diff_id_cons a1 s1 H5).
(* fvarlift1 *)elim (diff_id_lift s1 H5).
(* fvarlift2 *)elim (diff_id_comp (lift s1) s2 H5).
(* rvarcons *)elim (diff_id_cons a1 s1 H5).
(* rvarlift1 *)elim (diff_id_lift s1 H5).
(* rvarlift2 *)elim (diff_id_comp (lift s1) s2 H5).
(* id *)
assumption.
(* contexte gauche*)
apply H3; assumption.
(* contexte droit *)
elim (case_SLid s' H5).
Save case_SL_reg_id.