(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith Omega List Permutation.

Require Import utils ill_form ill_rules.

Set Implicit Arguments.

Section Relational_phase_semantics.

  (** We define a sound relational phase sematics for ILL
      based on stable closures *)

  Variable M : Type.

  Implicit Types A B C : M -> Type.

  Variable cl : (M -> Type) -> (M -> Type).

  Hypothesis cl_increase   : forall A, A ⊆ cl A.
  Hypothesis cl_monotone   : forall A B, A ⊆ B -> cl A ⊆ cl B.
  Hypothesis cl_idempotent : forall A, cl (cl A) ⊆ cl A.

  Proposition cl_prop A B : A ⊆ cl B ≡ cl A ⊆ cl B.
  Proof.
    split; intros H x Hx.
    apply cl_idempotent; revert Hx; apply cl_monotone; auto.
    apply H, cl_increase; auto.
  Qed.

  Definition cl_inc A B := fst (cl_prop A B).
  Definition inc_cl A B := snd (cl_prop A B).

  Fact cl_eq1 A B : A ≃ B -> cl A ≃ cl B.
  Proof. intros []; split; apply cl_monotone; auto. Qed.

  Hint Resolve cl_inc cl_eq1.

  Notation closed := (fun x : M -> Type => cl x ⊆ x).

  Fact cl_closed A B : closed B -> A ⊆ B -> cl A ⊆ B.
  Proof.
    intros H1 H2.
    apply inc1_trans with (2 := H1), cl_inc,
          inc1_trans with (1 := H2), cl_increase.
  Qed.

  Fact cap_closed A B : closed A -> closed B -> closed (A ∩ B).
  Proof.
    intros HA HB x Hx; split; [ apply HA | apply HB ]; revert Hx; apply cl_monotone; red; tauto.
  Qed.

  Hint Resolve cap_closed.

  (* this is a relational/non-deterministic monoid *)

  Variable Compose : M -> M -> M -> Type.

  (* Composition lifted to predicates *)

  Inductive Composes (A B : M -> Type) : M -> Type :=
    In_composes : forall a b c, A a -> B b -> Compose a b c -> Composes A B c.

  (* ⊆ ≃ ∩ ∪ ∘ *)

  Infix "∘" := Composes (at level 50, no associativity).

  Proposition composes_monotone A A' B B' : A ⊆ A' -> B ⊆ B' ->  A ∘ B ⊆ A' ∘ B'.
  Proof. intros ? ? _ [ ? ? ? ? ? H ]; apply In_composes with (3 := H); auto. Qed.

  Hint Resolve composes_monotone.

  (* Stability is the important axiom in phase semantics *)

  Definition cl_stability   := forall A B, cl A ∘ cl B ⊆ cl (A ∘ B).
  Definition cl_stability_l := (forall A B, cl A ∘    B ⊆ cl (A ∘ B)).
  Definition cl_stability_r := forall A B,    A ∘ cl B ⊆ cl (A ∘ B).

  Proposition cl_stable_imp_stable_l : cl_stability -> cl_stability_l.
  Proof.
    intros H ? ? x Hx.
    apply H; revert x Hx.
    apply composes_monotone; auto.
  Qed.

  Proposition cl_stable_imp_stable_r : cl_stability -> cl_stability_r.
  Proof.
    intros H ? ? x Hx.
    apply H; revert x Hx.
    apply composes_monotone; auto.
  Qed.

  Proposition cl_stable_lr_imp_stable : cl_stability_l -> cl_stability_r -> cl_stability.
  Proof.
    intros H1 H2 A B x Hx.
    apply cl_idempotent.
    generalize (H1 _ _ _ Hx).
    apply cl_monotone, H2.
  Qed.

  Hint Resolve cl_stable_imp_stable_l cl_stable_imp_stable_r cl_stable_lr_imp_stable.

  Variable e : M.

  Notation sg := (@eq _).

  Notation cl_neutrality_1  := (forall a, cl (sg e ∘ sg a) a).
  Notation cl_neutrality_2  := (forall a, sg e ∘ sg a ⊆ cl (sg a)).
  Notation cl_neutrality_3  := (forall a, cl (sg a ∘ sg e) a).
  Notation cl_neutrality_4  := (forall a, sg a ∘ sg e ⊆ cl (sg a)).
  Notation cl_commutativity := (forall a b, sg a ∘ sg b ⊆ cl (sg b ∘ sg a)).
  Notation cl_associativity_1 := (forall a b c, sg a ∘ (sg b ∘ sg c) ⊆ cl ((sg a ∘ sg b) ∘ sg c)).
  Notation cl_associativity_2 := (forall a b c, (sg a ∘ sg b) ∘ sg c ⊆ cl (sg a ∘ (sg b ∘ sg c))).

  Hypothesis cl_commute : cl_commutativity.

  Proposition composes_commute_1 A B : A ∘ B ⊆ cl (B ∘ A).
  Proof.
    intros _ [ a b c Ha Hb Hc ].
    apply cl_monotone with (sg b ∘ sg a).
    apply composes_monotone; apply sg_inc1; auto.
    apply cl_commute.
    constructor 1 with (3 := Hc); auto.
  Qed.

  Hint Resolve composes_commute_1.

  Proposition composes_commute A B : cl (A∘B) ≃ cl (B∘A).
  Proof.
    split; intros x Hx; apply cl_idempotent; revert Hx; apply cl_monotone; auto.
  Qed.

  Section commute_stability.

    Proposition cl_stable_l_imp_stable_r : cl_stability_l -> cl_stability_r.
    Proof.
      intros Hl A B x Hx.
      apply cl_idempotent.
      apply cl_monotone with (cl B ∘ A).
      apply inc1_trans with (2 := fst (composes_commute _ _)); auto.
      apply composes_commute_1; auto.
    Qed.

    Proposition cl_stable_r_imp_stable_l : cl_stability_r -> cl_stability_l.
    Proof.
      intros Hl A B.
      apply inc1_trans with (2 := fst (composes_commute _ _)); auto.
      apply inc1_trans with (1 := @composes_commute_1 _ _); auto.
    Qed.

    Hint Resolve cl_stable_l_imp_stable_r.

    Proposition cl_stable_l_imp_stable : cl_stability_l -> cl_stability.
    Proof. auto. Qed.

  End commute_stability.

  (* ⊆ ≃ ∩ ∪ ∘ *)

  Hypothesis cl_stable_l : cl_stability_l.
  Hypothesis cl_stable_r : cl_stability_r.

  Proposition cl_stable : cl_stability.
  Proof. auto. Qed.

  Hint Resolve cl_stable.

  (* ⊆ ≃ ∩ ∪ ∘ ⊸ *)

  Proposition composes_congruent_l_1 A B C : A ⊆ cl B -> C ∘ A ⊆ cl (C ∘ B).
  Proof.
    intros ?.
    apply inc1_trans with (B := cl (C ∘ cl B)); auto.
    apply inc_cl, cl_monotone, composes_monotone; auto.
  Qed.

  Hint Resolve composes_congruent_l_1.

  Proposition composes_congruent_l A B C : cl A ≃ cl B -> cl (C ∘ A) ≃ cl (C ∘ B).
  Proof.
    intros [H1 H2].
    generalize (inc_cl H1) (inc_cl H2); intros H3 H4.
    split; apply cl_inc;
    apply inc1_trans with (2 := @cl_stable_r _ _), composes_monotone; auto.
  Qed.

  Proposition composes_congruent_r_1 A B C : A ⊆ cl B -> A ∘ C ⊆ cl (B ∘ C).
  Proof.
    intros ?.
    apply inc1_trans with (B := cl (cl B ∘ C)); auto.
    apply inc_cl, cl_monotone, composes_monotone; auto.
  Qed.

  Hint Resolve composes_congruent_r_1.

  Proposition composes_congruent_r A B C : cl A ≃ cl B -> cl (A ∘ C) ≃ cl (B ∘ C).
  Proof.
    intros [H1 H2].
    generalize (inc_cl H1) (inc_cl H2); intros H3 H4.
    split; apply cl_inc;
    apply inc1_trans with (2 := @cl_stable_l _ _), composes_monotone; auto.
  Qed.

  Hint Resolve composes_congruent_l composes_congruent_r.

  Proposition composes_congruent A B C D :
               cl A ≃ cl B
            -> cl C ≃ cl D
            -> cl (A ∘ C) ≃ cl (B ∘ D).
  Proof. intros; apply eq1_trans with (cl (B ∘ C)); auto. Qed.

  Section commute_neutrality.

    Proposition cl_neutrality_1_imp_3 : cl_neutrality_1 -> cl_neutrality_3.
    Proof.
      intros H x; generalize (H x).
      apply composes_commute.
    Qed.

    Proposition cl_neutrality_2_imp_4 : cl_neutrality_2 -> cl_neutrality_4.
    Proof.
      intros H x y Hxy.
      specialize (H x).
      apply cl_idempotent.
      apply cl_monotone in H.
      apply H.
      revert Hxy; apply cl_commute.
    Qed.

  End commute_neutrality.

  Hypothesis cl_neutral_1 : cl_neutrality_1.
  Hypothesis cl_neutral_2 : cl_neutrality_2.
  Hypothesis cl_neutral_3 : cl_neutrality_3.
  Hypothesis cl_neutral_4 : cl_neutrality_4.

  Section commute_associativity.

    Proposition cl_associative_1_imp_2 : cl_associativity_1 -> cl_associativity_2.
    Proof.
      intros H1 a b c.
      apply inc1_trans with (2 := fst (composes_commute _ _)).
      apply inc1_trans with (cl ((sg c ∘ sg b) ∘ sg a)).
      + apply inc1_trans with (2 := cl_inc (H1 _ _ _)).
        apply inc1_trans with (2 := fst (composes_commute _ _)).
        apply inc_cl, composes_congruent; auto.
      + apply composes_congruent; auto.
    Qed.

  End commute_associativity.

  Hypothesis cl_associative_1 : cl_associativity_1.
  Hypothesis cl_associative_2 : cl_associativity_2.

  (* ⊆ ≃ ∩ ∪ ∘ ⊸ *)

  Definition Magicwand_l A B k := A ∘ sg k ⊆ B.
  Infix "⊸" := Magicwand_l (at level 51, right associativity).

  Proposition magicwand_l_spec A B C : B ∘ A ⊆ C ≡ A ⊆ B ⊸ C.
  Proof.
    split; intros H x Hx.
    intros y Hy; apply H; revert Hy; apply composes_monotone; auto.
    apply sg_inc1; auto.
    destruct Hx as [ a b x Ha Hb Hx ].
    apply (H _ Hb).
    constructor 1 with a b; auto.
  Qed.

  Definition magicwand_l_adj_1 A B C := fst (magicwand_l_spec A B C).
  Definition magicwand_l_adj_2 A B C := snd (magicwand_l_spec A B C).

  Proposition magicwand_l_monotone A A' B B' : A ⊆ A' -> B ⊆ B' -> A' ⊸ B ⊆ A ⊸ B'.
  Proof.
    intros ? HB; apply magicwand_l_adj_1, inc1_trans with (2 := HB).
    intros _ [? ? ? Ha Hb Hc]; apply Hb, In_composes with (3 := Hc); auto.
  Qed.

  Hint Resolve magicwand_l_monotone.

  Proposition cl_magicwand_l_1 X Y : cl (X ⊸ cl Y) ⊆ X ⊸ cl Y.
  Proof.
    apply magicwand_l_adj_1.
    apply inc1_trans with (B := cl (X ∘ (X ⊸ cl Y))); auto.
    apply cl_inc; apply magicwand_l_spec; auto.
  Qed.

  Proposition cl_magicwand_l_2 X Y : cl X ⊸ Y ⊆ X ⊸ Y.
  Proof. apply magicwand_l_monotone; auto. Qed.

  Hint Immediate cl_magicwand_l_1 cl_magicwand_l_2.

  Proposition cl_magicwand_l_3 X Y : X ⊸ cl Y ⊆ cl X ⊸ cl Y.
  Proof.
    intros c Hc y.
    apply inc1_trans with (B := cl (X ∘ sg c)); auto.
  Qed.

  Hint Immediate cl_magicwand_l_3.

  Proposition closed_magicwand_l X Y : closed Y -> closed (X ⊸ Y).
  Proof.
    simpl; intros ?.
    apply inc1_trans with (B := cl (X ⊸ cl Y)); auto.
    apply inc1_trans with (B := X ⊸ cl Y); auto.
  Qed.

  Hint Resolve closed_magicwand_l.

  Proposition magicwand_l_eq_1 X Y : X ⊸ cl Y ≃ cl X ⊸ cl Y.
  Proof. split; auto. Qed.

  Proposition magicwand_l_eq_2 X Y : cl (X ⊸ cl Y) ≃ X ⊸ cl Y.
  Proof. split; auto. Qed.

  Proposition magicwand_l_eq_3 X Y : cl (X ⊸ cl Y) ≃ cl X ⊸ cl Y.
  Proof.
    apply eq1_trans with (X ⊸ cl Y); auto.
  Qed.

  Hint Resolve magicwand_l_eq_1 magicwand_l_eq_2 magicwand_l_eq_3.

  Definition Magicwand_r B A k := sg k ∘ A ⊆ B.
  Infix "⟜" := Magicwand_r (at level 52, left associativity).

  Proposition magicwand_r_spec A B C : A ∘ B ⊆ C ≡ A ⊆ C ⟜ B.
  Proof.
    split; intros H x Hx.
    intros y Hy; apply H; revert Hy; apply composes_monotone; auto.
    apply sg_inc1; auto.
    destruct Hx as [ a b x Ha Hb Hx ].
    apply (H _ Ha).
    constructor 1 with a b; auto.
  Qed.

  Definition magicwand_r_adj_1 A B C := fst (magicwand_r_spec A B C).
  Definition magicwand_r_adj_2 A B C := snd (magicwand_r_spec A B C).

  Proposition magicwand_r_monotone A A' B B' : A ⊆ A' -> B ⊆ B' -> B ⟜ A' ⊆ B' ⟜ A.
  Proof.
    intros ? HB; apply magicwand_r_adj_1, inc1_trans with (2 := HB).
    intros _ [? ? ? Ha Hb Hc]; apply Ha, In_composes with (3 := Hc); auto.
  Qed.

  Hint Resolve magicwand_r_monotone.

  Proposition cl_magicwand_r_1 X Y : cl (cl Y ⟜ X) ⊆ cl Y ⟜ cl X.
  Proof.
    apply magicwand_r_adj_1.
    apply inc1_trans with (B := cl ((cl Y ⟜ X) ∘ X)); auto.
    apply cl_inc; apply magicwand_r_spec; auto.
  Qed.

  Proposition cl_magicwand_r_2 X Y : Y ⟜ cl X ⊆ Y ⟜ X.
  Proof. apply magicwand_r_monotone; auto. Qed.

  Hint Immediate cl_magicwand_r_1 cl_magicwand_r_2.

  Proposition cl_magicwand_r_3 X Y : cl Y ⟜ X ⊆ cl Y ⟜ cl X.
  Proof.
    intros c Hc y.
    apply inc1_trans with (B := cl (sg c ∘ X)); auto.
  Qed.

  Hint Immediate cl_magicwand_r_3.

  Proposition closed_magicwand_r X Y : closed Y -> closed (Y ⟜ X).
  Proof.
    simpl; intros ?.
    apply inc1_trans with (B := cl (cl Y ⟜ X)); auto.
    apply inc1_trans with (1 := @cl_magicwand_r_1 _ _); auto.
  Qed.

  Hint Resolve closed_magicwand_r.

  Proposition magicwand_r_eq_1 X Y : cl Y ⟜ X ≃ cl Y ⟜ cl X.
  Proof. split; auto. Qed.

  Proposition magicwand_r_eq_2 X Y : cl (cl Y ⟜ X) ≃ cl Y ⟜ X.
  Proof. split; auto. Qed.

  Proposition magicwand_r_eq_3 X Y : cl (cl Y ⟜ X) ≃ cl Y ⟜ cl X.
  Proof. apply eq1_trans with (cl Y ⟜ X); auto. Qed.

  Hint Resolve magicwand_r_eq_1 magicwand_r_eq_2 magicwand_r_eq_3.

  (* ⊆ ≃ ∩ ∪ ∘ ⊸ *)

  Proposition cl_equiv_2 X Y : cl (cl X ∘ Y) ≃ cl (X ∘ Y).
  Proof.
    split.
    apply cl_inc; auto.
    apply cl_monotone, composes_monotone; auto.
  Qed.

  Proposition cl_equiv_3 X Y : cl (X ∘ cl Y) ≃ cl (X ∘ Y).
  Proof.
    split.
    apply cl_inc; auto.
    apply cl_monotone, composes_monotone; auto.
  Qed.

  Proposition cl_equiv_4 X Y : cl (cl X ∘ cl Y) ≃ cl (X ∘ Y).
  Proof.
    split.
    apply cl_inc; auto.
    apply cl_monotone, composes_monotone; auto.
  Qed.

  Hint Immediate cl_equiv_2 cl_equiv_3 cl_equiv_4.

  Proposition composes_associative_1 A B C : A ∘ (B ∘ C) ⊆ cl ((A ∘ B) ∘ C).
  Proof.
    intros _ [a _ k Ha [b c y Hb Hc Hy] Hk].
    generalize (@cl_associative_1 a b c k); intros H.
    spec all in H.
    apply In_composes with (3 := Hk); auto.
    apply In_composes with (3 := Hy); auto.
    revert H.
    apply cl_monotone.
    repeat apply composes_monotone; apply sg_inc1; auto.
  Qed.

  Hint Immediate composes_associative_1.

  Proposition composes_associative_2 A B C : (A ∘ B) ∘ C ⊆ cl (A ∘ (B ∘ C)).
  Proof.
    intros _ [_ c k [a b y Ha Hb Hy] Hc Hk].
    generalize (@cl_associative_2 a b c k); intros H.
    spec all in H.
    apply In_composes with (3 := Hk); auto.
    apply In_composes with (3 := Hy); auto.
    revert H.
    apply cl_monotone.
    repeat apply composes_monotone; apply sg_inc1; auto.
  Qed.

  Hint Immediate composes_associative_2.

  Proposition composes_associative A B C : cl (A ∘ (B ∘ C)) ≃ cl ((A ∘ B) ∘ C).
  Proof. split; auto; apply cl_inc; auto. Qed.

  Hint Immediate composes_associative.

  Proposition composes_neutral_l_1 A : A ⊆ cl (sg e ∘ A).
  Proof.
    intros a Ha.
    generalize (cl_neutral_1 a).
    apply cl_monotone, composes_monotone; auto.
    apply sg_inc1; auto.
  Qed.

  Proposition composes_neutral_l_2 A : sg e ∘ A ⊆ cl A.
  Proof.
    intros _ [y a x [] Ha Hx].
    generalize (@cl_neutral_2 a x); intros H.
    spec all in H.
    constructor 1 with e a; auto.
    revert H; apply cl_monotone, sg_inc1; auto.
  Qed.

  Hint Resolve composes_neutral_l_1 composes_neutral_l_2.

  Proposition composes_neutral_l A : cl (sg e ∘ A) ≃ cl A.
  Proof. split; apply cl_inc; auto. Qed.

  Proposition composes_neutral_r_1 A : A ⊆ cl (A ∘ sg e).
  Proof.
    intros a Ha.
    generalize (cl_neutral_3 a).
    apply cl_monotone, composes_monotone; auto.
    apply sg_inc1; auto.
  Qed.

  Proposition composes_neutral_r_2 A : A ∘ sg e ⊆ cl A.
  Proof.
    intros _ [a y x Ha [] Hx].
    generalize (@cl_neutral_4 a x); intros H.
    spec all in H.
    constructor 1 with a e; auto.
    revert H; apply cl_monotone, sg_inc1; auto.
  Qed.

  Hint Resolve composes_neutral_r_1 composes_neutral_r_2.

  Proposition composes_neutral_r A : cl (A ∘ sg e) ≃ cl A.
  Proof. split; apply cl_inc; auto. Qed.

  (* ⊆ ≃ ∩ ∪ ∘ ⊸ ⊛ *)

  Notation "x 'glb' y " := (x ∩ y) (at level 50, no associativity).
  Notation "x 'lub' y" := (cl (x ∪ y)) (at level 50, no associativity).

  Proposition closed_glb A B : closed A -> closed B -> closed (A glb B).
  Proof.
    simpl; intros HA HB x Hx; split;
      [ apply HA | apply HB ]; revert x Hx;
      apply cl_monotone; red; tauto.
  Qed.

  Proposition lub_out A B C : closed C -> A ⊆ C -> B ⊆ C -> A lub B ⊆ C.
  Proof.
    simpl.
    intros H1 H2 H3.
    apply inc1_trans with (2 := H1), cl_monotone.
    intros ? [ ]; auto.
  Qed.

  Proposition glb_in A B C : C ⊆ A -> C ⊆ B -> C ⊆ A glb B.
  Proof. simpl; split; auto. Qed.

  Proposition closed_lub A B : closed (A lub B).        Proof. simpl; apply cl_idempotent. Qed.
  Proposition glb_out_l A B  : A glb B ⊆ A .            Proof. simpl; red; tauto. Qed.
  Proposition glb_out_r A B  : A glb B ⊆ B.             Proof. simpl; red; tauto. Qed.
  Proposition lub_in_l A B   : A ⊆ A lub B.             Proof. apply inc1_trans with (2 := cl_increase _); red; tauto. Qed.
  Proposition lub_in_r A B   : B ⊆ A lub B.             Proof. apply inc1_trans with (2 := cl_increase _); red; tauto. Qed.

  Proposition glb_comm A B : A glb B ≃ B glb A.
  Proof. split; apply glb_in; red; tauto. Qed.

  (* ⊆ ≃ ∩ ∪ ∘ ⊸ ⊛ *)

  Notation "x ⊛ y " := (cl (x ∘ y)) (at level 59).

  Proposition closed_times A B : closed (A⊛B).
  Proof. simpl; apply cl_idempotent. Qed.

  Proposition times_monotone A A' B B' : A ⊆ A' -> B ⊆ B' -> A⊛B ⊆ A'⊛B'.
  Proof. simpl; intros ? ?; apply cl_monotone, composes_monotone; auto. Qed.

  Notation top := (fun _ : M => True).
  Notation bot := (cl (fun _ => False)).
  Notation unit := (cl (sg e)).

  Proposition closed_top     : closed top.         Proof. simpl; intros; red; auto. Qed.
  Proposition closed_bot     : closed bot.         Proof. simpl; apply cl_idempotent. Qed.
  Proposition closed_unit    : closed unit.        Proof. simpl; apply cl_idempotent. Qed.
  Proposition top_greatest A : A ⊆ top.            Proof. simpl; red; tauto. Qed.

  Hint Resolve closed_glb closed_top.

  Fact closed_mglb ll : (forall x, In_t x ll -> closed x) -> closed (fold_right (fun x y => x ∩ y) top ll).
  Proof.
    revert ll; apply Forall_type_rect; simpl; auto; red; auto.
  Qed.

  Hint Resolve closed_mglb.

  Proposition bot_least A : closed A -> bot ⊆ A.
  Proof. intro H; apply inc1_trans with (2 := H), cl_monotone; red; tauto. Qed.

  Proposition unit_neutral_l_1 A : closed A -> unit ⊛ A ⊆ A.
  Proof.
    intros H; apply inc1_trans with (2 := H).
    apply cl_inc.
    apply inc1_trans with (1 := @cl_stable_l _ _).
    apply cl_inc; auto.
  Qed.

  Proposition unit_neutral_l_2 A : A ⊆ unit ⊛ A.
  Proof.
    intros a Ha; simpl.
    generalize (composes_neutral_l_1 _ _ Ha).
    apply cl_monotone, composes_monotone; auto.
  Qed.

  Proposition unit_neutral_l A : closed A -> unit ⊛ A ≃ A.
  Proof.
    intros H; split.
    revert H; apply unit_neutral_l_1.
    apply unit_neutral_l_2.
  Qed.

  Proposition unit_neutral_r_1 A : closed A -> A ⊛ unit ⊆ A.
  Proof.
    intros H; apply inc1_trans with (2 := H).
    apply cl_inc.
    apply inc1_trans with (1 := @cl_stable_r _ _).
    apply cl_inc; auto.
  Qed.

  Proposition unit_neutral_r_2 A : A ⊆ A ⊛ unit.
  Proof.
    intros a Ha; simpl.
    generalize (composes_neutral_r_1 _ _ Ha).
    apply cl_monotone, composes_monotone; auto.
  Qed.

  Proposition unit_neutral_r A : closed A -> A ⊛ unit ≃ A.
  Proof.
    intros H; split.
    revert H; apply unit_neutral_r_1.
    apply unit_neutral_r_2.
  Qed.

  (* ⊆ ≃ ∩ ∪ ∘ ⊸ ⊛ *)

  Hint Resolve unit_neutral_l unit_neutral_r.

  Proposition times_commute_1 A B : A⊛B ⊆ B⊛A.
  Proof. simpl; apply cl_inc, composes_commute_1. Qed.

  Hint Resolve times_commute_1.

  Proposition times_commute A B : A⊛B ≃ B⊛A.
  Proof. split; auto. Qed.

  Proposition times_associative A B C : (A⊛B)⊛C ≃ A⊛(B⊛C).
  Proof.
    apply eq1_sym, eq1_trans with (1 := cl_equiv_3 _ _ ).
    apply eq1_sym, eq1_trans with (1 := cl_equiv_2 _ _ ).
    apply eq1_sym, composes_associative.
  Qed.

  Proposition times_associative_1 A B C : (A⊛B)⊛C ⊆ A⊛(B⊛C).     Proof. apply times_associative. Qed.
  Proposition times_associative_2 A B C : A⊛(B⊛C) ⊆ (A⊛B)⊛C.     Proof. apply times_associative. Qed.

  Hint Resolve times_associative_1 times_associative_2.

  Proposition times_congruence A A' B B' : A ≃ A' -> B ≃ B' -> A⊛B ≃ A'⊛B'.
  Proof. intros; apply composes_congruent; auto. Qed.

  (* ⊆ ≃ ∩ ∪ ∘ ⊸ ⊛ *)

  Proposition adjunction_l_1 A B C : closed C -> B ⊛ A ⊆ C -> A ⊆ B ⊸ C.
  Proof. intros ? H; apply magicwand_l_adj_1, inc1_trans with (2 := H); auto. Qed.

  Proposition adjunction_l_2 A B C : closed C -> A ⊆ B ⊸ C -> B ⊛ A ⊆ C.
  Proof. intros H ?; apply inc1_trans with (2 := H), cl_monotone, magicwand_l_adj_2; auto. Qed.

  Hint Resolve times_congruence adjunction_l_1 (* adjunction_2 *).

  Proposition adjunction_l A B C : closed C -> (B ⊛ A ⊆ C ≡ A ⊆ B ⊸ C).
  Proof.
    split; [ apply adjunction_l_1 | apply adjunction_l_2 ]; auto.
  Qed.

  Proposition adjunction_r_1 A B C : closed C -> A ⊛ B ⊆ C -> A ⊆ C ⟜ B.
  Proof. intros ? H; apply magicwand_r_adj_1, inc1_trans with (2 := H); auto. Qed.

  Proposition adjunction_r_2 A B C : closed C -> A ⊆ C ⟜ B -> A ⊛ B ⊆ C.
  Proof. intros H ?; apply inc1_trans with (2 := H), cl_monotone, magicwand_r_adj_2; auto. Qed.

  Hint Resolve adjunction_r_1 (* adjunction_2 *).

  Proposition adjunction_r A B C : closed C -> (A ⊛ B ⊆ C ≡ A ⊆ C ⟜ B).
  Proof.
    split; [ apply adjunction_r_1 | apply adjunction_r_2 ]; auto.
  Qed.

  Proposition times_bot_distrib_l A : bot ⊛ A ⊆ bot.
  Proof.
    apply adjunction_r_2; auto.
    apply bot_least; auto.
  Qed.

  Proposition times_bot_distrib_r A : A ⊛ bot ⊆ bot.
  Proof.
    apply adjunction_l_2; auto.
    apply bot_least; auto.
  Qed.

  Hint Immediate times_bot_distrib_l times_bot_distrib_r.

  Proposition times_lub_distrib_l A B C : (A lub B) ⊛ C ⊆ (A ⊛ C) lub (B ⊛ C).
  Proof.
    apply adjunction_r, lub_out; auto;
    apply adjunction_r; auto; intros ? ?; apply cl_increase; auto.
  Qed.

  Proposition times_lub_distrib_r A B C : C ⊛ (A lub B) ⊆ (C ⊛ A) lub (C ⊛ B).
  Proof.
    apply adjunction_l, lub_out; auto;
    apply adjunction_l; auto; intros ? ?; apply cl_increase; auto.
  Qed.

  (* J := { x | x ∈ unit /\ x ∈ x ⊛ x } with unit = cl e and x ⊛ x = cl (x∘x) *)

  Let J x := (cl (sg e) x * (cl (sg x ∘ sg x)) x)%type.

  Let In_J : forall x, cl (sg e) x -> (cl (sg x ∘ sg x)) x -> J x.
  Proof. split; auto. Qed.

  Let J_inv x : J x -> unit x * cl (sg x ∘ sg x) x.
  Proof. auto. Qed.

  Proposition J_inc_unit : J ⊆ unit.
  Proof. induction 1; trivial. Qed.

  Variable K : M -> Type.

  Notation sub_monoid_hyp_1 := ((cl K) e).
  Notation sub_monoid_hyp_2 := (K ∘ K ⊆ K).
  Notation sub_J_hyp := (K ⊆ J).

  Hypothesis sub_monoid_1 : sub_monoid_hyp_1.
  Hypothesis sub_monoid_2 : sub_monoid_hyp_2.
  Hypothesis sub_J : sub_J_hyp.

  Proposition K_inc_unit : K ⊆ unit.
  Proof. apply inc1_trans with J; trivial; apply J_inc_unit. Qed.

  Proposition K_compose A B : (K ∩ A) ∘ (K ∩ B) ⊆ K ∩ (A ∘ B).
  Proof.
    intros x Hx.
    induction Hx as [ a b c [ ] [ ] Hc ]; split.
    + apply sub_monoid_2; constructor 1 with a b; auto.
    + constructor 1 with a b; auto.
  Qed.

  Let bang A := cl (K∩A).

  Notation "❗ A" := (bang A) (at level 40, no associativity).

  Fact store_inc_unit A : ❗ A ⊆ unit.
  Proof.
    apply inc1_trans with (cl K).
    + apply cl_monotone; red; tauto.
    + apply cl_inc, K_inc_unit.
  Qed.

  Hint Resolve store_inc_unit.

  Proposition closed_store A : closed (❗A).
  Proof. simpl; apply cl_idempotent. Qed.

  Proposition store_dec A : closed A -> ❗A ⊆ A.
  Proof.
    intros HA; simpl.
    apply inc1_trans with (cl A); trivial.
    apply cl_monotone.
    apply glb_out_r.
  Qed.

  Fact store_monotone A B : A ⊆ B -> ❗A ⊆ ❗B.
  Proof.
    intro; apply cl_monotone.
    intros ? []; split; auto.
  Qed.

  Hint Resolve store_monotone.

  Fact store_congruence A B : A ≃ B -> ❗A ≃ ❗B.
  Proof. intros []; split; auto. Qed.

  Proposition store_der A B : closed B -> ❗A ⊆ B -> ❗A ⊆ ❗B.
  Proof.
    unfold bang.
    intros H1 H2; apply cl_monotone; intros x []; split; auto.
    apply H2, cl_increase; auto.
  Qed.

  Proposition store_unit_1 : unit ⊆ ❗top.
  Proof.
    apply cl_inc.
    intros ? []; apply cl_monotone with K; auto; red; auto.
  Qed.

  Hint Resolve J_inc_unit.

  Proposition store_unit_2 : ❗top ⊆ unit.
  Proof.
    apply cl_inc; trivial.
    apply inc1_trans with J; auto.
    intros ? []; auto.
  Qed.

  Hint Resolve store_unit_1 store_unit_2.

  Proposition store_unit : unit ≃ ❗top.
  Proof. split; auto. Qed.

  Proposition store_comp A B : closed A -> closed B -> ❗A ⊛ ❗B ≃ ❗(A∩B).
  Proof.
    intros HA HB; split.
    + apply inc1_trans with (cl ((K glb A) ∘ (K glb B))).
      * apply cl_inc; trivial; apply cl_stable.
      * apply cl_monotone.
        intros x [ a b c [ H1 H2 ] [ H3 H4 ] Hc ].
        assert (H5 : unit a). { apply K_inc_unit; auto. }
        assert (H6 : unit b). { apply K_inc_unit; auto. }
        split; [ | split ].
        - apply sub_monoid_2; constructor 1 with a b; auto.
        - apply unit_neutral_r_1; auto; apply cl_increase.
          constructor 1 with a b; auto.
        - apply unit_neutral_l_1; auto; apply cl_increase.
          constructor 1 with a b; auto.
    + apply cl_inc; trivial.
      intros x (H1 & H2 & H3).
      apply cl_monotone with (sg x ∘ sg x).
      2: { apply sub_J in H1; destruct H1; trivial. }
      intros d [ a b ? ? Hab ]; subst a b; constructor 1 with x x; auto;
        apply cl_increase; auto.
  Qed.

  Let ltimes := fold_right (fun x y => x ⊛ y) unit.
  Let lcap := fold_right (fun x y => x∩y) top.

  Proposition ltimes_store ll :
           (forall x, In_t x ll -> closed x)
        -> ltimes (map bang  ll)
         ≃ ❗(lcap ll).
  Proof.
    unfold ltimes, lcap.
    revert ll.
    apply Forall_type_rect; simpl; auto.
    intros A ll H1 H2 IH2.
    apply eq1_trans with (❗A ⊛ ❗(fold_right (fun x y => x ∩ y) top ll)).
    * apply times_congruence; auto.
    * apply eq1_trans with (❗(A ∩ fold_right (fun x y => x ∩ y) top ll)); auto.
      apply store_comp; auto.
  Qed.

  Proposition store_compose_idem A : closed A -> ❗A ⊆ ❗A⊛❗A.
  Proof.
    intros HA.
    apply inc1_trans with (❗(A∩A)).
    + apply store_der.
      * apply closed_glb; trivial.
      * apply inc1_trans with A.
        - apply store_dec; trivial.
        - red; tauto.
    + apply (snd (store_comp HA HA)).
  Qed.

  Reserved Notation "'⟦' A '⟧'" (at level 49).
  Reserved Notation "'⟬߭' A '⟭'" (at level 49).

  Variable (v : ill_vars -> M -> Type) (Hv : forall x, cl (v x) ⊆ v x).

  Fixpoint Form_sem f :=
    match f with
      | ⟘             => bot
      | ⟙             => top
      | 𝝐              => unit
      | £ x    => v x
      | a -o b => ⟦a⟧ ⊸ ⟦b⟧
      | b o- a => ⟦b⟧ ⟜ ⟦a⟧
      | a ⊗ b  => ⟦a⟧ ⊛ ⟦b⟧
      | a ⊕ b  => ⟦a⟧ lub ⟦b⟧
      | a & b  => ⟦a⟧ glb ⟦b⟧
      | !a     => ❗⟦a⟧
    end
  where "⟦ a ⟧" := (Form_sem a).

  Fact closed_Form_sem f : cl (⟦f⟧) ⊆ ⟦f⟧.
  Proof. induction f as [ | [] | | [] ]; simpl; unfold bang; auto; red; auto. Qed.

  Definition list_Form_sem ll := fold_right (fun x y => x⊛y) unit (map Form_sem ll).

  Notation "⟬߭  ll ⟭" := (list_Form_sem ll).

  Fact list_Form_sem_nil : ⟬߭nil⟭ = unit.
  Proof. auto. Qed.

  Fact list_Form_sem_cons f ll : ⟬߭f::ll⟭  = ⟦f⟧ ⊛ ⟬߭ll⟭.
  Proof. auto. Qed.

  Fact closed_list_Form_sem ll : cl (⟬߭ll⟭) ⊆ ⟬߭ll⟭.
  Proof. unfold list_Form_sem; induction ll; simpl; auto. Qed.

  Hint Resolve closed_Form_sem closed_list_Form_sem.

  Fact list_Form_sem_app ll mm : ⟬߭ll++mm⟭ ≃ ⟬߭ll⟭ ⊛⟬߭mm⟭.
  Proof.
    induction ll as [ | f ll IHll ]; simpl app; auto.
    + apply eq1_sym, unit_neutral_l; auto.
    + apply eq1_sym, eq1_trans with (1 := @times_associative _ _ _), eq1_sym.
      apply times_congruence; auto.
  Qed.

  Fact list_Form_sem_congr_l ll mm pp : ⟬߭mm⟭ ≃ ⟬߭pp⟭  -> ⟬߭ll++mm⟭ ≃ ⟬߭ll++pp⟭.
  Proof.
    intros H.
    do 2 apply eq1_trans with (1 := list_Form_sem_app _ _), eq1_sym.
    apply times_congruence; auto.
  Qed.

  Fact list_Form_sem_congr_r ll mm pp : ⟬߭mm⟭ ≃ ⟬߭pp⟭  -> ⟬߭mm++ll⟭ ≃ ⟬߭pp++ll⟭.
  Proof.
    intros H.
    do 2 apply eq1_trans with (1 := list_Form_sem_app _ _), eq1_sym.
    apply times_congruence; auto.
  Qed.

  Fact list_Form_sem_mono_l ll mm pp : ⟬߭mm⟭ ⊆ ⟬߭pp⟭  -> ⟬߭ll++mm⟭ ⊆ ⟬߭ll++pp⟭.
  Proof.
    intros H.
    apply inc1_trans with (⟬߭ll⟭ ⊛⟬߭mm⟭); [ apply list_Form_sem_app | ].
    apply inc1_trans with (⟬߭ll⟭ ⊛⟬߭pp⟭); [ | apply list_Form_sem_app ].
    apply times_monotone; auto.
  Qed.

  Fact list_Form_sem_mono_r ll mm pp : ⟬߭mm⟭ ⊆ ⟬߭pp⟭  -> ⟬߭mm++ll⟭ ⊆ ⟬߭pp++ll⟭.
  Proof.
    intros H.
    apply inc1_trans with (⟬߭mm⟭ ⊛⟬߭ll⟭); [ apply list_Form_sem_app | ].
    apply inc1_trans with (⟬߭pp⟭ ⊛⟬߭ll⟭); [ | apply list_Form_sem_app ].
    apply times_monotone; auto.
  Qed.

  Fact list_Form_sem_bang ll : ⟬߭‼ll⟭ ≃ ❗ (lcap (map Form_sem ll)).
  Proof.
    unfold list_Form_sem.
    assert (forall x, In_t x (map Form_sem ll) -> closed x) as Hll.
    { induction ll as [ | y ll IHll ].
      + intros _ [].
      + intros x [ ? | Hx ]; subst; auto. }
    apply eq1_trans with (2 := ltimes_store _ Hll).
    rewrite map_map.
    apply equal_eq1; clear Hll.
    induction ll as [ | a ll IHll ]; simpl; auto.
    rewrite IHll; auto.
  Qed.

  (* All the rules of the ILL sequent calculus (including cut) are closed
     under relational phase semantics, hence we deduce the following
     soundness theorem *)

  Section soundness.

    Variable s1 s2 : bool.

    Notation "l '⊢' x" := (ill_proof s1 s2 l x) (at level 70, no associativity).

    Fact ill_ax_sound a : ⟬߭a::nil⟭  ⊆ ⟦a⟧.
    Proof. intro; apply unit_neutral_r; auto. Qed.

    Fact ill_cut_sound Γ ϴ Δ a b : ⟬߭Γ⟭ ⊆ ⟦a⟧ -> ⟬߭Δ++a::ϴ⟭ ⊆ ⟦b⟧ -> ⟬߭Δ++Γ++ϴ⟭ ⊆ ⟦b⟧.
    Proof.
      intros H1 H2.
      apply inc1_trans with (2 := H2).
      apply list_Form_sem_mono_l.
      apply inc1_trans with (1 := fst (list_Form_sem_app _ _)).
      rewrite list_Form_sem_cons; apply times_monotone; auto.
    Qed.

    (* Beware that ill_co_swap_sound assumes commutativity
        while ill_nc_swap_sound does not *)

    Fact ill_nc_swap_sound Γ Δ a b c : ⟬߭Γ++!a::!b::Δ⟭ ⊆ ⟦c⟧ -> ⟬߭Γ++!b::!a::Δ⟭ ⊆ ⟦c⟧.
    Proof.
      intros H x Hx; apply H; revert x Hx.
      apply list_Form_sem_congr_l.
      change (!a::!b::Δ) with (‼(a::b::nil)++Δ).
      change (!b::!a::Δ) with (‼(b::a::nil)++Δ).
      apply list_Form_sem_congr_r.
      do 2 apply eq1_trans with (1 := list_Form_sem_bang _), eq1_sym.
      apply store_congruence.
      simpl; split; red; tauto.
    Qed.

    Fact ill_co_swap_sound Γ Δ a b c : ⟬߭Γ++a::b::Δ⟭ ⊆ ⟦c⟧ -> ⟬߭Γ++b::a::Δ⟭ ⊆ ⟦c⟧.
    Proof.
      intros H x Hx; apply H; revert x Hx.
      apply list_Form_sem_congr_l.
      change (a::b::Δ) with ((a::b::nil)++Δ).
      change (b::a::Δ) with ((b::a::nil)++Δ).
      apply list_Form_sem_congr_r.
      repeat rewrite list_Form_sem_cons.
      repeat rewrite list_Form_sem_nil.
      apply eq1_trans with (1 := times_commute _ _).
      apply times_congruence.
      + apply unit_neutral_r; auto.
      + apply eq1_sym, unit_neutral_r; auto.
    Qed.

    Fact ill_nc_perm_sound Γ Δ a : s1 = false -> Γ ~[s1] Δ -> ⟬߭Γ⟭ ⊆ ⟦a⟧ -> ⟬߭Δ⟭ ⊆ ⟦a⟧.
    Proof.
      intros H1 H2; revert H2 a; subst; simpl.
      induction 1 as [ | a Ga De H1 IH1 | | ] ; intros c; auto.
      + repeat rewrite list_Form_sem_cons.
        intros H; apply adjunction_l_2; auto.
        apply IH1 with (a := a -o c); simpl.
        apply adjunction_l_1; auto.
      + apply ill_nc_swap_sound with (Γ := nil).
    Qed.

    Fact ill_co_perm_sound Γ Δ a : s1 = true -> Γ ~[s1] Δ -> ⟬߭Γ⟭ ⊆ ⟦a⟧ -> ⟬߭Δ⟭ ⊆ ⟦a⟧.
    Proof.
      intros H1 H2; revert H2 a; subst; simpl.
      induction 1 as [ | a Ga De H1 IH1 | | ] ; intros c; auto.
      + repeat rewrite list_Form_sem_cons.
        intros H; apply adjunction_l_2; auto.
        apply IH1 with (a := a -o c); simpl.
        apply adjunction_l_1; auto.
      + apply ill_co_swap_sound with (Γ := nil).
    Qed.

    Fact ill_limp_l_sound Γ ϴ Δ a b c :  ⟬߭Γ⟭ ⊆ ⟦a⟧ -> ⟬߭ϴ++b::Δ⟭ ⊆ ⟦c⟧ -> ⟬߭ϴ++Γ++a -o b::Δ⟭ ⊆ ⟦c⟧.
    Proof.
      intros H1 H2 x Hx; apply H2; revert x Hx.
      apply list_Form_sem_mono_l.
      change (b::Δ) with ((b::nil)++Δ).
      replace (Γ++a -o b::Δ) with ((Γ++a -o b::nil)++Δ).
      2: rewrite app_ass; auto.
      apply list_Form_sem_mono_r.
      apply inc1_trans with (1 := fst (list_Form_sem_app _ _)).
      apply inc1_trans with (⟬߭Γ⟭ ⊛ (⟦ a ⟧ ⊸ ⟦ b ⟧)).
      * apply times_congruence; auto.
        rewrite list_Form_sem_cons, list_Form_sem_nil.
        apply eq1_sym, unit_neutral_r; auto.
      * apply inc1_trans with (⟦b⟧).
        apply adjunction_l; auto.
        rewrite list_Form_sem_cons, list_Form_sem_nil.
        apply unit_neutral_r; auto.
    Qed.

    Fact ill_rimp_l_sound Γ ϴ Δ a b c :  ⟬߭Γ⟭ ⊆ ⟦a⟧ -> ⟬߭ϴ++b::Δ⟭ ⊆ ⟦c⟧ -> ⟬߭ϴ++b o- a::Γ++Δ⟭ ⊆ ⟦c⟧.
    Proof.
      intros H1 H2 x Hx; apply H2; revert x Hx.
      apply list_Form_sem_mono_l.
      change (b::Δ) with ((b::nil)++Δ).
      change (b o- a::Γ++Δ) with ((b o- a::Γ)++Δ).
      apply list_Form_sem_mono_r.
      do 2 rewrite list_Form_sem_cons.
      rewrite list_Form_sem_nil.
      apply inc1_trans with (⟦ b ⟧).
      2: apply unit_neutral_r; auto.
      apply adjunction_r; auto.
      apply magicwand_r_monotone; auto.
    Qed.

    Fact ill_limp_r_sound Γ a b : ⟬߭a::Γ⟭ ⊆ ⟦b⟧ -> ⟬߭Γ⟭ ⊆ ⟦a⟧ ⊸ ⟦b⟧.
    Proof. intro; apply adjunction_l; auto. Qed.

    Fact ill_rimp_r_sound Γ a b : ⟬߭Γ++a::nil⟭ ⊆ ⟦b⟧ -> ⟬߭Γ⟭ ⊆ ⟦b⟧ ⟜ ⟦a⟧.
    Proof.
      intros H.
      apply adjunction_r; auto.
      apply inc1_trans with (2 := H).
      apply inc1_trans with (2 := snd (list_Form_sem_app _ _)).
      apply times_monotone; auto.
      rewrite list_Form_sem_cons, list_Form_sem_nil.
      apply unit_neutral_r; auto.
    Qed.

    Fact ill_with_l1_sound Γ Δ a b c : ⟬߭Γ++a::Δ⟭ ⊆ ⟦c⟧ -> ⟬߭Γ++a ﹠ b::Δ⟭ ⊆ ⟦c⟧.
    Proof.
      intros H.
      apply inc1_trans with (2 := H).
      apply list_Form_sem_mono_l, times_monotone; auto.
      simpl; red; tauto.
    Qed.

    Fact ill_with_l2_sound Γ Δ a b c : ⟬߭Γ++b::Δ⟭ ⊆ ⟦c⟧ -> ⟬߭Γ++a ﹠ b::Δ⟭ ⊆ ⟦c⟧.
    Proof.
      intros H.
      apply inc1_trans with (2 := H).
      apply list_Form_sem_mono_l, times_monotone; auto.
      simpl; red; tauto.
    Qed.

    Fact ill_with_r_sound Γ a b : ⟬߭Γ⟭ ⊆ ⟦a⟧ -> ⟬߭Γ⟭ ⊆ ⟦b⟧ -> ⟬߭Γ⟭ ⊆ ⟦a﹠b⟧.
    Proof. intros; simpl; red; auto. Qed.

    Fact ill_bang_l_sound Γ Δ a b : ⟬߭Γ++a::Δ⟭ ⊆ ⟦b⟧ -> ⟬߭Γ++!a::Δ⟭ ⊆ ⟦b⟧.
    Proof.
      intros H.
      apply inc1_trans with (2 := H).
      apply list_Form_sem_mono_l, times_monotone; auto.
      apply store_dec; auto.
    Qed.

    Fact ill_bang_r_sound Γ a : ⟬߭‼Γ⟭ ⊆ ⟦ a ⟧ -> ⟬߭‼Γ⟭ ⊆ ❗⟦a⟧.
    Proof.
      intros H x Hx.
      apply list_Form_sem_bang in Hx; revert x Hx.
      apply store_der; auto.
      intros x Hx; apply H, list_Form_sem_bang; auto.
    Qed.

    Fact ill_weak_sound Γ Δ a b : ⟬߭Γ++Δ⟭ ⊆ ⟦b⟧ -> ⟬߭Γ++!a::Δ⟭ ⊆ ⟦b⟧.
    Proof.
      intros H.
      apply inc1_trans with (2 := H), list_Form_sem_mono_l.
      apply inc1_trans with (unit ⊛ ⟬߭Δ⟭).
      * apply times_monotone; simpl; auto.
      * apply unit_neutral_l; auto.
    Qed.

    Fact ill_cntr_sound Γ Δ a b : ⟬߭Γ++!a::!a::Δ⟭ ⊆ ⟦b⟧ -> ⟬߭Γ++!a::Δ⟭ ⊆ ⟦b⟧.
    Proof.
      intros H.
      apply inc1_trans with (2 := H), list_Form_sem_mono_l.
      change (!a::Δ) with (‼(a::nil)++Δ) at 1.
      change (!a::!a::Δ) with (‼(a::a::nil)++Δ).
      apply list_Form_sem_mono_r.
      apply inc1_trans with (1 := fst (list_Form_sem_bang _)).
      apply inc1_trans with (2 := snd (list_Form_sem_bang _)).
      apply store_monotone; simpl; red; tauto.
    Qed.

    Fact ill_times_l_sound Γ Δ a b c : ⟬߭Γ++a::b::Δ⟭ ⊆ ⟦c⟧ -> ⟬߭Γ++a⊗b::Δ⟭ ⊆ ⟦c⟧.
    Proof.
      intros H.
      apply inc1_trans with (2 := H), list_Form_sem_mono_l.
      do 3 rewrite list_Form_sem_cons.
      apply times_associative.
    Qed.

    Fact ill_times_r_sound Γ Δ a b : ⟬߭Γ⟭ ⊆ ⟦a⟧ -> ⟬߭Δ⟭ ⊆ ⟦b⟧ -> ⟬߭Γ++Δ⟭ ⊆ ⟦a⟧⊛⟦b⟧.
    Proof.
      intros ? ?.
      apply inc1_trans with (1 := fst (list_Form_sem_app _ _)).
      apply times_monotone; auto.
    Qed.

    Fact ill_plus_l_sound Γ Δ a b c : ⟬߭Γ++a::Δ⟭ ⊆ ⟦c⟧ -> ⟬߭Γ++b::Δ⟭ ⊆ ⟦c⟧ -> ⟬߭Γ++a⊕b::Δ⟭ ⊆ ⟦c⟧.
    Proof.
      intros H1 H2.
      apply inc1_trans with ((⟬߭Γ⟭ ⊛(⟦a⟧⊛⟬߭Δ⟭))lub (⟬߭Γ⟭ ⊛(⟦b⟧⊛⟬߭Δ⟭))).
      2: { apply lub_out; auto.
           * apply inc1_trans with (2 := H1).
             apply inc1_trans with (2 := snd (list_Form_sem_app _ _)).
             apply times_monotone; auto.
           * apply inc1_trans with (2 := H2).
             apply inc1_trans with (2 := snd (list_Form_sem_app _ _)).
             apply times_monotone; auto. }
      apply inc1_trans with (1 := fst (list_Form_sem_app _ _)).
      rewrite list_Form_sem_cons.
      apply inc1_trans with (2 := @times_lub_distrib_r _ _ _).
      apply times_monotone; auto.
      apply times_lub_distrib_l.
    Qed.

    Fact ill_plus_r1_sound Γ a b : ⟬߭Γ⟭ ⊆ ⟦a⟧ -> ⟬߭Γ⟭ ⊆ ⟦a⊕b⟧.
    Proof. intros ? ? ?; simpl; apply cl_increase; auto. Qed.

    Fact ill_plus_r2_sound Γ a b : ⟬߭Γ⟭ ⊆ ⟦b⟧ -> ⟬߭Γ⟭ ⊆ ⟦a⊕b⟧.
    Proof. intros ? ? ?; simpl; apply cl_increase; auto. Qed.

    Fact ill_bot_l_sound Γ Δ a : ⟬߭Γ++⟘::Δ⟭ ⊆ ⟦a⟧.
    Proof.
      intros x Hx.
      apply list_Form_sem_app in Hx.
      rewrite list_Form_sem_cons in Hx.
      apply bot_least; auto.
      apply times_bot_distrib_r with (A := ⟬߭Γ⟭) .
      revert x Hx; apply times_monotone; auto.
    Qed.

    Fact ill_top_r_sound Γ : ⟬߭Γ⟭ ⊆ ⟦⟙⟧.
    Proof. simpl; red; auto. Qed.

    Fact ill_unit_l_sound Γ Δ a : ⟬߭Γ++Δ⟭ ⊆ ⟦a⟧ -> ⟬߭Γ++𝝐::Δ⟭ ⊆ ⟦a⟧.
    Proof.
      intros H.
      apply inc1_trans with (2 := H), list_Form_sem_mono_l.
      apply unit_neutral_l; auto.
    Qed.

    Fact ill_unit_r_sound : ⟬߭nil⟭ ⊆ ⟦𝝐⟧.
    Proof. simpl; red; auto. Qed.

  End soundness.

  Notation "l '⊢' x [ s1 , s2 ]" := (ill_proof s1 s2 l x) (at level 70, no associativity).

  Hint Resolve   ill_ax_sound
                 ill_limp_l_sound ill_limp_r_sound ill_rimp_l_sound ill_rimp_r_sound
                 ill_with_l1_sound ill_with_l2_sound ill_with_r_sound
                 ill_bang_l_sound ill_bang_r_sound ill_weak_sound ill_cntr_sound
                 ill_times_l_sound ill_times_r_sound
                 ill_plus_l_sound ill_plus_r1_sound ill_plus_r2_sound
                 ill_bot_l_sound ill_top_r_sound
                 ill_unit_l_sound ill_unit_r_sound.

  Section ill_nc_soundness.

    (* Don't know with auto fails in the four last cases *)

    Let ill_soundness_rec s1 s2 Γ a : Γ ⊢ a [s1,s2] -> s1 = false -> ⟬߭Γ⟭  ⊆ ⟦a⟧.
    Proof.
      induction 1; intros E; auto; try discriminate.
      + apply ill_cut_sound with A; auto.
      + apply ill_nc_perm_sound with (1 := E) (Γ := Γ); auto.
      + apply ill_limp_r_sound; auto.
      + apply ill_rimp_r_sound; auto.
      + apply ill_bang_r_sound; auto.
      + apply ill_times_r_sound; auto.
    Qed.

    Theorem ill_nc_soundness cut Γ a : Γ ⊢ a [false,cut] -> ⟬߭Γ⟭  ⊆ ⟦a⟧.
    Proof.
      intros H; apply ill_soundness_rec with (1 := H); trivial.
    Qed.

  End ill_nc_soundness.

  Section ill_comm_soundness.

    (* Don't know with auto fails in the four last cases *)

    Let ill_soundness_rec s1 s2 Γ a : Γ ⊢ a [s1,s2] -> s1 = true -> ⟬߭Γ⟭  ⊆ ⟦a⟧.
    Proof.
      induction 1; intros E; auto; try discriminate.
      + apply ill_cut_sound with A; auto.
      + apply ill_co_perm_sound with (1 := E) (Γ := Γ); auto.
      + apply ill_limp_r_sound; auto.
      + apply ill_rimp_r_sound; auto.
      + apply ill_bang_r_sound; auto.
      + apply ill_times_r_sound; auto.
    Qed.

    Theorem ill_comm_soundness cut Γ a : Γ ⊢ a [true,cut] -> ⟬߭Γ⟭  ⊆ ⟦a⟧.
    Proof.
      intros H; apply ill_soundness_rec with (1 := H); trivial.
    Qed.

  End ill_comm_soundness.

End Relational_phase_semantics.

Local Infix "∘" := (@Composes _ _) (at level 50, no associativity).

Check ill_comm_soundness.
Check ill_nc_soundness.


Require Import little_w_string parser ZArith List String.
Require Import Lia.
Open Scope Z_scope.
Import AB A D L.
Open Scope a_scope.

Definition le_list :=
  fun l => match l with n1::n2::nil => n1 <= n2 | _ => False end.

Definition pp :=
   fun l => match l with n1::n2::nil => 2*n1=n2*(n2+1) | _ => False end.

Definition ex_m := (("le", le_list)::("pp",pp)::nil).

Example ex1 : forall r2 n g, 0<= n ->
  exec (("x", 0)::("y", 0)::("n", n)::nil)
   (parse_instr''
       "while x < n do [le(x,n) /\ pp(y,x)] x:=x+1;y:=x+y done") r2 ->
   2*(r2@g)"y" = (r2@g)"n"*((r2@g)"n"+1).
Proof.
intros r2 n g Hn Hex.
 change (i_a ex_m (r2@g) (parse_assert' "pp(y,n)")).
 unfold parse_instr'' in Hex.
 apply vcg_sound with (2:= Hex);[clear Hn Hex g n r2| idtac].

parse_it.
Import syntax.
  unfold ex_m, pp, le_list;  compute_vcg; expand_semantics.
intros g; generalize (g "x")(g "y")(g "n"); intros x y n; clear.
list_conj.
intros [Hnlt [Hxlen Heq']];  assert (x=n) by lia; subst x; auto.
intros [Hxltn [_ Heq']];
 split;[lia | rewrite Zmult_plus_distr_r; rewrite Heq'; ring].
Show.
parse_it; unfold ex_m, le_list, pp; compute_vcg; expand_semantics; simpl.
Show.
auto with zarith.
Qed.


Require Import Coq.omega.Omega.
Set Implicit Arguments.

Require Import Coq.Structures.OrderedType.

Module W_as_MOT <: MiniOrderedType.

  Require Import Bedrock.Memory.

  Definition t := W.

  Require Import Bedrock.Word.

  Definition eq := @eq t.

  Local Open Scope nat.

  Definition lt (x y : t) := wordToNat x < wordToNat y.

  Lemma eq_refl : forall x : t, eq x x.
    unfold eq; eauto.
  Qed.

  Lemma eq_sym : forall x y : t, eq x y -> eq y x.
    unfold eq; eauto.
  Qed.

  Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
    unfold eq; intuition.
    congruence.
  Qed.

  Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
    unfold lt; intros; omega.
  Qed.

  Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
    unfold lt; unfold eq; intuition.
    subst.
    omega.
  Qed.

  Require Import Platform.Cito.WordFacts.

  Definition compare : forall x y : t, Compare lt eq x y.
    unfold lt; unfold eq.
    intros.
    destruct (Compare_dec.lt_eq_lt_dec (wordToNat x) (wordToNat y)).
    destruct s.
    econstructor 1; eauto.
    econstructor 2; eauto.
    eapply wordToNat_eq_eq; eauto.
    econstructor 3; eauto.
  Defined.

End W_as_MOT.

Module W_as_OT := MOT_to_OT W_as_MOT.
Require Import Coq.Structures.OrdersAlt.
Module W_as_OT_new := Update_OT W_as_OT.
Require Import Coq.Structures.Equalities.
Module W_as_UDT := Make_UDT W_as_OT.


Require Import CT.Category.
Require Import CT.Functor.
Require Import CT.Instance.Functor.FaithfulFunctor.
Require Import CT.Instance.Functor.FullFunctor.

(** * Fully Faithful Functors

A "fully faithful" functor is one that is both full and faithful.

We represent this simply as a pair of proofs of fullness and faithfulness.
*)
Section FullyFaithfulFunctor.
  Context {A B : Category}.
  Variable (F : Functor A B).

  Definition FullyFaithfulFunctor :=
    (FullFunctor F, FaithfulFunctor F).
End FullyFaithfulFunctor.


(* -*- coding: utf-8 -*- *)
(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(** Binary Integers (Pierre Crégut, CNET, Lannion, France) *)

Require Import BinPos.
Require Import BinInt.
Require Import Arith_base.
Require Import Decidable.
Require Import Zcompare.

Open Local Scope Z_scope.

Implicit Types x y z : Z.

(*********************************************************)
(** Properties of the order relations on binary integers *)

(** * Trichotomy *)

Theorem Ztrichotomy_inf : forall n m:Z, {n < m} + {n = m} + {n > m}.
Proof.
  unfold Zgt, Zlt in |- *; intros m n; assert (H := refl_equal (m ?= n)).
  set (x := m ?= n) in H at 2 |- *.
  destruct x;
    [ left; right; rewrite Zcompare_Eq_eq with (1 := H) | left; left | right ];
    reflexivity.
Qed.

Theorem Ztrichotomy : forall n m:Z, n < m \/ n = m \/ n > m.
Proof.
  intros m n; destruct (Ztrichotomy_inf m n) as [[Hlt| Heq]| Hgt];
    [ left | right; left | right; right ]; assumption.
Qed.

(**********************************************************************)
(** * Decidability of equality and order on Z *)

Theorem dec_eq : forall n m:Z, decidable (n = m).
Proof.
  intros x y; unfold decidable in |- *; elim (Zcompare_Eq_iff_eq x y);
    intros H1 H2; elim (Dcompare (x ?= y));
      [ tauto
	| intros H3; right; unfold not in |- *; intros H4; elim H3; rewrite (H2 H4);
	  intros H5; discriminate H5 ].
Qed.

Theorem dec_Zne : forall n m:Z, decidable (Zne n m).
Proof.
  intros x y; unfold decidable, Zne in |- *; elim (Zcompare_Eq_iff_eq x y).
  intros H1 H2; elim (Dcompare (x ?= y));
    [ right; rewrite H1; auto
      | left; unfold not in |- *; intro; absurd ((x ?= y) = Eq);
	[ elim H; intros HR; rewrite HR; discriminate | auto ] ].
Qed.

Theorem dec_Zle : forall n m:Z, decidable (n <= m).
Proof.
  intros x y; unfold decidable, Zle in |- *; elim (x ?= y);
    [ left; discriminate
      | left; discriminate
      | right; unfold not in |- *; intros H; apply H; trivial with arith ].
Qed.

Theorem dec_Zgt : forall n m:Z, decidable (n > m).
Proof.
  intros x y; unfold decidable, Zgt in |- *; elim (x ?= y);
    [ right; discriminate | right; discriminate | auto with arith ].
Qed.

Theorem dec_Zge : forall n m:Z, decidable (n >= m).
Proof.
  intros x y; unfold decidable, Zge in |- *; elim (x ?= y);
    [ left; discriminate
      | right; unfold not in |- *; intros H; apply H; trivial with arith
      | left; discriminate ].
Qed.

Theorem dec_Zlt : forall n m:Z, decidable (n < m).
Proof.
  intros x y; unfold decidable, Zlt in |- *; elim (x ?= y);
    [ right; discriminate | auto with arith | right; discriminate ].
Qed.

Theorem not_Zeq : forall n m:Z, n <> m -> n < m \/ m < n.
Proof.
  intros x y; elim (Dcompare (x ?= y));
    [ intros H1 H2; absurd (x = y);
      [ assumption | elim (Zcompare_Eq_iff_eq x y); auto with arith ]
      | unfold Zlt in |- *; intros H; elim H; intros H1;
	[ auto with arith
	  | right; elim (Zcompare_Gt_Lt_antisym x y); auto with arith ] ].
Qed.

(** * Relating strict and large orders *)

Lemma Zgt_lt : forall n m:Z, n > m -> m < n.
Proof.
  unfold Zgt, Zlt in |- *; intros m n H; elim (Zcompare_Gt_Lt_antisym m n);
    auto with arith.
Qed.

Lemma Zlt_gt : forall n m:Z, n < m -> m > n.
Proof.
  unfold Zgt, Zlt in |- *; intros m n H; elim (Zcompare_Gt_Lt_antisym n m);
    auto with arith.
Qed.

Lemma Zge_le : forall n m:Z, n >= m -> m <= n.
Proof.
  intros m n; change (~ m < n -> ~ n > m) in |- *; unfold not in |- *;
    intros H1 H2; apply H1; apply Zgt_lt; assumption.
Qed.

Lemma Zle_ge : forall n m:Z, n <= m -> m >= n.
Proof.
  intros m n; change (~ m > n -> ~ n < m) in |- *; unfold not in |- *;
    intros H1 H2; apply H1; apply Zlt_gt; assumption.
Qed.

Lemma Zle_not_gt : forall n m:Z, n <= m -> ~ n > m.
Proof.
  trivial.
Qed.

Lemma Zgt_not_le : forall n m:Z, n > m -> ~ n <= m.
Proof.
  intros n m H1 H2; apply H2; assumption.
Qed.

Lemma Zle_not_lt : forall n m:Z, n <= m -> ~ m < n.
Proof.
  intros n m H1 H2.
  assert (H3 := Zlt_gt _ _ H2).
  apply Zle_not_gt with n m; assumption.
Qed.

Lemma Zlt_not_le : forall n m:Z, n < m -> ~ m <= n.
Proof.
  intros n m H1 H2.
  apply Zle_not_lt with m n; assumption.
Qed.

Lemma Znot_ge_lt : forall n m:Z, ~ n >= m -> n < m.
Proof.
  unfold Zge, Zlt in |- *; intros x y H; apply dec_not_not;
    [ exact (dec_Zlt x y) | assumption ].
Qed.

Lemma Znot_lt_ge : forall n m:Z, ~ n < m -> n >= m.
Proof.
  unfold Zlt, Zge in |- *; auto with arith.
Qed.

Lemma Znot_gt_le : forall n m:Z, ~ n > m -> n <= m.
Proof.
  trivial.
Qed.

Lemma Znot_le_gt : forall n m:Z, ~ n <= m -> n > m.
Proof.
  unfold Zle, Zgt in |- *; intros x y H; apply dec_not_not;
    [ exact (dec_Zgt x y) | assumption ].
Qed.

Lemma Zge_iff_le : forall n m:Z, n >= m <-> m <= n.
Proof.
  intros x y; intros. split. intro. apply Zge_le. assumption.
  intro. apply Zle_ge. assumption.
Qed.

Lemma Zgt_iff_lt : forall n m:Z, n > m <-> m < n.
Proof.
  intros x y. split. intro. apply Zgt_lt. assumption.
  intro. apply Zlt_gt. assumption.
Qed.

(** * Equivalence and order properties *)

(** Reflexivity *)

Lemma Zle_refl : forall n:Z, n <= n.
Proof.
  intros n; unfold Zle in |- *; rewrite (Zcompare_refl n); discriminate.
Qed.

Lemma Zeq_le : forall n m:Z, n = m -> n <= m.
Proof.
  intros; rewrite H; apply Zle_refl.
Qed.

Hint Resolve Zle_refl: zarith.

(** Antisymmetry *)

Lemma Zle_antisym : forall n m:Z, n <= m -> m <= n -> n = m.
Proof.
  intros n m H1 H2; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]].
  absurd (m > n); [ apply Zle_not_gt | apply Zlt_gt ]; assumption.
  assumption.
  absurd (n > m); [ apply Zle_not_gt | idtac ]; assumption.
Qed.

(** Asymmetry *)

Lemma Zgt_asym : forall n m:Z, n > m -> ~ m > n.
Proof.
  unfold Zgt in |- *; intros n m H; elim (Zcompare_Gt_Lt_antisym n m);
    intros H1 H2; rewrite H1; [ discriminate | assumption ].
Qed.

Lemma Zlt_asym : forall n m:Z, n < m -> ~ m < n.
Proof.
  intros n m H H1; assert (H2 : m > n). apply Zlt_gt; assumption.
  assert (H3 : n > m). apply Zlt_gt; assumption.
  apply Zgt_asym with m n; assumption.
Qed.

(** Irreflexivity *)

Lemma Zgt_irrefl : forall n:Z, ~ n > n.
Proof.
  intros n H; apply (Zgt_asym n n H H).
Qed.

Lemma Zlt_irrefl : forall n:Z, ~ n < n.
Proof.
  intros n H; apply (Zlt_asym n n H H).
Qed.

Lemma Zlt_not_eq : forall n m:Z, n < m -> n <> m.
Proof.
  unfold not in |- *; intros x y H H0.
  rewrite H0 in H.
  apply (Zlt_irrefl _ H).
Qed.

(** Large = strict or equal *)

Lemma Zlt_le_weak : forall n m:Z, n < m -> n <= m.
Proof.
  intros n m Hlt; apply Znot_gt_le; apply Zgt_asym; apply Zlt_gt; assumption.
Qed.

Lemma Zle_lt_or_eq : forall n m:Z, n <= m -> n < m \/ n = m.
Proof.
  intros n m H; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]];
    [ left; assumption
      | right; assumption
      | absurd (n > m); [ apply Zle_not_gt | idtac ]; assumption ].
Qed.

Lemma Zle_lt_or_eq_iff : forall n m, n <= m <-> n < m \/ n = m.
Proof.
  unfold Zle, Zlt. intros.
  generalize (Zcompare_Eq_iff_eq n m).
  destruct (n ?= m); intuition; discriminate.
Qed.

(** Dichotomy *)

Lemma Zle_or_lt : forall n m:Z, n <= m \/ m < n.
Proof.
  intros n m; destruct (Ztrichotomy n m) as [Hlt| [Heq| Hgt]];
    [ left; apply Znot_gt_le; intro Hgt; assert (Hgt' := Zlt_gt _ _ Hlt);
      apply Zgt_asym with m n; assumption
      | left; rewrite Heq; apply Zle_refl
      | right; apply Zgt_lt; assumption ].
Qed.

(** Transitivity of strict orders *)

Lemma Zgt_trans : forall n m p:Z, n > m -> m > p -> n > p.
Proof.
  exact Zcompare_Gt_trans.
Qed.

Lemma Zlt_trans : forall n m p:Z, n < m -> m < p -> n < p.
Proof.
  exact Zcompare_Lt_trans.
Qed.

(** Mixed transitivity *)

Lemma Zle_gt_trans : forall n m p:Z, m <= n -> m > p -> n > p.
Proof.
  intros n m p H1 H2; destruct (Zle_lt_or_eq m n H1) as [Hlt| Heq];
    [ apply Zgt_trans with m; [ apply Zlt_gt; assumption | assumption ]
      | rewrite <- Heq; assumption ].
Qed.

Lemma Zgt_le_trans : forall n m p:Z, n > m -> p <= m -> n > p.
Proof.
  intros n m p H1 H2; destruct (Zle_lt_or_eq p m H2) as [Hlt| Heq];
    [ apply Zgt_trans with m; [ assumption | apply Zlt_gt; assumption ]
      | rewrite Heq; assumption ].
Qed.

Lemma Zlt_le_trans : forall n m p:Z, n < m -> m <= p -> n < p.
  intros n m p H1 H2; apply Zgt_lt; apply Zle_gt_trans with (m := m);
    [ assumption | apply Zlt_gt; assumption ].
Qed.

Lemma Zle_lt_trans : forall n m p:Z, n <= m -> m < p -> n < p.
Proof.
  intros n m p H1 H2; apply Zgt_lt; apply Zgt_le_trans with (m := m);
    [ apply Zlt_gt; assumption | assumption ].
Qed.

(** Transitivity of large orders *)

Lemma Zle_trans : forall n m p:Z, n <= m -> m <= p -> n <= p.
Proof.
  intros n m p H1 H2; apply Znot_gt_le.
  intro Hgt; apply Zle_not_gt with n m. assumption.
  exact (Zgt_le_trans n p m Hgt H2).
Qed.

Lemma Zge_trans : forall n m p:Z, n >= m -> m >= p -> n >= p.
Proof.
  intros n m p H1 H2.
  apply Zle_ge.
  apply Zle_trans with m; apply Zge_le; trivial.
Qed.

Hint Resolve Zle_trans: zarith.

(** * Compatibility of order and operations on Z *)

(** ** Successor *)

(** Compatibility of successor wrt to order *)

Lemma Zsucc_le_compat : forall n m:Z, m <= n -> Zsucc m <= Zsucc n.
Proof.
  unfold Zle, not in |- *; intros m n H1 H2; apply H1;
    rewrite <- (Zcompare_plus_compat n m 1); do 2 rewrite (Zplus_comm 1);
      exact H2.
Qed.

Lemma Zsucc_gt_compat : forall n m:Z, m > n -> Zsucc m > Zsucc n.
Proof.
  unfold Zgt in |- *; intros n m H; rewrite Zcompare_succ_compat;
    auto with arith.
Qed.

Lemma Zsucc_lt_compat : forall n m:Z, n < m -> Zsucc n < Zsucc m.
Proof.
  intros n m H; apply Zgt_lt; apply Zsucc_gt_compat; apply Zlt_gt; assumption.
Qed.

Hint Resolve Zsucc_le_compat: zarith.

(** Simplification of successor wrt to order *)

Lemma Zsucc_gt_reg : forall n m:Z, Zsucc m > Zsucc n -> m > n.
Proof.
  unfold Zsucc, Zgt in |- *; intros n p;
    do 2 rewrite (fun m:Z => Zplus_comm m 1);
      rewrite (Zcompare_plus_compat p n 1); trivial with arith.
Qed.

Lemma Zsucc_le_reg : forall n m:Z, Zsucc m <= Zsucc n -> m <= n.
Proof.
  unfold Zle, not in |- *; intros m n H1 H2; apply H1; unfold Zsucc in |- *;
    do 2 rewrite <- (Zplus_comm 1); rewrite (Zcompare_plus_compat n m 1);
      assumption.
Qed.

Lemma Zsucc_lt_reg : forall n m:Z, Zsucc n < Zsucc m -> n < m.
Proof.
  intros n m H; apply Zgt_lt; apply Zsucc_gt_reg; apply Zlt_gt; assumption.
Qed.

(** Special base instances of order *)

Lemma Zgt_succ : forall n:Z, Zsucc n > n.
Proof.
  exact Zcompare_succ_Gt.
Qed.

Lemma Znot_le_succ : forall n:Z, ~ Zsucc n <= n.
Proof.
  intros n; apply Zgt_not_le; apply Zgt_succ.
Qed.

Lemma Zlt_succ : forall n:Z, n < Zsucc n.
Proof.
  intro n; apply Zgt_lt; apply Zgt_succ.
Qed.

Lemma Zlt_pred : forall n:Z, Zpred n < n.
Proof.
  intros n; apply Zsucc_lt_reg; rewrite <- Zsucc_pred; apply Zlt_succ.
Qed.

(** Relating strict and large order using successor or predecessor *)

Lemma Zgt_le_succ : forall n m:Z, m > n -> Zsucc n <= m.
Proof.
  unfold Zgt, Zle in |- *; intros n p H; elim (Zcompare_Gt_not_Lt p n);
    intros H1 H2; unfold not in |- *; intros H3; unfold not in H1;
      apply H1;
	[ assumption
	  | elim (Zcompare_Gt_Lt_antisym (n + 1) p); intros H4 H5; apply H4; exact H3 ].
Qed.

Lemma Zle_gt_succ : forall n m:Z, n <= m -> Zsucc m > n.
Proof.
  intros n p H; apply Zgt_le_trans with p.
  apply Zgt_succ.
  assumption.
Qed.

Lemma Zle_lt_succ : forall n m:Z, n <= m -> n < Zsucc m.
Proof.
  intros n m H; apply Zgt_lt; apply Zle_gt_succ; assumption.
Qed.

Lemma Zlt_le_succ : forall n m:Z, n < m -> Zsucc n <= m.
Proof.
  intros n p H; apply Zgt_le_succ; apply Zlt_gt; assumption.
Qed.

Lemma Zgt_succ_le : forall n m:Z, Zsucc m > n -> n <= m.
Proof.
  intros n p H; apply Zsucc_le_reg; apply Zgt_le_succ; assumption.
Qed.

Lemma Zlt_succ_le : forall n m:Z, n < Zsucc m -> n <= m.
Proof.
  intros n m H; apply Zgt_succ_le; apply Zlt_gt; assumption.
Qed.

Lemma Zle_succ_gt : forall n m:Z, Zsucc n <= m -> m > n.
Proof.
  intros n m H; apply Zle_gt_trans with (m := Zsucc n);
    [ assumption | apply Zgt_succ ].
Qed.

Lemma Zlt_succ_r : forall n m, n < Zsucc m <-> n <= m.
Proof.
  split; [apply Zlt_succ_le | apply Zle_lt_succ].
Qed.

Lemma Zle_succ_l : forall n m, Zsucc n <= m <-> n < m.
Proof.
 intros. split; intros H.
 rewrite (Zsucc_pred m). apply Zle_lt_succ, Zsucc_le_reg.
 now rewrite <- Zsucc_pred.
 now apply Zlt_le_succ.
Qed.

(** Weakening order *)

Lemma Zle_succ : forall n:Z, n <= Zsucc n.
Proof.
  intros n; apply Zgt_succ_le; apply Zgt_trans with (m := Zsucc n);
    apply Zgt_succ.
Qed.

Hint Resolve Zle_succ: zarith.

Lemma Zle_pred : forall n:Z, Zpred n <= n.
Proof.
  intros n; pattern n at 2 in |- *; rewrite Zsucc_pred; apply Zle_succ.
Qed.

Lemma Zlt_lt_succ : forall n m:Z, n < m -> n < Zsucc m.
  intros n m H; apply Zgt_lt; apply Zgt_trans with (m := m);
    [ apply Zgt_succ | apply Zlt_gt; assumption ].
Qed.

Lemma Zle_le_succ : forall n m:Z, n <= m -> n <= Zsucc m.
Proof.
  intros x y H.
  apply Zle_trans with y; trivial with zarith.
Qed.

Lemma Zle_succ_le : forall n m:Z, Zsucc n <= m -> n <= m.
Proof.
  intros n m H; apply Zle_trans with (m := Zsucc n);
    [ apply Zle_succ | assumption ].
Qed.

Hint Resolve Zle_le_succ: zarith.

(** Relating order wrt successor and order wrt predecessor *)

Lemma Zgt_succ_pred : forall n m:Z, m > Zsucc n -> Zpred m > n.
Proof.
  unfold Zgt, Zsucc, Zpred in |- *; intros n p H;
    rewrite <- (fun x y => Zcompare_plus_compat x y 1);
      rewrite (Zplus_comm p); rewrite Zplus_assoc;
	rewrite (fun x => Zplus_comm x n); simpl in |- *;
	  assumption.
Qed.

Lemma Zlt_succ_pred : forall n m:Z, Zsucc n < m -> n < Zpred m.
Proof.
  intros n p H; apply Zsucc_lt_reg; rewrite <- Zsucc_pred; assumption.
Qed.

(** Relating strict order and large order on positive *)

Lemma Zlt_0_le_0_pred : forall n:Z, 0 < n -> 0 <= Zpred n.
Proof.
  intros x H.
  rewrite (Zsucc_pred x) in H.
  apply Zgt_succ_le.
  apply Zlt_gt.
  assumption.
Qed.

Lemma Zgt_0_le_0_pred : forall n:Z, n > 0 -> 0 <= Zpred n.
Proof.
  intros; apply Zlt_0_le_0_pred; apply Zgt_lt. assumption.
Qed.

(** Special cases of ordered integers *)

Lemma Zlt_0_1 : 0 < 1.
Proof.
  change (0 < Zsucc 0) in |- *. apply Zlt_succ.
Qed.

Lemma Zle_0_1 : 0 <= 1.
Proof.
  change (0 <= Zsucc 0) in |- *. apply Zle_succ.
Qed.

Lemma Zle_neg_pos : forall p q:positive, Zneg p <= Zpos q.
Proof.
  intros p; red in |- *; simpl in |- *; red in |- *; intros H; discriminate.
Qed.

Lemma Zgt_pos_0 : forall p:positive, Zpos p > 0.
Proof.
  unfold Zgt in |- *; trivial.
Qed.

(* weaker but useful (in [Zpower] for instance) *)
Lemma Zle_0_pos : forall p:positive, 0 <= Zpos p.
Proof.
  intro; unfold Zle in |- *; discriminate.
Qed.

Lemma Zlt_neg_0 : forall p:positive, Zneg p < 0.
Proof.
  unfold Zlt in |- *; trivial.
Qed.

Lemma Zle_0_nat : forall n:nat, 0 <= Z_of_nat n.
Proof.
  simple induction n; simpl in |- *; intros;
    [ apply Zle_refl | unfold Zle in |- *; simpl in |- *; discriminate ].
Qed.

Hint Immediate Zeq_le: zarith.

(** Transitivity using successor *)

Lemma Zgt_trans_succ : forall n m p:Z, Zsucc n > m -> m > p -> n > p.
Proof.
  intros n m p H1 H2; apply Zle_gt_trans with (m := m);
    [ apply Zgt_succ_le; assumption | assumption ].
Qed.

(** Derived lemma *)

Lemma Zgt_succ_gt_or_eq : forall n m:Z, Zsucc n > m -> n > m \/ m = n.
Proof.
  intros n m H.
  assert (Hle : m <= n).
  apply Zgt_succ_le; assumption.
  destruct (Zle_lt_or_eq _ _ Hle) as [Hlt| Heq].
  left; apply Zlt_gt; assumption.
  right; assumption.
Qed.

(** ** Addition *)
(** Compatibility of addition wrt to order *)

Lemma Zplus_gt_compat_l : forall n m p:Z, n > m -> p + n > p + m.
Proof.
  unfold Zgt in |- *; intros n m p H; rewrite (Zcompare_plus_compat n m p);
    assumption.
Qed.

Lemma Zplus_gt_compat_r : forall n m p:Z, n > m -> n + p > m + p.
Proof.
  intros n m p H; rewrite (Zplus_comm n p); rewrite (Zplus_comm m p);
    apply Zplus_gt_compat_l; trivial.
Qed.

Lemma Zplus_le_compat_l : forall n m p:Z, n <= m -> p + n <= p + m.
Proof.
  intros n m p; unfold Zle, not in |- *; intros H1 H2; apply H1;
    rewrite <- (Zcompare_plus_compat n m p); assumption.
Qed.

Lemma Zplus_le_compat_r : forall n m p:Z, n <= m -> n + p <= m + p.
Proof.
  intros a b c; do 2 rewrite (fun n:Z => Zplus_comm n c);
    exact (Zplus_le_compat_l a b c).
Qed.

Lemma Zplus_lt_compat_l : forall n m p:Z, n < m -> p + n < p + m.
Proof.
  unfold Zlt in |- *; intros n m p; rewrite Zcompare_plus_compat;
    trivial with arith.
Qed.

Lemma Zplus_lt_compat_r : forall n m p:Z, n < m -> n + p < m + p.
Proof.
  intros n m p H; rewrite (Zplus_comm n p); rewrite (Zplus_comm m p);
    apply Zplus_lt_compat_l; trivial.
Qed.

Lemma Zplus_lt_le_compat : forall n m p q:Z, n < m -> p <= q -> n + p < m + q.
Proof.
  intros a b c d H0 H1.
  apply Zlt_le_trans with (b + c).
  apply Zplus_lt_compat_r; trivial.
  apply Zplus_le_compat_l; trivial.
Qed.

Lemma Zplus_le_lt_compat : forall n m p q:Z, n <= m -> p < q -> n + p < m + q.
Proof.
  intros a b c d H0 H1.
  apply Zle_lt_trans with (b + c).
  apply Zplus_le_compat_r; trivial.
  apply Zplus_lt_compat_l; trivial.
Qed.

Lemma Zplus_le_compat : forall n m p q:Z, n <= m -> p <= q -> n + p <= m + q.
Proof.
  intros n m p q; intros H1 H2; apply Zle_trans with (m := n + q);
    [ apply Zplus_le_compat_l; assumption
      | apply Zplus_le_compat_r; assumption ].
Qed.

Lemma Zplus_lt_compat : forall n m p q:Z, n < m -> p < q -> n + p < m + q.
  intros; apply Zplus_le_lt_compat. apply Zlt_le_weak; assumption. assumption.
Qed.

(** Compatibility of addition wrt to being positive *)

Lemma Zplus_le_0_compat : forall n m:Z, 0 <= n -> 0 <= m -> 0 <= n + m.
Proof.
  intros x y H1 H2; rewrite <- (Zplus_0_l 0); apply Zplus_le_compat; assumption.
Qed.

(** Simplification of addition wrt to order *)

Lemma Zplus_gt_reg_l : forall n m p:Z, p + n > p + m -> n > m.
Proof.
  unfold Zgt in |- *; intros n m p H; rewrite <- (Zcompare_plus_compat n m p);
    assumption.
Qed.

Lemma Zplus_gt_reg_r : forall n m p:Z, n + p > m + p -> n > m.
Proof.
  intros n m p H; apply Zplus_gt_reg_l with p.
  rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial.
Qed.

Lemma Zplus_le_reg_l : forall n m p:Z, p + n <= p + m -> n <= m.
Proof.
  intros n m p; unfold Zle, not in |- *; intros H1 H2; apply H1;
    rewrite (Zcompare_plus_compat n m p); assumption.
Qed.

Lemma Zplus_le_reg_r : forall n m p:Z, n + p <= m + p -> n <= m.
Proof.
  intros n m p H; apply Zplus_le_reg_l with p.
  rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial.
Qed.

Lemma Zplus_lt_reg_l : forall n m p:Z, p + n < p + m -> n < m.
Proof.
  unfold Zlt in |- *; intros n m p; rewrite Zcompare_plus_compat;
    trivial with arith.
Qed.

Lemma Zplus_lt_reg_r : forall n m p:Z, n + p < m + p -> n < m.
Proof.
  intros n m p H; apply Zplus_lt_reg_l with p.
  rewrite (Zplus_comm p n); rewrite (Zplus_comm p m); trivial.
Qed.

(** ** Multiplication *)
(** Compatibility of multiplication by a positive wrt to order *)

Lemma Zmult_le_compat_r : forall n m p:Z, n <= m -> 0 <= p -> n * p <= m * p.
Proof.
  intros a b c H H0; destruct c.
  do 2 rewrite Zmult_0_r; assumption.
  rewrite (Zmult_comm a); rewrite (Zmult_comm b).
  unfold Zle in |- *; rewrite Zcompare_mult_compat; assumption.
  unfold Zle in H0; contradiction H0; reflexivity.
Qed.

Lemma Zmult_le_compat_l : forall n m p:Z, n <= m -> 0 <= p -> p * n <= p * m.
Proof.
  intros a b c H1 H2; rewrite (Zmult_comm c a); rewrite (Zmult_comm c b).
  apply Zmult_le_compat_r; trivial.
Qed.

Lemma Zmult_lt_compat_r : forall n m p:Z, 0 < p -> n < m -> n * p < m * p.
Proof.
  intros x y z H H0; destruct z.
  contradiction (Zlt_irrefl 0).
  rewrite (Zmult_comm x); rewrite (Zmult_comm y).
  unfold Zlt in |- *; rewrite Zcompare_mult_compat; assumption.
  discriminate H.
Qed.

Lemma Zmult_gt_compat_r : forall n m p:Z, p > 0 -> n > m -> n * p > m * p.
Proof.
  intros x y z; intros; apply Zlt_gt; apply Zmult_lt_compat_r; apply Zgt_lt;
    assumption.
Qed.

Lemma Zmult_gt_0_lt_compat_r :
  forall n m p:Z, p > 0 -> n < m -> n * p < m * p.
Proof.
  intros x y z; intros; apply Zmult_lt_compat_r;
    [ apply Zgt_lt; assumption | assumption ].
Qed.

Lemma Zmult_gt_0_le_compat_r :
  forall n m p:Z, p > 0 -> n <= m -> n * p <= m * p.
Proof.
  intros x y z Hz Hxy.
  elim (Zle_lt_or_eq x y Hxy).
  intros; apply Zlt_le_weak.
  apply Zmult_gt_0_lt_compat_r; trivial.
  intros; apply Zeq_le.
  rewrite H; trivial.
Qed.

Lemma Zmult_lt_0_le_compat_r :
  forall n m p:Z, 0 < p -> n <= m -> n * p <= m * p.
Proof.
  intros x y z; intros; apply Zmult_gt_0_le_compat_r; try apply Zlt_gt;
    assumption.
Qed.

Lemma Zmult_gt_0_lt_compat_l :
  forall n m p:Z, p > 0 -> n < m -> p * n < p * m.
Proof.
  intros x y z; intros.
  rewrite (Zmult_comm z x); rewrite (Zmult_comm z y);
    apply Zmult_gt_0_lt_compat_r; assumption.
Qed.

Lemma Zmult_lt_compat_l : forall n m p:Z, 0 < p -> n < m -> p * n < p * m.
Proof.
  intros x y z; intros.
  rewrite (Zmult_comm z x); rewrite (Zmult_comm z y);
    apply Zmult_gt_0_lt_compat_r; try apply Zlt_gt; assumption.
Qed.

Lemma Zmult_gt_compat_l : forall n m p:Z, p > 0 -> n > m -> p * n > p * m.
Proof.
  intros x y z; intros; rewrite (Zmult_comm z x); rewrite (Zmult_comm z y);
    apply Zmult_gt_compat_r; assumption.
Qed.

Lemma Zmult_ge_compat_r : forall n m p:Z, n >= m -> p >= 0 -> n * p >= m * p.
Proof.
  intros a b c H1 H2; apply Zle_ge.
  apply Zmult_le_compat_r; apply Zge_le; trivial.
Qed.

Lemma Zmult_ge_compat_l : forall n m p:Z, n >= m -> p >= 0 -> p * n >= p * m.
Proof.
  intros a b c H1 H2; apply Zle_ge.
  apply Zmult_le_compat_l; apply Zge_le; trivial.
Qed.

Lemma Zmult_ge_compat :
  forall n m p q:Z, n >= p -> m >= q -> p >= 0 -> q >= 0 -> n * m >= p * q.
Proof.
  intros a b c d H0 H1 H2 H3.
  apply Zge_trans with (a * d).
  apply Zmult_ge_compat_l; trivial.
  apply Zge_trans with c; trivial.
  apply Zmult_ge_compat_r; trivial.
Qed.

Lemma Zmult_le_compat :
  forall n m p q:Z, n <= p -> m <= q -> 0 <= n -> 0 <= m -> n * m <= p * q.
Proof.
  intros a b c d H0 H1 H2 H3.
  apply Zle_trans with (c * b).
  apply Zmult_le_compat_r; assumption.
  apply Zmult_le_compat_l.
  assumption.
  apply Zle_trans with a; assumption.
Qed.

(** Simplification of multiplication by a positive wrt to being positive *)

Lemma Zmult_gt_0_lt_reg_r : forall n m p:Z, p > 0 -> n * p < m * p -> n < m.
Proof.
  intros x y z; intros; destruct z.
  contradiction (Zgt_irrefl 0).
  rewrite (Zmult_comm x) in H0; rewrite (Zmult_comm y) in H0.
  unfold Zlt in H0; rewrite Zcompare_mult_compat in H0; assumption.
  discriminate H.
Qed.

Lemma Zmult_lt_reg_r : forall n m p:Z, 0 < p -> n * p < m * p -> n < m.
Proof.
  intros a b c H0 H1.
  apply Zmult_gt_0_lt_reg_r with c; try apply Zlt_gt; assumption.
Qed.

Lemma Zmult_le_reg_r : forall n m p:Z, p > 0 -> n * p <= m * p -> n <= m.
Proof.
  intros x y z Hz Hxy.
  elim (Zle_lt_or_eq (x * z) (y * z) Hxy).
  intros; apply Zlt_le_weak.
  apply Zmult_gt_0_lt_reg_r with z; trivial.
  intros; apply Zeq_le.
  apply Zmult_reg_r with z.
  intro. rewrite H0 in Hz. contradiction (Zgt_irrefl 0).
  assumption.
Qed.

Lemma Zmult_lt_0_le_reg_r : forall n m p:Z, 0 < p -> n * p <= m * p -> n <= m.
Proof.
  intros x y z; intros; apply Zmult_le_reg_r with z.
  try apply Zlt_gt; assumption.
  assumption.
Qed.

Lemma Zmult_ge_reg_r : forall n m p:Z, p > 0 -> n * p >= m * p -> n >= m.
Proof.
  intros a b c H1 H2; apply Zle_ge; apply Zmult_le_reg_r with c; trivial.
  apply Zge_le; trivial.
Qed.

Lemma Zmult_gt_reg_r : forall n m p:Z, p > 0 -> n * p > m * p -> n > m.
Proof.
  intros a b c H1 H2; apply Zlt_gt; apply Zmult_gt_0_lt_reg_r with c; trivial.
  apply Zgt_lt; trivial.
Qed.

(** Compatibility of multiplication by a positive wrt to being positive *)

Lemma Zmult_le_0_compat : forall n m:Z, 0 <= n -> 0 <= m -> 0 <= n * m.
Proof.
  intros x y; case x.
  intros; rewrite Zmult_0_l; trivial.
  intros p H1; unfold Zle in |- *.
  pattern 0 at 2 in |- *; rewrite <- (Zmult_0_r (Zpos p)).
  rewrite Zcompare_mult_compat; trivial.
  intros p H1 H2; absurd (0 > Zneg p); trivial.
  unfold Zgt in |- *; simpl in |- *; auto with zarith.
Qed.

Lemma Zmult_gt_0_compat : forall n m:Z, n > 0 -> m > 0 -> n * m > 0.
Proof.
  intros x y; case x.
  intros H; discriminate H.
  intros p H1; unfold Zgt in |- *; pattern 0 at 2 in |- *;
    rewrite <- (Zmult_0_r (Zpos p)).
  rewrite Zcompare_mult_compat; trivial.
  intros p H; discriminate H.
Qed.

Lemma Zmult_lt_0_compat : forall n m:Z, 0 < n -> 0 < m -> 0 < n * m.
Proof.
  intros a b apos bpos.
  apply Zgt_lt.
  apply Zmult_gt_0_compat; try apply Zlt_gt; assumption.
Qed.

(** For compatibility *)
Notation Zmult_lt_O_compat := Zmult_lt_0_compat (only parsing).

Lemma Zmult_gt_0_le_0_compat : forall n m:Z, n > 0 -> 0 <= m -> 0 <= m * n.
Proof.
  intros x y H1 H2; apply Zmult_le_0_compat; trivial.
  apply Zlt_le_weak; apply Zgt_lt; trivial.
Qed.

(** Simplification of multiplication by a positive wrt to being positive *)

Lemma Zmult_le_0_reg_r : forall n m:Z, n > 0 -> 0 <= m * n -> 0 <= m.
Proof.
  intros x y; case x;
    [ simpl in |- *; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H
      | intros p H1; unfold Zle in |- *; rewrite Zmult_comm;
	pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p));
	  rewrite Zcompare_mult_compat; auto with arith
      | intros p; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H ].
Qed.

Lemma Zmult_gt_0_lt_0_reg_r : forall n m:Z, n > 0 -> 0 < m * n -> 0 < m.
Proof.
  intros x y; case x;
    [ simpl in |- *; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H
      | intros p H1; unfold Zlt in |- *; rewrite Zmult_comm;
	pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p));
	  rewrite Zcompare_mult_compat; auto with arith
      | intros p; unfold Zgt in |- *; simpl in |- *; intros H; discriminate H ].
Qed.

Lemma Zmult_lt_0_reg_r : forall n m:Z, 0 < n -> 0 < m * n -> 0 < m.
Proof.
  intros x y; intros; eapply Zmult_gt_0_lt_0_reg_r with x; try apply Zlt_gt;
    assumption.
Qed.

Lemma Zmult_gt_0_reg_l : forall n m:Z, n > 0 -> n * m > 0 -> m > 0.
Proof.
  intros x y; case x.
  intros H; discriminate H.
  intros p H1; unfold Zgt in |- *.
  pattern 0 at 1 in |- *; rewrite <- (Zmult_0_r (Zpos p)).
  rewrite Zcompare_mult_compat; trivial.
  intros p H; discriminate H.
Qed.

(** ** Square *)
(** Simplification of square wrt order *)

Lemma Zgt_square_simpl :
  forall n m:Z, n >= 0 -> n * n > m * m -> n > m.
Proof.
  intros n m H0 H1.
  case (dec_Zlt m n).
  intro; apply Zlt_gt; trivial.
  intros H2; cut (m >= n).
  intros H.
  elim Zgt_not_le with (1 := H1).
  apply Zge_le.
  apply Zmult_ge_compat; auto.
  apply Znot_lt_ge; trivial.
Qed.

Lemma Zlt_square_simpl :
  forall n m:Z, 0 <= n -> m * m < n * n -> m < n.
Proof.
  intros x y H0 H1.
  apply Zgt_lt.
  apply Zgt_square_simpl; try apply Zle_ge; try apply Zlt_gt; assumption.
Qed.

(** * Equivalence between inequalities *)

Lemma Zle_plus_swap : forall n m p:Z, n + p <= m <-> n <= m - p.
Proof.
  intros x y z; intros. split. intro. rewrite <- (Zplus_0_r x). rewrite <- (Zplus_opp_r z).
  rewrite Zplus_assoc. exact (Zplus_le_compat_r _ _ _ H).
  intro. rewrite <- (Zplus_0_r y). rewrite <- (Zplus_opp_l z). rewrite Zplus_assoc.
  apply Zplus_le_compat_r. assumption.
Qed.

Lemma Zlt_plus_swap : forall n m p:Z, n + p < m <-> n < m - p.
Proof.
  intros x y z; intros. split. intro. unfold Zminus in |- *. rewrite Zplus_comm. rewrite <- (Zplus_0_l x).
  rewrite <- (Zplus_opp_l z). rewrite Zplus_assoc_reverse. apply Zplus_lt_compat_l. rewrite Zplus_comm.
  assumption.
  intro. rewrite Zplus_comm. rewrite <- (Zplus_0_l y). rewrite <- (Zplus_opp_r z).
  rewrite Zplus_assoc_reverse. apply Zplus_lt_compat_l. rewrite Zplus_comm. assumption.
Qed.

Lemma Zeq_plus_swap : forall n m p:Z, n + p = m <-> n = m - p.
Proof.
  intros x y z; intros. split. intro. apply Zplus_minus_eq. symmetry  in |- *. rewrite Zplus_comm.
  assumption.
  intro. rewrite H. unfold Zminus in |- *. rewrite Zplus_assoc_reverse.
  rewrite Zplus_opp_l. apply Zplus_0_r.
Qed.

Lemma Zlt_minus_simpl_swap : forall n m:Z, 0 < m -> n - m < n.
Proof.
  intros n m H; apply Zplus_lt_reg_l with (p := m); rewrite Zplus_minus;
    pattern n at 1 in |- *; rewrite <- (Zplus_0_r n);
      rewrite (Zplus_comm m n); apply Zplus_lt_compat_l;
	assumption.
Qed.

Lemma Zlt_0_minus_lt : forall n m:Z, 0 < n - m -> m < n.
Proof.
  intros n m H; apply Zplus_lt_reg_l with (p := - m); rewrite Zplus_opp_l;
    rewrite Zplus_comm; exact H.
Qed.

Lemma Zle_0_minus_le : forall n m:Z, 0 <= n - m -> m <= n.
Proof.
  intros n m H; apply Zplus_le_reg_l with (p := - m); rewrite Zplus_opp_l;
    rewrite Zplus_comm; exact H.
Qed.

Lemma Zle_minus_le_0 : forall n m:Z, m <= n -> 0 <= n - m.
Proof.
  intros n m H; unfold Zminus; apply Zplus_le_reg_r with (p := m);
    rewrite <- Zplus_assoc; rewrite Zplus_opp_l; rewrite Zplus_0_r; exact H.
Qed.

Lemma Zmult_lt_compat:
  forall n m p q : Z, 0 <= n < p -> 0 <= m < q -> n * m < p * q.
Proof.
  intros n m p q (H1, H2) (H3,H4).
  assert (0<p) by (apply Zle_lt_trans with n; auto).
  assert (0<q) by (apply Zle_lt_trans with m; auto).
  case Zle_lt_or_eq with (1 := H1); intros H5; auto with zarith.
  case Zle_lt_or_eq with (1 := H3); intros H6; auto with zarith.
  apply Zlt_trans with (n * q).
  apply Zmult_lt_compat_l; auto.
  apply Zmult_lt_compat_r; auto with zarith.
  rewrite <- H6; rewrite Zmult_0_r; apply Zmult_lt_0_compat; auto with zarith.
  rewrite <- H5; simpl; apply Zmult_lt_0_compat; auto with zarith.
Qed.

Lemma Zmult_lt_compat2:
  forall n m p q : Z, 0 < n <= p -> 0 < m < q -> n * m < p * q.
Proof.
  intros n m p q (H1, H2) (H3, H4).
  apply Zle_lt_trans with (p * m).
  apply Zmult_le_compat_r; auto.
  apply Zlt_le_weak; auto.
  apply Zmult_lt_compat_l; auto.
  apply Zlt_le_trans with n; auto.
Qed.

(** For compatibility *)
Notation Zlt_O_minus_lt := Zlt_0_minus_lt (only parsing).