Require Import Cava.Arrow.Classes.Category.

Import CategoryNotations.

Local Open Scope category_scope.

Reserved Infix "**" (at level 30, right associativity).

Generalizable Variable unit product.

Class DecidableEquality T := {
  eq_dec: forall x y : T, {x = y} + {x <> y}
}.

(* generalized arrow *)
Class Arrow (object: Type) (category: Category object) (unit: object) (product: object -> object -> object) := {
  arrow_category := category;
  u := unit;
  product := product
    where "x ** y" := (product x y);

  first  {x y z} (f: x ~> y) : x ** z ~> y ** z;
  second {x y z} (f: x ~> y) : z ** x ~> z ** y;

  bimap {x y z w} (f: x ~> y) (g: z ~> w) := first f >>> second g;

  assoc   {x y z} : ((x**y)**z) ~> (x**(y**z));
  unassoc {x y z} : (x**(y**z)) ~> ((x**y)**z);

  cancelr  {x} : x ** unit ~> x;
  cancell  {x} : unit ** x ~> x;

  uncancell {x} : x ~> unit**x;
  uncancelr {x} : x ~> x**unit;
}.

Coercion arrow_category: Arrow >-> Category.

Declare Scope arrow_scope.
Bind Scope arrow_scope with Arrow.
Delimit Scope arrow_scope with Arrow.

Notation "x ** y" := (product x y)
  (at level 30, right associativity) : arrow_scope.

Class ArrowLaws
  (object: Set)
  (category: Category object) (category_laws: CategoryLaws category)
  (unit: object) (product: object -> object -> object) (A: Arrow object category unit product)
  := {
  (* (un)cance{l,r} and (un)assoc are natural isomorphisms *)
  first_cancelr   {x y} (f: x ~> y): first f >>> cancelr =M= cancelr >>> f;
  uncancelr_first {x y} (f: x ~> y): uncancelr >>> first f =M= f >>> uncancelr;

  second_cancell   {x y} (f: x ~> y): second f >>> cancell =M= cancell >>> f;
  uncancell_second {x y} (f: x ~> y): uncancell >>> second f =M= f >>> uncancell;

  assoc_iso {x y z w s t} (f: x ~> y) (g: z ~> w) (h: s ~> t):
    assoc >>> bimap _ _ _ _ f (bimap _ _ _ _ g h) =M= bimap _ _ _ _ (bimap _ _ _ _ f g) h >>> assoc;

  unassoc_iso {x y z w s t} (f: x ~> y) (g: z ~> w) (h: s ~> t):
    unassoc >>> bimap _ _ _ _ (bimap _ _ _ _ f g) h =M= bimap _ _ _ _ f (bimap _ _ _ _ g h) >>> unassoc;

  (* triangle and pentagon identities? *)
}.

Section with_continuation.
  Context `{arrow_laws: ArrowLaws}.

  Local Ltac prove_cont law :=
    rewrite <-associativity;
    setoid_rewrite law; apply associativity.

  Lemma first_cancelr_cont {x y z} (f: x ~> y) (k: _ ~> z):
    first f >>> cancelr >>> k =M= cancelr >>> f >>> k.
  Proof using arrow_laws. prove_cont (first_cancelr f). Qed.

  Lemma uncancelr_first_cont {x y z} (f: x ~> y) (k: _ ~> z):
    uncancelr >>> first f >>> k =M= f >>> uncancelr >>> k.
  Proof using arrow_laws. prove_cont (uncancelr_first f). Qed.

  Lemma second_cancell_cont {x y z} (f: x ~> y) (k: _ ~> z):
    second f >>> cancell >>> k =M= cancell >>> f >>> k.
  Proof using arrow_laws. prove_cont (second_cancell f). Qed.

  Lemma uncancell_second_cont {x y z} (f: x ~> y) (k: _ ~> z):
    uncancell >>> second f >>> k =M= f >>> uncancell >>> k.
  Proof using arrow_laws. prove_cont (uncancell_second f). Qed.

  Lemma assoc_iso_cont
        {x y z w s t v} (f: x ~> y) (g: z ~> w) (h: s ~> t) (k: _ ~> v):
    assoc >>> bimap _ _ _ _ f (bimap _ _ _ _ g h) >>> k
    =M= bimap _ _ _ _ (bimap _ _ _ _ f g) h >>> assoc >>> k.
  Proof using arrow_laws. prove_cont (assoc_iso f g h). Qed.

  Lemma unassoc_iso_cont
        {x y z w s t v} (f: x ~> y) (g: z ~> w) (h: s ~> t) (k: _ ~> v):
    unassoc >>> bimap _ _ _ _ (bimap _ _ _ _ f g) h >>> k
    =M= bimap _ _ _ _ f (bimap _ _ _ _ g h) >>> unassoc >>> k.
  Proof using arrow_laws. prove_cont (unassoc_iso f g h). Qed.
End with_continuation.

Local Open Scope arrow_scope.

Class ArrowCopy `(A: Arrow) := {
  copy {x} : x ~> x**x;
}.

Class ArrowDrop `(A: Arrow) := {
  drop {x} : x ~> u;
}.

Class ArrowSwap `(A: Arrow) := {
  swap {x y} : x**y ~> y**x;
}.

Class ArrowLoop `(A: Arrow) := {
  loopr {x y z} : (x**z ~> y**z) -> (x ~> y);
  loopl {x y z} : (z**x ~> z**y) -> (x ~> y);
}.

Class ArrowConstant
  object (category: Category object)
  unit prod (A: Arrow object category unit prod)
  (r: object) t
  := {
  constant : t -> (unit ~> r);
}.

Inductive void := .

Lemma void_is_false: void -> False.
Proof.
  intros.
  destruct H.
Qed.

Class ArrowSum
  object (category: Category object)
  void either (ASum: Arrow object category void either)
  := {
  merge {x} : (either x x) ~> x;
  never {x} : void ~> x;
}.

(*
Class ArrowApply := {
  app {x y}: (x~>y)**y ~> x:
}.

Class ArrowProd := {
  prod_copy {x} : x ~> (x<*>x):
  prod_drop {x} : x ~> v;
}.
*)

Class ArrowSTKC
  `(A: Arrow)
  := {
  stkc_arrow := A;
  stkc_arrow_drop :> ArrowDrop A;
  stkc_arrow_swap :> ArrowSwap A;
  stkc_arrow_copy :> ArrowCopy A;
}.

Coercion stkc_arrow: ArrowSTKC >-> Arrow.
Coercion stkc_arrow_drop: ArrowSTKC >-> ArrowDrop.
Coercion stkc_arrow_swap: ArrowSTKC >-> ArrowSwap.
Coercion stkc_arrow_copy: ArrowSTKC >-> ArrowCopy.

Section arrowstkc.
  Context {object: Type}.
  Context {unit: object}.
  Context {product: object -> object -> object}.

  Inductive ArrowStructure :=
    | Id: object -> ArrowStructure
    | Assoc: object -> object -> object -> ArrowStructure
    | Unassoc: object -> object -> object -> ArrowStructure
    | Cancelr: object -> ArrowStructure
    | Cancell: object -> ArrowStructure
    | Uncancell: object -> ArrowStructure
    | Uncancelr: object -> ArrowStructure
    | Copy: object -> ArrowStructure
    | Drop: object -> ArrowStructure
    | Swap: object -> object -> ArrowStructure.

  Inductive ArrowComposition :=
    | Compose: object -> object -> object -> ArrowComposition
    | First: object -> object -> object -> ArrowComposition
    | Second: object -> object -> object -> ArrowComposition.

  Definition arrow_input (a: ArrowStructure): object :=
    match a with
    | Id x => x
    | Assoc x y z => (product (product x y) z)
    | Unassoc x y z => (product x (product y z))
    | Cancelr x => product x unit
    | Cancell x => product unit x
    | Uncancell x => x
    | Uncancelr x => x
    | Copy x => x
    | Drop x => x
    | Swap x y => product x y
    end.

  Definition arrow_output (a: ArrowStructure): object :=
    match a with
    | Id x => x
    | Assoc x y z => (product x (product y z))
    | Unassoc x y z => (product (product x y) z)
    | Cancelr x => x
    | Cancell x => x
    | Uncancell x => product unit x
    | Uncancelr x => product x unit
    | Copy x => product x x
    | Drop x => unit
    | Swap x y => product y x
    end.
End arrowstkc.


Require Import Coq.Program.Program.
Require Import Fiat.Common.
(** * Various useful lemmas about logic *)

(** We prove things here mainly for the purpose of [setoid_rewrite]ing with instances of [impl] and [iff]. *)

Local Arguments impl / .
Local Arguments flip / .
Local Arguments pointwise_relation / .

Local Hint Extern 1 => progress simpl in *.
Local Hint Extern 1 => progress subst; eauto. (* WTF? *)
Local Hint Extern 1 => progress destruct_head_hnf sig.

Section forall_eq.
  (** We prove some lemmas about [forall] and [eq], for the benefit of setoid rewriting. *)
  Definition iff_remove_forall_eql A x (P : _ -> Prop)
  : iff (forall y : A, y = x -> P y) (P x).
  Proof. firstorder. Defined.

  Definition iff_remove_forall_eqr A x (P : _ -> Prop)
  : iff (forall y : A, x = y -> P y) (P x).
  Proof. firstorder. Defined.

  (** These versions are around twice as fast as the [iff] versions... not sure why. *)
  Definition remove_forall_eql A x (P : _ -> Prop)
  : flip impl (forall y : A, y = x -> P y) (P x)
    := proj2 (@iff_remove_forall_eql A x P).

  Definition remove_forall_eql' A x (P : _ -> Prop)
  : impl (forall y : A, y = x -> P y) (P x)
    := proj1 (@iff_remove_forall_eql A x P).

  Definition remove_forall_eqr A x (P : _ -> Prop)
  : flip impl (forall y : A, x = y -> P y) (P x)
    := proj2 (@iff_remove_forall_eqr A x P).

  Definition remove_forall_eqr' A x (P : _ -> Prop)
  : impl (forall y : A, x = y -> P y) (P x)
    := proj1 (@iff_remove_forall_eqr A x P).

  Section and.
    (** Variants for equalities with /\  *)
    Definition iff_remove_forall_eql_and A x (P : _ -> Prop) (Q : A -> Prop)
    : iff (forall y : A, (y = x /\ Q y) -> P y) (Q x -> P x).
    Proof. firstorder. Qed.

    Definition iff_remove_forall_eqr_and A x (P : _ -> Prop) (Q : A -> Prop)
    : iff (forall y : A, (x = y /\ Q y) -> P y) (Q x -> P x).
    Proof. firstorder. Qed.

    Definition iff_remove_forall_and_eql A x (P : _ -> Prop) (Q : A -> Prop)
    : iff (forall y : A, (Q y /\ y = x) -> P y) (Q x -> P x).
    Proof. firstorder. Qed.

    Definition iff_remove_forall_and_eqr A x (P : _ -> Prop) (Q : A -> Prop)
    : iff (forall y : A, (Q y /\ x = y) -> P y) (Q x -> P x).
    Proof. firstorder. Qed.

    Definition remove_forall_eql_and A x (P : _ -> Prop) (Q : A -> Prop)
    : flip impl (forall y : A, (y = x /\ Q y) -> P y) (Q x -> P x)
      := proj2 (@iff_remove_forall_eql_and A x P Q).

    Definition remove_forall_eql_and' A x (P : _ -> Prop) (Q : A -> Prop)
    : impl (forall y : A, (y = x /\ Q y) -> P y) (Q x -> P x)
      := proj1 (@iff_remove_forall_eql_and A x P Q).

    Definition remove_forall_eqr_and A x (P : _ -> Prop) (Q : A -> Prop)
    : flip impl (forall y : A, (x = y /\ Q y) -> P y) (Q x -> P x)
      := proj2 (@iff_remove_forall_eqr_and A x P Q).

    Definition remove_forall_eqr_and' A x (P : _ -> Prop) (Q : A -> Prop)
    : impl (forall y : A, (x = y /\ Q y) -> P y) (Q x -> P x)
      := proj1 (@iff_remove_forall_eqr_and A x P Q).

    Definition remove_forall_and_eql A x (P : _ -> Prop) (Q : A -> Prop)
    : flip impl (forall y : A, (Q y /\ y = x) -> P y) (Q x -> P x)
      := proj2 (@iff_remove_forall_and_eql A x P Q).

    Definition remove_forall_and_eql' A x (P : _ -> Prop) (Q : A -> Prop)
    : impl (forall y : A, (Q y /\ y = x) -> P y) (Q x -> P x)
      := proj1 (@iff_remove_forall_and_eql A x P Q).

    Definition remove_forall_and_eqr A x (P : _ -> Prop) (Q : A -> Prop)
    : flip impl (forall y : A, (Q y /\ x = y) -> P y) (Q x -> P x)
      := proj2 (@iff_remove_forall_and_eqr A x P Q).

    Definition remove_forall_and_eqr' A x (P : _ -> Prop) (Q : A -> Prop)
    : impl (forall y : A, (Q y /\ x = y) -> P y) (Q x -> P x)
      := proj1 (@iff_remove_forall_and_eqr A x P Q).
  End and.
End forall_eq.

Section exists_and_eq.
  (** And now with [exists] *)
  Definition iff_remove_exists_and_eql A x (P : _ -> Prop)
  : iff (exists y : A, P y /\ y = x) (P x).
  Proof. firstorder. Qed.

  Definition iff_remove_exists_and_eqr A x (P : _ -> Prop)
  : iff (exists y : A, P y /\ x = y) (P x).
  Proof. firstorder. Defined.

  Definition iff_remove_exists_eql_and A x (P : _ -> Prop)
  : iff (exists y : A, y = x /\ P y) (P x).
  Proof. firstorder. Qed.

  Definition iff_remove_exists_eqr_and A x (P : _ -> Prop)
  : iff (exists y : A, x = y /\ P y) (P x).
  Proof. firstorder. Defined.

  (** These versions are around twice as fast as the [iff] versions... not sure why. *)
  Definition remove_exists_and_eql A x (P : _ -> Prop)
  : flip impl (exists y : A, P y /\ y = x) (P x)
    := proj2 (@iff_remove_exists_and_eql A x P).

  Definition remove_exists_and_eql' A x (P : _ -> Prop)
  : impl (exists y : A, P y /\ y = x) (P x)
    := proj1 (@iff_remove_exists_and_eql A x P).

  Definition remove_exists_and_eqr A x (P : _ -> Prop)
  : flip impl (exists y : A, P y /\ x = y) (P x)
    := proj2 (@iff_remove_exists_and_eqr A x P).

  Definition remove_exists_and_eqr' A x (P : _ -> Prop)
  : impl (exists y : A, P y /\ x = y) (P x)
    := proj1 (@iff_remove_exists_and_eqr A x P).

  Definition remove_exists_eql_and A x (P : _ -> Prop)
  : flip impl (exists y : A, y = x /\ P y) (P x)
    := proj2 (@iff_remove_exists_eql_and A x P).

  Definition remove_exists_eql_and' A x (P : _ -> Prop)
  : impl (exists y : A, y = x /\ P y) (P x)
    := proj1 (@iff_remove_exists_eql_and A x P).

  Definition remove_exists_eqr_and A x (P : _ -> Prop)
  : flip impl (exists y : A, x = y /\ P y) (P x)
    := proj2 (@iff_remove_exists_eqr_and A x P).

  Definition remove_exists_eqr_and' A x (P : _ -> Prop)
  : impl (exists y : A, x = y /\ P y) (P x)
    := proj1 (@iff_remove_exists_eqr_and A x P).
End exists_and_eq.

Lemma forall_sig_prop A P (Q : _ -> Prop)
: (forall x : @sig A P, Q x) <-> (forall x y, Q (exist P x y)).
Proof. firstorder. Defined.

Lemma forall_commute A P Q (R : forall x : A, P x -> Q x -> Prop)
: (forall x y z, R x y z) <-> (forall x z y, R x y z).
Proof. firstorder. Defined.

Lemma flip_a_impl_b_impl_a (A : Prop) B : flip impl (B -> A) A.
Proof. firstorder. Defined.

Lemma exists_sig A P Q
: (exists x : @sig A P, Q x) <-> (exists x y, Q (exist P x y)).
Proof. firstorder eauto. Defined.

Lemma exists_and_comm A B Q
: (exists x : A, B /\ Q x) <-> (B /\ exists x : A, Q x).
Proof. firstorder. Defined.

Lemma exists_and_assoc A B Q
: (exists x : A, (Q x /\ B)) <-> ((exists x : A, Q x) /\ B).
Proof. firstorder. Defined.

Lemma impl_exists A P Q (H : exists x : A, impl Q (P x))
: impl Q (exists x : A, P x).
Proof. firstorder. Defined.

#[global]
Hint Resolve impl_exists : typeclass_instances.


Require Export hexamys.

Lemma eolien : hexamy -> forall A B C A' B' C' A'' B'' C'',
A<>B -> A<>C -> A<>A' -> A<>B' -> A<> C' ->
A<>A'' -> A<>B'' -> A<>C'' ->
B<>C -> B<>A' -> B<>B' -> B<> C' ->
B<>A'' -> B<>B'' -> B<>C'' ->
C<>A' -> C<>B' -> C<> C' ->
C<>A'' -> C<>B'' -> C<>C'' ->
A'<>B' -> A'<> C' ->
A'<>A'' -> A'<>B'' -> A'<>C'' ->
B'<> C' ->
B'<>A'' -> B'<>B'' -> B'<>C'' ->
C'<>A'' -> C'<>B'' -> C'<>C'' ->
A''<>B'' -> A''<>C'' ->
B''<>C'' ->
Col A' B C -> Col B' A C -> Col C' A B ->
Col A'' B' C' -> Col B'' A' C' -> Col C'' A' B' ->
Col B A'' C'' -> Col C A'' B'' -> Col A C'' B''.
Proof.
intros.
geo_norm.

elim (uniqdec.eq_line_dec x6 x3).
intro;subst;collapse;firstorder.
intro.

elim (uniqdec.eq_line_dec x1 x0).
intro;subst;collapse;firstorder.
intro.

remove_line_occ.

not_eq x x2.
not_eq x4 x5.

hexamy_proof B' A' C B A'' C' C A'' B C' A' B'.
Qed.


From Coq Require Import Arith.Arith.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.EqNat.
From Coq Require Import omega.Omega.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.
From Coq Require Import QArith.QArith_base.
From Coq Require Import QArith.Qabs.
From Coq Require Import QArith.Qminmax.
From Coq Require Import QArith.Qround.
From Coq Require Import Logic.Classical.
From Coq Require Import Classes.Equivalence.
From Coq Require Import Classes.Morphisms.
From Coq Require Export Field.
From CReal Require Import QArith_ext.QArith_base_ext.
From CReal.Cauchy Require Import RBase.
From CReal.Cauchy Require Import RArith.
From CReal.Cauchy Require Import RSign.

Definition Rlt (a b:Real) : Prop :=
  Rpositive (Rminus b a).

Notation "a < b" := (Rlt a b):Real_scope.

Theorem Rlt_trans: forall A B C, (A < B)%R -> (B < C)%R -> (A < C)%R.
Proof. intros.
  destruct A as [A HA], B as [B HB], C as [C HC]. hnf in *.
  unfold Rminus in *. unfold Ropp in *. unfold Cauchy_opp in *.
  unfold Rplus in *. unfold CauchySeqPlus in *.
  destruct H as [epsAB [HepsAB [NAB HAB]]]. destruct H0 as [epsBC [HepsBC [NBC HBC]]].
  destruct (take_max_N NAB NBC _ _ HAB HBC) as [N H]. clear HAB HBC.
  destruct (classic (epsAB<epsBC)) as [Heps|Heps].
  - exists (epsAB+epsAB). split.
      { rewrite <- Qplus_0_r. apply Qplus_lt_le_compat. auto. apply Qlt_le_weak. auto. }
    exists N. intros n Hn qac Hq.
    destruct (H n) as [H1 H2]. auto. clear H.
    destruct (Cauchy_exists _ HA n) as [qa Hqa],
             (Cauchy_exists _ HB n) as [qb Hqb],
             (Cauchy_exists _ HC n) as [qc Hqc].
    assert (E1: epsAB + epsAB <= epsAB + epsBC).
      { apply Qplus_le_compat. apply Qle_refl. apply Qlt_le_weak. auto. }
    assert (E2: qc - qa == (qb - qa) + (qc - qb)) by ring.
    assert (E3: qac == qc - qa).
      { apply Hq. auto. intros. rewrite (Cauchy_unique _ HA _ _ _ Hqa H). reflexivity. }
    assert (E4: epsAB <= (qb - qa)).
      { apply H1. intros. auto. rewrite (H0 qa Hqa).
        rewrite (Cauchy_unique _ HB _ _ _ Hqb H). reflexivity. }
    assert (E5: epsBC <= (qc - qb)).
      { apply H2. intros. auto. rewrite (H0 qb Hqb).
        rewrite (Cauchy_unique _ HC _ _ _ Hqc H). reflexivity. }
    rewrite E3. rewrite E2. apply (Qle_trans _ _ _ E1).
    apply Qplus_le_compat. auto. auto.
  - exists (epsBC+epsBC). split.
      { rewrite <- Qplus_0_r. apply Qplus_lt_le_compat. auto. apply Qlt_le_weak. auto. }
    exists N. intros n Hn qac Hq. apply Qnot_lt_le in Heps.
    destruct (H n) as [H1 H2]. auto. clear H.
    destruct (Cauchy_exists _ HA n) as [qa Hqa],
             (Cauchy_exists _ HB n) as [qb Hqb],
             (Cauchy_exists _ HC n) as [qc Hqc].
    assert (E1: epsBC + epsBC <= epsAB + epsBC).
      { apply Qplus_le_compat. auto. apply Qle_refl. }
    assert (E2: qc - qa == (qb - qa) + (qc - qb)) by ring.
    assert (E3: qac == qc - qa).
      { apply Hq. auto. intros. rewrite (Cauchy_unique _ HA _ _ _ Hqa H). reflexivity. }
    assert (E4: epsAB <= (qb - qa)).
      { apply H1. intros. auto. rewrite (H0 qa Hqa).
        rewrite (Cauchy_unique _ HB _ _ _ Hqb H). reflexivity. }
    assert (E5: epsBC <= (qc - qb)).
      { apply H2. intros. auto. rewrite (H0 qb Hqb).
        rewrite (Cauchy_unique _ HC _ _ _ Hqc H). reflexivity. }
    rewrite E3. rewrite E2. apply (Qle_trans _ _ _ E1).
    apply Qplus_le_compat. auto. auto.
Qed.

Theorem Rlt_plus_r: forall (A B C:Real), (A < B)%R -> (A+C < B+C)%R.
Proof. intros. destruct A as [A HA], B as [B HB], C as [C HC]. hnf in *.
  unfold Rminus in *. unfold Rplus in *. unfold CauchySeqPlus in *.
  unfold Ropp in *. unfold Cauchy_opp in *. destruct H as [eps [Heps [N H]]].
  exists eps. split. auto. exists N. intros.
  destruct (Cauchy_exists _ HA n) as [qa Hqa],
           (Cauchy_exists _ HB n) as [qb Hqb],
           (Cauchy_exists _ HC n) as [qc Hqc].
  assert (E: q == (qb + qc) - (qa + qc)).
    { apply H1.
      - intros. rewrite (Cauchy_unique _ HC _ _ _ Hqc H3).
        rewrite (Cauchy_unique _ HB _ _ _ Hqb H2). reflexivity.
      - intros. rewrite (H2 _ _ Hqa Hqc). reflexivity. }
  assert (E1: (qb + qc) - (qa + qc) == qb - qa) by ring.
  apply (H n). auto. intros.
  rewrite <- (Cauchy_unique _ HB _ _ _ Hqb H2).
  assert (E3: q2 == - qa) by auto. rewrite E3.
  rewrite E. rewrite E1. reflexivity.
Qed.

Theorem Rlt_mult_r: forall (A B C:Real),  (Rpositive C) ->(A < B)%R -> (A*C < B*C)%R.
Proof. intros. destruct A as [A HA], B as [B HB], C as [C HC]. hnf in *.
  unfold Rminus in *. unfold Rplus in *. unfold CauchySeqPlus in *.
  unfold Ropp in *. unfold Cauchy_opp in *. unfold Rmult in *.
  unfold CauchySeqMult in *. destruct H as [eps1 [Heps1 [N1 H1]]].
  destruct H0 as [eps2 [Heps2 [N2 H2]]].
  destruct (take_max_N N1 N2 _ _ H1 H2) as [N H]. clear H1 H2 N1 N2.
  exists (eps2*eps1). split.
  { rewrite <- (Qmult_0_l eps1). apply (Qmult_lt_r). auto. auto. }
  exists N. intros n Hn q H0. destruct (H _ Hn) as [H1 H2]. clear H.
  destruct (Cauchy_exists _ HA n) as [qa Hqa],
           (Cauchy_exists _ HB n) as [qb Hqb],
           (Cauchy_exists _ HC n) as [qc Hqc].
  assert (E1: q == qb*qc - qa*qc).
  { apply H0.
    - intros. rewrite (Cauchy_unique _ HC _ _ _ Hqc H3).
      rewrite (Cauchy_unique _ HB _ _ _ Hqb H). reflexivity.
    - intros. rewrite (H _ _ Hqa Hqc). reflexivity. }
  assert (E2: qb*qc - qa*qc == (qb-qa)*qc) by ring.
  assert (E3: eps2 <= qb -qa).
  { apply H2. intros. rewrite (H3 _ Hqa).
    rewrite (Cauchy_unique _ HB _ _ _ Hqb H). reflexivity. }
  assert (E4: eps1 <= qc).
  { apply H1. auto. }
  rewrite E1,E2. apply Qmult_le_compat_nonneg.
  apply Qlt_le_weak. auto.
  apply Qlt_le_weak. auto.
  auto. auto.
Qed.

Instance Rlt_comp : Proper (Real_equiv ==> Real_equiv ==> iff) Rlt.
Proof. split.
- intros. unfold Rlt. assert (E1: (y0 - y==x0 - x)%R).
  rewrite <- H. rewrite H0. reflexivity.
  unfold Rlt in H1. rewrite E1. apply H1.
- intros. unfold Rlt. assert (E1: (y0 - y ==x0 - x)%R).
  rewrite <- H. rewrite H0. reflexivity.
  unfold Rlt in H1. rewrite <- E1. apply H1.
Qed.

Lemma Rlt_mult_l: forall (A B C:Real),  (Rpositive C) ->(A < B)%R -> (C*A< C*B)%R.
Proof. intros. rewrite (Rmult_comm C A). rewrite (Rmult_comm C B). apply Rlt_mult_r.
  auto. auto.
Qed.

Definition Rle (a b:Real) : Prop :=
  (a < b)%R \/ (a == b)%R.
Notation "a <= b" := (Rle a b):Real_scope.
Definition Rgt (a b:Real) : Prop :=
  (b < a)%R.
Notation "a > b" := (Rgt a b):Real_scope.
Definition Rge (a b:Real) : Prop :=
  (b <= a)%R.
Notation "a >= b" := (Rge a b):Real_scope.

Instance Rle_comp: Proper (Real_equiv ==> Real_equiv ==> iff) Rle.
Proof. split.
- intros. hnf. hnf in H1. destruct H1.
  left. rewrite <- H0. rewrite <- H. auto.
  right. rewrite <-H. rewrite <- H0. auto.
- intros. hnf. hnf in H1. destruct H1.
  left. rewrite H. rewrite H0. auto.
  right. rewrite H,H0. auto.
Qed.
Instance Rgt_comp: Proper (Real_equiv ==> Real_equiv ==> iff) Rgt.
Proof. split.
- intros. unfold Rgt in *. rewrite <-H,<-H0. auto.
- intros. unfold Rgt in *. rewrite H,H0. auto.
Qed.

Theorem Rpositive_gt_0: forall x, Rpositive x <-> (0<x)%R.
Proof. intros. destruct x as [A HA]. split.
  hnf in *. intros.
  destruct H as [eps [Heps [N HN]]]. exists eps. split. auto.
  exists N. unfold Rminus. unfold Ropp. unfold Cauchy_opp.
  unfold Rzero. unfold Rplus. unfold CauchySeqPlus.
  intros. destruct (Cauchy_exists _ HA n) as [qa Hqa].
  assert (E: q == qa).
  { rewrite <- (Qplus_0_r qa). apply H0. auto. intros. rewrite H1. reflexivity. }
  rewrite E. apply (HN n). auto. auto.
  intros. hnf in *.
  destruct H as [eps [Heps [N HN]]]. exists eps. split. auto.
  exists N. unfold Rminus in *. unfold Ropp in *. unfold Cauchy_opp in *.
  unfold Rzero in *. unfold Rplus in *. unfold CauchySeqPlus in *.
  intros. destruct (Cauchy_exists _ HA n) as [qa Hqa].
  apply (HN n). auto. intros. rewrite (H2 0).
  rewrite (Cauchy_unique _ HA _ _ _ H0 H1).
  ring. ring.
Qed.

Theorem Rnegative_lt_0: forall x, Rnegative x <-> (x<0)%R.
Proof. intros. destruct x as [A HA]. split. hnf in *. intros.
  destruct H as [eps [Heps [N HN]]]. exists eps. split. auto.
  exists N. unfold Rminus. unfold Ropp in *. unfold Cauchy_opp in *.
  unfold Rzero. unfold Rplus. unfold CauchySeqPlus.
  intros. destruct (Cauchy_exists _ HA n) as [qa Hqa].
  assert (E:q == -qa).
  { rewrite <- (Qplus_0_l (- qa)). apply H0. reflexivity. intros.
    rewrite (Cauchy_unique _ HA _ _ _ Hqa H1). reflexivity. }
  rewrite E. apply (HN n). auto. intros. rewrite (Cauchy_unique _ HA _ _ _ Hqa H1).
  reflexivity.
  intros. hnf in *.
  destruct H as [eps [Heps [N HN]]]. exists eps. split. auto.
  exists N. unfold Rminus in *. unfold Ropp in *. unfold Cauchy_opp in *.
  unfold Rzero in *. unfold Rplus in *. unfold CauchySeqPlus in *.
  intros. apply (HN n). auto. intros. rewrite H1.
  destruct (Cauchy_exists _ HA n) as [qa Hqa].
  rewrite (H0 qa). rewrite (H2 qa). ring. auto. auto.
Qed.

Theorem Ropp_lt_compat: forall x y, (x<y)%R -> (-y < -x)%R.
Proof. intros.
  assert (E1: (x + -(x + y) <y + -(x + y))%R).
  { apply Rlt_plus_r. auto. }
  assert (E2: (x + -(x + y) == -y)%R).
  { rewrite Ropp_plus_distr. rewrite <- Rplus_assoc. rewrite Rplus_opp_r. rewrite Rplus_comm.
    rewrite Rplus_Zero. reflexivity. }
  assert (E3: (y + -(x + y) == -x)%R).
  { rewrite Ropp_plus_distr. rewrite <- Rplus_comm. rewrite Rplus_assoc. rewrite <- (Rplus_comm y).
    rewrite Rplus_opp_r. rewrite Rplus_Zero. reflexivity. }
  rewrite <- E3. rewrite <- E2. apply E1.
Qed.

Theorem Rzero_opp_zero: (0==-0)%R.
Proof. hnf. unfold Cauchy_opp.
  intros. exists O. intros.
  rewrite H1. rewrite (H2 _ H1). rewrite H1.
  apply H.
Qed.

Theorem Rplus_lt_compat: forall x y z, (x<y <-> x+z < y+z)%R.
Proof. intros. unfold Rlt in *.
  assert (E: (y + z - (x + z) == y - x)%R).
  { unfold Rminus. rewrite (Ropp_plus_distr x z).
    rewrite (Rplus_assoc). rewrite (Rplus_comm (-x) (-z)).
    rewrite <- (Rplus_assoc z (-z)). rewrite Rplus_opp_r.
    rewrite Rplus_0_l. reflexivity. }
  rewrite E. split. auto. auto.
Qed.

Theorem Rnot_lt (x y:Real): (~(x<y) -> (x==y)\/(x>y))%R.
Proof. intros. unfold Rlt in *. apply Rnot_positive in H.
  destruct H.
  - right. apply Rnegative_lt_0 in H. apply (Rplus_lt_compat _ 0 x) in H.
    rewrite Rplus_0_l in H. unfold Rminus in H. rewrite Rplus_assoc in H.
    rewrite (Rplus_comm _ x) in H. rewrite (Rplus_opp_r) in H. rewrite Rplus_0_r in H.
    auto.
  - left. rewrite <- Rplus_0_l. rewrite <- H. unfold Rminus. rewrite Rplus_assoc.
    rewrite (Rplus_comm _ x). rewrite Rplus_opp_r. rewrite Rplus_0_r. reflexivity.
Qed.

Lemma Rpositive_Ropp (A:Real): Rpositive A -> Rnegative (Ropp A).
Proof. intros. destruct A as [A HA]. hnf in *. unfold Ropp.
  unfold Cauchy_opp. destruct H as [eps [Heps [N H]]].
  exists eps. split. auto. exists N. intros.
  apply (H _ H0). destruct (Cauchy_exists _ HA n) as [qa Hqa].
  assert (E: q == qa). { rewrite <- (Qopp_involutive qa). apply H1.
  intros. rewrite (Cauchy_unique _ HA _ _ _ Hqa H2). reflexivity. }
  rewrite E. auto.
Qed.

Lemma Rnegative_Ropp (A:Real): Rnegative A -> Rpositive (Ropp A).
Proof. intros. destruct A as [A HA]. auto.
Qed.

Lemma Ropp_mult_distr : forall A B, (- (A * B) == (- A) * B)%R.
Proof. intros. destruct A as [A HA],B as [B HB]. hnf. intros.
  exists O. intros. unfold Cauchy_opp in *. unfold CauchySeqMult in *.
  destruct (Cauchy_exists _ HA m) as [qa Hqa].
  destruct (Cauchy_exists _ HB m) as [qb Hqb].
  assert (E1: q1 == - (qa*qb)). { apply H1. intros.
    rewrite (Cauchy_unique _ HA _ _ _ Hqa H3).
    rewrite (Cauchy_unique _ HB _ _ _ Hqb H4).
    reflexivity. }
  assert (E2: q2 == - qa*qb). { apply H2. intros.
    rewrite (Cauchy_unique _ HA _ _ _ Hqa H3). reflexivity.
    auto. }
  assert (E3: q1 - q2 == 0). { rewrite E1. rewrite E2. ring. }
  rewrite E3. apply H.
Qed.

Lemma Rlt_irrefl: forall A, ~(A<A)%R.
Proof. intros. intros C. hnf in C. destruct C as [eps [Heps H]].
  destruct H as [N HN].
  pose proof (HN N (le_refl N) 0).
  assert (foo: eps <=0). { apply H. unfold Rminus. unfold Rplus. unfold Ropp.
    unfold Cauchy_opp. unfold CauchySeqPlus. destruct A.
    intros. pose proof (H2 _ H1). rewrite H3. ring. }
  apply Qle_not_lt in foo. contradiction.
Qed.

Theorem Rnot_lt_le: forall A B, (~(A<B)<->(A>=B))%R.
Proof. intros. split.
- intros. unfold Rlt in H. apply Rnot_positive in H. unfold Rnegative in H.
  assert (Et: (-(B-A) == A - B)%R). { unfold Rminus. rewrite Ropp_plus_distr.
    rewrite <- Ropp_involutive. rewrite Rplus_comm. reflexivity. }
  rewrite Et in H. unfold Rge. unfold Rle. destruct H.
  + left. unfold Rgt. auto.
  + right. rewrite <- (Rplus_0_l A). rewrite <- H. unfold Rminus. rewrite Rplus_assoc.
    rewrite (Rplus_comm _ A). rewrite Rplus_opp_r. rewrite Rplus_0_r. reflexivity.
- intros. hnf in H. destruct H.
  assert (Et: (-(A-B) == B - A)%R). { unfold Rminus. rewrite Ropp_plus_distr.
  rewrite <- Ropp_involutive. rewrite Rplus_comm. reflexivity. }
  + unfold Rlt in H. apply Rpositive_not_negative in H. intros C. apply H.
    unfold Rnegative.
    rewrite Et. auto.
  + rewrite H. apply Rlt_irrefl.
Qed.

Theorem Rnot_le_lt: forall A B, (~(A<=B) <-> (A >B))%R.
Proof. intros. split.
- intros. unfold Rle in H. apply not_or_and in H. destruct H.
  unfold Rlt in H. apply Rnot_positive in H. destruct H.
  * unfold Rgt. apply Rnegative_Ropp in H.
    assert (-(B-A)==A-B)%R by ring. rewrite H1 in H. auto.
  * assert (B==A)%R. { rewrite <-(Rplus_0_r A). rewrite <- H. ring. }
    symmetry in H1. contradiction.
- intros. unfold Rle. apply and_not_or. unfold Rgt in H. split.
  * apply Rpositive_not_negative in H. intros C. apply H.
    assert (A-B==-(B-A))%R by ring. rewrite H0. apply Rpositive_Ropp. auto.
  * apply Rpositive_not_zero in H. intros C. apply H. rewrite C. ring.
Qed.

Lemma Rlt_le_weak : forall A B, (A < B -> A <= B)%R.
Proof. intros. unfold Rle. left. auto.
Qed.

Lemma Rle_refl: forall A, (A<=A)%R.
Proof. intros. right. reflexivity.
Qed.

Lemma Rle_trans : forall x y z, (x<=y -> y<=z -> x<=z)%R.
Proof. intros. destruct H,H0.
- apply Rlt_le_weak. apply (Rlt_trans _ y).
  auto. auto.
- rewrite <- H0. apply Rlt_le_weak. auto.
- rewrite H. apply Rlt_le_weak. auto.
- rewrite H,H0. apply Rle_refl.
Qed.

Lemma Rle_lt_trans : (forall x y z, x<=y -> y<z -> x<z)%R.
Proof. intros. destruct H.
- apply (Rlt_trans _ y).
  auto. auto.
- rewrite H. auto.
Qed.

Lemma Rlt_le_trans : forall x y z, (x<y -> y<=z -> x<z)%R.
Proof. intros. destruct H0.
- apply (Rlt_trans _ y).
  auto. auto.
- rewrite <- H0. auto.
Qed.

Lemma Rinv_lt_0_compat' A (H:Rpositive A): Rpositive (/(exist _ A (Rpositive_not_zero _ H))).
Proof. hnf. hnf in H. destruct H as [eps [Heps [N HN]]].
  destruct A as [A HA].
  destruct (CauchySeqBounded _ HA) as [M [HM H2]]. unfold Rinv.
 exists (/M). split.
  - apply Qinv_lt_0_compat. auto.
  - exists N. intros. pose proof (HN _ H _ H0).
    pose proof (Qlt_le_trans _ _ _ Heps H1).
    pose proof (H2 _ _ H0).
    rewrite (Qabs_pos _ (Qlt_le_weak _ _ H3)) in H4.
    apply Qlt_le_weak.
    assert ( /q*M >0). {
      rewrite <- (Qmult_0_r (/q)). apply Qmult_lt_l. auto. auto. }
    apply (proj1 (Qmult_lt_r _ _ _ H5)).
    assert (Et1: / M * (/ q * M)==/q).
      { field. split. intros C. rewrite C in H3. apply Qlt_irrefl in H3. auto.
        intros C. rewrite C in HM. apply Qlt_irrefl in HM. auto. }
    assert (Et2: q * (/ q * M) == M).
      { field. intros C. rewrite C in H3. apply Qlt_irrefl in H3. auto. }
    rewrite Et1,Et2. auto.
Qed.

Lemma Rinv_lt_0_compat A (H0: ~(A==0)%R): Rpositive A
  -> Rpositive (/(exist _ A H0)).
Proof. intros H. hnf. hnf in H. destruct H as [eps [Heps [N HN]]].
  destruct A as [A HA].
  destruct (CauchySeqBounded _ HA) as [M [HM H2]]. unfold Rinv.
 exists (/M). split.
  - apply Qinv_lt_0_compat. auto.
  - exists N. intros. pose proof (HN _ H _ H1).
    pose proof (Qlt_le_trans _ _ _ Heps H3).
    pose proof (H2 _ _ H1).
    rewrite (Qabs_pos _ (Qlt_le_weak _ _ H4)) in H5.
    apply Qlt_le_weak.
    assert ( /q*M >0). {
      rewrite <- (Qmult_0_r (/q)). apply Qmult_lt_l. auto. auto. }
    apply (proj1 (Qmult_lt_r _ _ _ H6)).
    assert (Et1: / M * (/ q * M)==/q).
      { field. split. intros C. rewrite C in H4. apply Qlt_irrefl in H4. auto.
        intros C. rewrite C in HM. apply Qlt_irrefl in HM. auto. }
    assert (Et2: q * (/ q * M) == M).
      { field. intros C. rewrite C in H4. apply Qlt_irrefl in H4. auto. }
    rewrite Et1,Et2. auto.
Qed.

Lemma Rlt_mult_compat_r:
  forall A B C : Real, Rpositive C -> (A*C < B*C)%R -> (A < B )%R.
Proof. intros.
  pose proof (Rpositive_not_zero _ H).
  apply (Rlt_mult_r _ _ (/(exist _ C H1)) (Rinv_lt_0_compat C H1 H)) in H0.
  rewrite Rmult_assoc in H0. rewrite Rmult_inv_r' in H0.
  rewrite Rmult_assoc in H0. rewrite Rmult_inv_r' in H0.
  repeat rewrite Rmult_1_r in H0. auto.
Qed.

Lemma Rlt_plus_compat_r:
  forall A B C : Real, (A+C < B+C)%R -> (A < B )%R.
Proof. intros.
  apply (Rlt_plus_r _ _ (-C)) in H.
  repeat rewrite Rplus_assoc in H.
  repeat rewrite Rplus_opp_r in H.
  repeat rewrite Rplus_0_r in H.
  auto.
Qed.

Lemma Rle_mult_compat_r:
  forall A B C : Real, Rpositive C -> (A*C <= B*C)%R -> (A <= B )%R.
Proof. intros. destruct H0.
- left. apply Rlt_mult_compat_r in H0. auto. auto.
- right. pose proof (Rpositive_not_zero _ H).
  apply (Rmult_inj_r_suff _ _ (/(exist _ C H1))) in H0.
  repeat rewrite Rmult_assoc in H0.
  repeat rewrite Rmult_inv_r' in H0.
  repeat rewrite Rmult_1_r in H0.
  auto.
Qed.

Lemma Rle_plus_compat_r:
  forall A B C : Real, (A+C <= B+C)%R -> (A <= B )%R.
Proof. intros. destruct H.
- left.
  apply (Rlt_plus_r _ _ (-C)) in H.
  repeat rewrite Rplus_assoc in H.
  repeat rewrite Rplus_opp_r in H.
  repeat rewrite Rplus_0_r in H. auto.
- right. apply (Rplus_inj_r _ _ C). auto.
Qed.

Lemma Rle_plus_r:
  forall A B C : Real, (A<= B)%R -> (A+C <= B+C )%R.
Proof. intros. destruct H.
- left.
  apply (Rlt_plus_r _ _ (C)) in H. auto.
- right. apply (Rplus_inj_r _ _ C). auto.
Qed.

Lemma Ropp_le_compat : forall A B, (A <= B <-> -B <= -A)%R.
Proof. intros. split.
  - intros. apply (Rle_plus_r _ _ (-A-B)) in H.
    assert (A + (- A - B)==-B)%R by ring.
    assert (B + (- A - B) == -A)%R by ring.
    rewrite H0 in H. rewrite H1 in H. auto.
  - intros. apply (Rle_plus_r _ _ (A+B)) in H.
    assert (-A + (A +B)==B)%R by ring.
    assert (-B + ( A + B) == A)%R by ring.
    rewrite H0 in H. rewrite H1 in H. auto.
Qed.

Lemma Rlt_plus_l: forall A B C : Real, (A < B)%R -> (C + A < C + B)%R.
Proof. intros. repeat rewrite (Rplus_comm C).
  apply (Rlt_plus_r _ _ C). auto.
Qed.

Lemma Rlt_plus_compat: forall A B C D, (A < B -> C < D -> A + C < B + D)%R.
Proof. intros. apply (Rlt_trans _ (A+D)).
  apply Rlt_plus_l. auto.
  apply Rlt_plus_r. auto.
Qed.

Lemma Rle_plus_l: forall A B C: Real, (A<=B)%R -> (C+A <= C+B)%R.
Proof. intros. destruct H.
  - left. apply (Rlt_plus_l _ _ C). auto.
  - right. rewrite H. reflexivity.
Qed.

Lemma Rle_lt_plus_compat: forall A B C D, (A <= B -> C < D -> A + C < B + D)%R.
Proof. intros. apply (Rlt_le_trans _ (A+D)).
  apply Rlt_plus_l. auto.
  apply Rle_plus_r. auto.
Qed.

Lemma Rlt_le_plus_compat: forall A B C D, (A < B -> C <= D -> A + C < B + D)%R.
Proof. intros. apply (Rle_lt_trans _ (A+D)).
  apply Rle_plus_l. auto.
  apply Rlt_plus_r. auto.
Qed.

Lemma Qlt_Rlt:
  forall q1 q2 : Q, (inject_Q q1 < inject_Q q2)%R <-> q1 < q2.
Proof. split.
- intros. hnf in H.
  hnf in H. repeat destruct H as [eps [Heps [N HN]]].
  pose proof (HN N (le_refl _) (q2-q1)).
  unfold Rminus in H. unfold Ropp in H. unfold inject_Q in H.
  unfold Rplus in H. unfold CauchySeqPlus in H.
  unfold Cauchy_opp in H.
  assert (eps<=q2-q1). { apply H. intros. rewrite H0. rewrite (H1 q1). reflexivity. reflexivity. }
  apply Qlt_minus_iff. apply (Qlt_le_trans _ _ _ Heps H0).
- intros.  hnf.
  exists (q2-q1). split. apply (proj1 (Qlt_minus_iff _ _)). auto.
  exists O. intros. hnf in H1. unfold Cauchy_opp in H1.
  rewrite (H1 q2 (-q1)). apply Qle_refl. reflexivity. intros.
  rewrite H2. reflexivity.
Qed.

Lemma Qle_Rle:
  forall q1 q2 : Q, (inject_Q q1 <= inject_Q q2)%R <-> q1 <= q2.
Proof. split.
- intros. apply Qle_lteq. hnf in H.
  destruct H.
  + left. apply Qlt_Rlt. auto.
  + right. auto using inject_Q_eq_inv.
- intros. apply Qle_lteq in H. destruct H.
  + left. apply Qlt_Rlt. auto.
  + right. rewrite H. reflexivity.
Qed.

Theorem inject_Q_lt_inv: forall q1 q2, (inject_Q q1 < inject_Q q2)%R <-> q1 < q2.
Proof. intros. split.
- intros. hnf in H.
  destruct (classic (q1 < q2)). auto.
  assert (E':q2 - q1>0).
  { destruct H. destruct H. destruct H1.
    apply (Qlt_le_trans _ x). auto. apply (H1 x0).
    omega. hnf. unfold Cauchy_opp. intros.
    rewrite H2. rewrite (H3 q1). reflexivity. reflexivity. }
  apply (Qplus_lt_r _ _ q1) in E'.
  assert (Et: q1 + (q2 - q1) == q2) by ring.
  rewrite Et in E'.
  rewrite Qplus_0_r in E'. auto.
- intros. hnf. exists (q2 - q1). split.
  { apply (Qplus_lt_r _ _ q1). rewrite Qplus_0_r.
    assert (Et: q1 + (q2 - q1) == q2) by ring.
    rewrite Et. auto. }
  exists O. intros. hnf in H1.
  rewrite (H1 q2 (-q1)). apply Qle_refl.
  reflexivity. hnf. intros. rewrite H2. reflexivity.
Qed.

Lemma inject_Q_Rpositive: forall q, q>0 <-> Rpositive (inject_Q q).
Proof. intros. split.
  - intros. apply Rpositive_gt_0. apply Qlt_Rlt. auto.
  - intros. apply Rpositive_gt_0 in H. apply Qlt_Rlt in H. auto.
Qed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Sebastien Hinderer, 2004-05-20
- Frederic Blanqui, 2005-02-25

polynomials with non-negative integers as coefficients
*)

Set Implicit Arguments.

From CoLoR Require Import Polynom ZUtil LogicUtil NaryFunction VecUtil.
From Coq Require Import List Max Lia.

From CoLoR Require ListUtil.

Notation vec := (vector D).
Notation vals := (@Vmap D Z val _).

Local Open Scope Z_scope.

Lemma pos_meval : forall n (m : monom n) (v : vec n), 0 <= meval m (vals v).

Proof.
induction n; intros; simpl. lia. VSntac m. VSntac v. simpl.
apply Zmult_le_0_compat. apply pos_power. destruct (Vhead v). hyp.
apply IHn.
Qed.

Lemma preserve_pos_meval n (m : monom n) : preserv pos (meval m).

Proof. intros v Hv. rewrite (Vmap_proj1_sig Hv). apply pos_meval. Qed.

Definition meval_D n (m : monom n) := restrict (preserve_pos_meval m).

Definition coef_pos n (p : poly n) := ListUtil.lforall (fun x => 0 <= fst x) p.

Definition bcoef_pos n (p : poly n) := forallb (fun x => is_not_neg (fst x)) p.

Lemma bcoef_pos_ok n (p : poly n) : bcoef_pos p = true <-> coef_pos p.

Proof. apply ListUtil.forallb_lforall. intros [z m]. apply is_not_neg_ok. Qed.

Lemma coef_pos_coef : forall n (p : poly n) m, coef_pos p -> 0 <= coef m p.

Proof.
induction p; intros; simpl. lia. destruct a. simpl in H. destruct H.
case (monom_eq_dec m t); intro. assert (0 <= coef m p). apply IHp. hyp.
lia. apply IHp. hyp.
Qed.

Lemma coef_pos_cons : forall n c (m : monom n) (p : poly n),
  coef_pos ((c,m)::p) -> 0 <= c /\ coef_pos p.

Proof.
unfold coef_pos. intros n c m p. simpl. auto.
Qed.

Lemma coef_pos_app : forall n (p1 p2 : poly n),
  coef_pos (p1 ++ p2) -> coef_pos p1 /\ coef_pos p2.

Proof.
unfold coef_pos. intros n p1 p2. simpl. rewrite ListUtil.lforall_app. intuition.
Qed.

Arguments coef_pos_app [n p1 p2] _.

Lemma coef_pos_mpmult : forall n c (m : monom n) (p : poly n),
  0 <= c -> coef_pos p -> coef_pos (mpmult c m p).

Proof.
induction p; intros; simpl. exact I. destruct a. simpl.
simpl in H0. destruct H0. split. apply Zmult_le_0_compat; hyp.
apply IHp; hyp.
Qed.

Lemma pos_peval : forall n (p : poly n) v, coef_pos p -> 0 <= peval p (vals v).

Proof.
induction p; intros; simpl. lia. destruct a. simpl in H. destruct H.
apply Zplus_le_0_compat. apply Zmult_le_0_compat. hyp.
apply pos_meval. apply IHp. hyp.
Qed.

Lemma preserve_pos_peval : forall n (p : poly n),
  coef_pos p -> preserv pos (peval p).

Proof.
intros. unfold preserv. intros v Hv.
rewrite (Vmap_proj1_sig Hv). apply pos_peval. hyp.
Qed.

Definition peval_D n (p : poly n) (H : coef_pos p) :=
  restrict (preserve_pos_peval p H).

Arguments peval_D [n p] _ _.

Lemma val_peval_D : forall n (p : poly n) (H : coef_pos p) (v : vec n),
  val (peval_D H v) = peval p (vals v).

Proof.
intuition.
Qed.

Lemma coef_pos_mpplus : forall n c (m : monom n) (p : poly n),
  0 <= c -> coef_pos p -> coef_pos (mpplus c m p).

Proof.
induction p; intros; simpl. auto. destruct a. simpl in H0. destruct H0.
case (monom_eq_dec m t); simpl; intuition.
Qed.

Lemma coef_pos_plus : forall n (p1 p2 : poly n),
  coef_pos p1 -> coef_pos p2 -> coef_pos (p1 + p2).

Proof.
induction p1; intros; simpl. hyp. destruct a. simpl in H. destruct H.
apply coef_pos_mpplus. hyp. apply IHp1; hyp.
Qed.

Lemma coef_pos_mult : forall n (p1 p2 : poly n),
  coef_pos p1 -> coef_pos p2 -> coef_pos (p1 * p2).

Proof.
induction p1; intros; simpl. exact I. destruct a. simpl in H. destruct H.
apply coef_pos_plus. apply coef_pos_mpmult; hyp. apply IHp1; hyp.
Qed.

Lemma coef_pos_power : forall k n (p : poly n),
  coef_pos p -> coef_pos (ppower p k).

Proof.
induction k; intros; simpl. intuition. apply coef_pos_mult. hyp.
apply IHk. hyp.
Qed.

Lemma coef_pos_mcomp : forall k n (m : monom n) (ps : vector (poly k) n),
  Vforall (@coef_pos k) ps -> coef_pos (mcomp m ps).

Proof.
induction n; intros; simpl. intuition. VSntac ps. simpl. rewrite H0 in H.
simpl in H. destruct H. apply coef_pos_mult. apply coef_pos_power.
hyp. apply IHn. hyp.
Qed.

Lemma coef_pos_cpmult : forall n c (p : poly n),
  0 <= c -> coef_pos p -> coef_pos (cpmult c p).

Proof.
induction p; intros; simpl. exact I. destruct a. simpl. simpl in H0. intuition.
Qed.

Lemma coef_pos_pcomp : forall n k (p : poly n) (ps : vector (poly k) n),
  coef_pos p -> Vforall (@coef_pos k) ps -> coef_pos (pcomp p ps).

Proof.
induction p; intros; simpl. exact I. destruct a. simpl. simpl in H. destruct H.
apply coef_pos_plus. apply coef_pos_cpmult. hyp. apply coef_pos_mcomp.
hyp. apply IHp; hyp.
Qed.

Lemma coefPos_ge0 : forall n (p : poly n) (m : monom n),
  coef_pos p -> coef m p >= 0.

Proof with auto with zarith.
  induction p. simpl...
  intros. destruct a. simpl.
  destruct (monom_eq_dec m t).
  subst m. apply Zge_trans with (coef t p).
  destruct H. simpl in H...
  apply IHp. destruct H...
  apply IHp. destruct H...
Qed.

Lemma coefPos_geC : forall n (p : poly n) (m : monom n) c,
  coef_pos p -> In (c, m) p -> coef m p >= c.

Proof with auto with zarith.
  induction p. simpl. tauto.
  intros. destruct a. simpl.
  destruct (monom_eq_dec m t). subst m.
  destruct H0. injection H0. intros. subst z.
  destruct H. ded (coefPos_ge0 p t H1)...
  apply Zge_trans with (coef t p).
  simpl in H...
  apply IHp... destruct H...
  destruct H0. congruence.
  apply IHp... destruct H...
Qed.


Require Import Logic.SeparationLogic.Tactics.Language.
Require Export Coq.Lists.List.
Require Import Logic.lib.Coqlib.

Local Open Scope shallow_syntax.
Local Open Scope list_scope.

Inductive expr: Type :=
  | impp : expr -> expr -> expr
  | sepcon : expr -> expr -> expr
  | emp : expr
  | varp : nat -> expr.

Declare Scope deep_syntax.
Local Open Scope deep_syntax.

Notation "x --> y" := (impp x y) (at level 55, right associativity) : deep_syntax.
Notation "x * y" := (sepcon x y) (at level 40, left associativity) : deep_syntax.

Inductive provable: expr -> Prop :=
| modus_ponens: forall x y, provable (x --> y) -> provable x -> provable y
| axiom1: forall x y, provable (x --> (y --> x))
| axiom2: forall x y z, provable ((x --> y --> z) --> (x --> y) --> (x --> z))
| sepcon_emp1: forall x, provable (x * emp --> x)
| sepcon_emp2: forall x, provable (x --> x * emp)
| sepcon_comm_impp: forall x y, provable (x * y --> y * x)
| sepcon_assoc1: forall x y z, provable (x * (y * z) --> (x * y) * z)
| sepcon_mono: forall x1 x2 y1 y2,
    provable (x1 --> x2) -> provable (y1 --> y2) -> provable ((x1 * y1) --> (x2 * y2)).

Notation "|--  x" := (provable x) (at level 71, no associativity) : deep_syntax.

Fixpoint beq e1 e2 :=
  match e1, e2 with
  | emp, emp => true
  | varp x, varp y => EqNat.beq_nat x y
  | sepcon p11 p12, sepcon p21 p22 => andb (beq p11 p21) (beq p12 p22)
  | impp p11 p12, impp p21 p22 => andb (beq p11 p21) (beq p12 p22)
  | _, _ => false
  end.

Ltac length_cont ls k :=
  match ls with
  | nil => k O
  | _ :: ?ls' => length_cont ls' ltac:(fun n => k (S n))
  end.
Ltac length ls := length_cont ls ltac:(fun l => l).

Ltac pred n :=
  match n with
  | O => O
  | S ?m => m
  end.

(*
Definition rev (l: list nat): list nat :=
  (fix rev (l: list nat) (cont: list nat -> list nat): list nat :=
    match l with
    | nil => cont nil
    | a :: l0 => rev l0 (fun l => a :: cont l)
    end) l (fun l => l).
*)

Ltac reverse_cont l k :=
  match l with
  | @nil ?T => k (@nil T)
  | @cons _ ?h ?t =>
    let k' l :=
        let t' := k l in
        constr:(cons h t')
    in reverse_cont t k'
  end.
Ltac reverse l := reverse_cont l ltac:(fun l => l).

Ltac search_expr' n i l l0 :=
  match l with
  | nil => let len := length l0 in constr:((S len, n :: l0))
  | n :: ?t => constr:((i, l0))
  | _ :: ?t => let pi := pred i in search_expr' n pi t l0
  end.
Ltac search_expr n l := let len := length l in search_expr' n len l l.

Fixpoint reflect (e : expr) (tbl : list Language.expr) (default : Language.expr) : Language.expr :=
    match e with
    | varp n => nth (pred n) tbl default
    | sepcon e1 e2 => Language.sepcon (reflect e1 tbl default) (reflect e2 tbl default )
    | impp e1 e2 => Language.impp (reflect e1 tbl default) (reflect e2 tbl default)
    | emp => Language.emp
    end.

Ltac shallowTodeep' se l0 :=
  match se with
  | Language.sepcon ?sp ?sq =>
    match shallowTodeep' sp l0 with
    | (?dp, ?l1) =>
      match shallowTodeep' sq l1 with
      | (?dq, ?l2) => constr:((sepcon dp dq, l2))
      end
    end
  | Language.impp ?sp ?sq =>
    match shallowTodeep' sp l0 with
    | (?dp, ?l1) =>
      match shallowTodeep' sq l1 with
      | (?dq, ?l2) => constr:((impp dp dq, l2))
      end
    end
  | Language.emp => constr:((emp, l0))
  | ?sp => match search_expr sp l0 with
          | (?i, ?l1) => constr:((varp i, l1))
          end
  end.
Ltac shallowTodeep se :=
match shallowTodeep' se constr:(@nil Language.expr) with
  | (?de, ?tbl) =>
    let tbl' := reverse tbl in
    assert (reflect de tbl' se = se) by reflexivity
end.

Theorem reify_sound : forall (e : expr) table (default: Language.expr),
  provable e -> Language.provable (reflect e table default).
Admitted.

Theorem abstract_sound : forall (e' : expr) table (default: Language.expr),
  Language.provable (reflect e' table default) -> provable e'.
Admitted.

Definition flatten_imp (e : expr) : list expr * expr :=
    match e with
    | impp p q => (p :: nil, q)
    | _ => (nil, e)
    end.

Fixpoint flatten_sepcon (e : expr) : list expr :=
    match e with
    | sepcon p q => (flatten_sepcon p ++ flatten_sepcon q)
    | s => s :: nil
    end.

Definition flatten (e : expr) : list expr * list expr :=
   let (ctx, r) := flatten_imp e in
   (List.flat_map flatten_sepcon ctx, flatten_sepcon r).

(*
Definition all_in_context e :=
  let (es, rs) := flatten e in forallb (fun r => existsb (beq r) es) rs.
*)

Fixpoint cancel_deep_context es r : (list expr) * bool:=
  match es with
  | nil => (nil, false)
  | e :: et =>
    match (beq e r) with
    | true => (et, true)
    | false => let (et', isfind) := cancel_deep_context et r in (e :: et', (false || isfind)%bool)
    end
  end.

Fixpoint cancel_deep es rs : list expr * list expr:=
  match rs with
  | nil => (es, nil)
  | r :: rt =>
    match (cancel_deep_context es r) with
    | (es', true) => (cancel_deep es' rt)
    | (es', false) => let (es'', rt'') := cancel_deep es' rt in (es'', r :: rt'')
    end
  end.

Fixpoint unflatten_sepcon' et e : expr :=
  match et with
  | nil => e
  | ep :: et0 => unflatten_sepcon' et0 (sepcon e ep)
  end.

Definition unflatten_sepcon le : expr :=
  match le with
  | nil => emp
  | e :: et => unflatten_sepcon' et e
  end.

Definition unflatten (es rs : list expr) : expr:=
  impp (unflatten_sepcon es) (unflatten_sepcon rs).

Lemma cancel_solver_sound : forall e e' es rs es' rs',
  (es, rs) = flatten e ->
  (es', rs') = cancel_deep es rs ->
  e' = unflatten es' rs' ->
  provable e' ->
  provable e.
Admitted.

Ltac cancel_solver' se :=
  match shallowTodeep' se constr:(@nil Language.expr) with
    | (?de, ?tbl) =>
      let tbl' := reverse tbl in
      let p := eval compute in (flatten de) in
      let es := eval compute in (fst p) in
      let rs := eval compute in (snd p) in
      let p' := eval compute in (cancel_deep es rs) in
      let es' := eval compute in (fst p') in
      let rs' := eval compute in (snd p') in
      let de' := eval compute in (unflatten es' rs') in
      assert (@eq Language.expr (reflect de tbl' se) (se)) as ReflectH by reflexivity;
      assert (@eq (list expr * list expr) (es, rs) (flatten de)) as FlattenH by reflexivity;
      assert (@eq (list expr * list expr) (es', rs') (cancel_deep es rs)) as CancelH by reflexivity;
      assert (@eq expr de' (unflatten es' rs')) as UnflattenH by reflexivity;
      apply (reify_sound de tbl' se);
      apply (cancel_solver_sound de de' es rs es' rs');
      [ apply FlattenH
      | apply CancelH
      | apply UnflattenH
      | ];
    match goal with
        | [|- provable ?dr] =>
          apply (abstract_sound dr tbl' se);
          let rfl := eval compute in (reflect dr tbl' se) in change (Language.provable rfl)
    end;
    try apply Language.provable_emp_refl;
    clear ReflectH FlattenH CancelH UnflattenH
  end.

Ltac cancel_solver :=
    match goal with
    | [|- Language.provable ?se] => cancel_solver' se
    end.

Section temp.
Parameter (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z: Language.expr).
Local Open Scope shallow_syntax.

Lemma foo: forall P, P /\ P -> P.
Proof. intros. tauto. Qed.

Goal |-- (W --> T) * U --> S * V -> |-- (W --> T) * U * (V --> W) * (P * Q) * T --> T * S * V * Q * P * (V --> W).
  intros.
  cancel_solver.
  auto.
  Qed.

Goal
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L)
--> (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G).
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_solver;
  auto.
  Time
  Qed.

Goal
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L)
--> (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G) *
    (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G).
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_solver;
  auto.
  Time
  Qed.

Goal
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L)
--> (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G) *
    (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G) *
    (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G).
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_solver;
  auto.
  Time
  Qed.

Goal
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    (M * (N * O) * P) * (Q * R * S) * T * (U * V) * W * X
--> (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G) *
    (M * X * (N * W) * O) * P * Q * (T * S) * (V * R * U).
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_solver;
  auto.
  Time
  Qed.

Goal
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    (M * (N * O) * P) * (Q * R * S) * T * (U * V) * W * X *
    (M * (N * O) * P) * (Q * R * S) * T * (U * V) * W * X *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L)
--> (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G) *
    (M * X * (N * W) * O) * P * Q * (T * S) * (V * R * U) *
    (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G) *
    (M * X * (N * W) * O) * P * Q * (T * S) * (V * R * U).
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_solver;
  auto.
  Time
  Qed.

Goal
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    (M * (N * O) * P) * (Q * R * S) * T * (U * V) * W * X *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    (M * (N * O) * P) * (Q * R * S) * T * (U * V) * W * X *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    (M * (N * O) * P) * (Q * R * S) * T * (U * V) * W * X
--> (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G) *
    (M * X * (N * W) * O) * P * Q * (T * S) * (V * R * U) *
    (M * X * (N * W) * O) * P * Q * (T * S) * (V * R * U) *
    (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G) *
    (I * J * (D * K) * L) * A * B * (C * H) * (E * F * G) *
    (M * X * (N * W) * O) * P * Q * (T * S) * (V * R * U).
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_solver;
  auto.
  Time
  Qed.

Goal
|-- A * B * C * D --> M * N * O * E ->
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L)
--> I * J * (G * E) * (F * M * N) * (O * (L * K * E) * H).
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_solver;
  auto.
  Time
  Qed.

Goal
|-- A * B * C * D * A * B * C * D
--> M * N * O * E * M * N * O * E ->
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L)
--> I * J * (G * E) * (F * M * N) * (O * (L * K * E) * H) *
    I * J * (G * E) * (F * M * N) * (O * (L * K * E) * H).
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_solver;
  auto.
  Time
  Qed.

Goal
|-- A * B * C * D * A * B * C * D * A * B * C * D
--> M * N * O * M * N * O * E * E * M * N * O * E ->
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L)
--> I * J * (G * E) * (F * M * N) * (O * (L * K * E) * H) *
    I * J * (G * E) * (F * M * N) * (O * (L * K * E) * H) *
    I * J * (G * E) * (F * M * N) * (O * (L * K * E) * H).
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_solver;
  auto.
  Time
  Qed.

Goal
|-- A * B * C * D * E * F * G * H --> S * T * Q * X * U * V * W * R ->
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) * (M * (N * O) * P)
--> (P * (I * J * (S * T)) * Q) * X * (U * M * N) * (O * (L * K * V) * W) * R.
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_solver;
  auto.
  Time
  Qed.

Goal
|-- A * B * C * D * E * F * G * H * A * B * C * D * E * F * G * H
--> S * T * Q * X * U * V * W * R * S * T * Q * X * U * V * W * R ->
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) * (M * (N * O) * P) *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) * (M * (N * O) * P)
--> (P * (I * J * (S * T)) * Q) * X * (U * M * N) * (O * (L * K * V) * W) * R *
    (P * (I * J * (S * T)) * Q) * X * (U * M * N) * (O * (L * K * V) * W) * R.
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_solver;
  auto.
  Time
  Qed.

Goal
|-- A * B * C * D * E * F * G * H * A * B * C * D * E * F * G * H * A * B * C * D * E * F * G * H
--> S * T * Q * X * U * V * W * R * S * T * Q * X * U * V * W * R * S * T * Q * X * U * V * W * R ->
|-- A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) * (M * (N * O) * P) *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) * (M * (N * O) * P) *
    A * B * (C * D) * (E * F * (G * H)) * (I * J * K * L) * (M * (N * O) * P)
--> (P * (I * J * (S * T)) * Q) * X * (U * M * N) * (O * (L * K * V) * W) * R *
    (P * (I * J * (S * T)) * Q) * X * (U * M * N) * (O * (L * K * V) * W) * R *
    (P * (I * J * (S * T)) * Q) * X * (U * M * N) * (O * (L * K * V) * W) * R.
  intros.
  Time
  apply foo; split;
    apply foo; split;
      apply foo; split;
  cancel_solver;
  auto.
  Time
  Qed.

End temp.


(** * Kripke Semantics *)

Require Export ND.
Require Export GenTarski.

(** ** Kripke Models *)

Section Kripke.
  Context {Sigma : Signature}.

  Section Model.
    Variable domain : Type.

    Class kmodel :=
      {
        nodes : Type ;

        reachable : nodes -> nodes -> Prop ;
        reach_refl u : reachable u u ;
        reach_tran u v w : reachable u v -> reachable v w -> reachable u w ;

        k_interp : interp domain ;
        k_P : nodes -> forall P : Preds, Vector.t domain (pred_ar P) -> Prop ;
        k_Bot : nodes -> Prop ;

        mon_P : forall u v, reachable u v -> forall P (t : Vector.t domain (pred_ar P)), k_P u t -> k_P v t;
        mon_Bot : forall u v, reachable u v -> k_Bot u -> k_Bot v
      }.

    Variable M : kmodel.

    Fixpoint ksat u (rho : fin -> domain) (phi : form) : Prop :=
      match phi with
      | Pred P v => k_P u (Vector.map (@eval _ _ k_interp rho) v)
      | Fal => k_Bot u
      | Impl phi psi => forall v, reachable u v -> ksat v rho phi -> ksat v rho psi
      | All phi => forall j : domain, ksat u (j .: rho) phi
      end.

    Global Instance kmodel_reach_refl : Reflexive reachable := reach_refl.
    Global Instance kmodel_reach_trans : Transitive reachable := reach_tran.

    Lemma ksat_mon (u : nodes) (rho : fin -> domain) (phi : form) :
      forall v (H : reachable u v), ksat u rho phi -> ksat v rho phi.
    Proof.
      revert rho. induction phi; intros rho v H; cbn; intuition; eauto using mon_P, mon_Bot, reach_tran.
    Qed.

    Lemma ksat_iff u rho phi :
      ksat u rho phi <-> forall v (H : reachable u v), ksat v rho phi.
    Proof.
      split.
      - intros H1 v H2. eapply ksat_mon; eauto.
      - intros H. apply H. eapply reach_refl.
    Qed.
  End Model.

  Notation "rho  '⊨(' u ')'  phi" := (ksat u rho phi) (at level 20).
  Notation "rho '⊨(' u , M ')' phi" := (@ksat _ M u rho phi) (at level 20).
  Arguments ksat {_ _} _ _ _,   _ _ _ _ _.

  Hint Resolve reach_refl.

  Section Substs.
    Variable D : Type.
    Context {M : kmodel D}.

    Lemma ksat_ext u rho xi phi :
      (forall x, rho x = xi x) -> rho ⊨(u,M) phi <-> xi ⊨(u,M) phi.
    Proof.
      induction phi in rho, xi, u |-*; intros Hext; comp.
      - tauto.
      - now rewrite (vec_ext (fun x => eval_ext _ x Hext)).
      - split; intros H v Hv Hv'; now apply (IHphi2 v rho xi Hext), (H _ Hv), (IHphi1 v rho xi Hext).
      - split; intros H d; apply (IHphi _ (d .: rho) (d .: xi)). all: ((intros []; cbn; congruence) + auto).
    Qed.

    Lemma ksat_comp u rho xi phi :
      rho ⊨(u,M) (subst_form xi phi) <-> (xi >> eval rho (I := @k_interp _ M)) ⊨(u,M) phi.
    Proof.
      induction phi in rho, xi, u |-*; comp.
      - tauto.
      - erewrite vec_comp. 2: reflexivity. erewrite vec_ext. 2: apply eval_comp. reflexivity.
      - setoid_rewrite IHphi1. now setoid_rewrite IHphi2.
      - setoid_rewrite IHphi. split; intros H d; eapply ksat_ext. 2, 4: apply (H d).
        all: intros []; comp; rewrite? eval_comp; now comp.
    Qed.
  End Substs.

  Definition kconstraint := forall D, kmodel D -> Prop.
  Definition kcon_subs (C C' : kconstraint) := (forall D (M : kmodel D), C' D M -> C D M).

  Definition kstandard D (M : kmodel D) := forall v, k_Bot v -> False.
  Definition kexploding D (M : kmodel D) := forall v rho P t, rho ⊨(v) (⊥ --> Pred P t).
  Definition kbottomless D (M : kmodel D) := True.

  Lemma kstandard_explodes :
    kcon_subs kexploding kstandard.
  Proof.
    intros D M HC u rho P t v Hv [] % HC.
  Qed.

  Definition kvalid_L (C : kconstraint) A phi :=
    forall D (M : @kmodel D), C _ M -> forall u rho, (forall psi, psi el A -> ksat u rho psi) -> ksat u rho phi.

  Definition kvalid_T (C : kconstraint) T phi :=
    forall D (M : @kmodel D), C _ M -> forall u rho, (forall psi, psi ∈ T -> ksat u rho psi) -> ksat u rho phi.

  Lemma kvalid_L_subs C C' A phi :
    kcon_subs C' C -> kvalid_L C' A phi -> kvalid_L C A phi.
  Proof.
    intros Hsub HC' D M HC % Hsub u rho HA. now apply HC'.
  Qed.
End Kripke.

Notation "rho  '⊨(' u ')'  phi" := (ksat u rho phi) (at level 20).
Notation "rho '⊨(' u , M ')' phi" := (@ksat _ _ M u rho phi) (at level 20).
Notation "A ⊫KE phi" := (kvalid_L kexploding A phi) (at level 20).
Notation "A ⊫KS phi" := (kvalid_L kstandard A phi) (at level 20).
Notation "A ⊫KBL phi" := (kvalid_L kbottomless A phi) (at level 20).
Arguments ksat {_ _} _ _ _ _,  {_ } _ _ _ _ _.

(** **** Soundness **)

Section KSoundness.
  Context {Sigma : Signature} {b : bottom}.

  Ltac clean_ksoundness :=
    match goal with
    | [ H : ?x = ?x -> _ |- _ ] => specialize (H eq_refl)
    | [ H : (?A -> ?B), H2 : (?A -> ?B) -> _ |- _] => specialize (H2 H)
    end.

  Lemma ksemantic_explosion D (M : kmodel D) rho v phi :
    kexploding M -> rho ⊨(v) ⊥ -> rho ⊨(v) phi.
  Proof.
    induction phi in rho, v |-*; firstorder.
  Qed.

  Lemma ksoundness A C (phi : form) :
    (b = expl -> kcon_subs kexploding C) -> @prv _ intu _ A phi  -> kvalid_L C A phi.
  Proof.
    intros Hexp Hprv D M HM. remember intu as s. induction Hprv; subst; cbn; intros u rho HA.
    all: repeat (clean_ksoundness + discriminate). all: (eauto || comp; eauto).
    - intros v Hr Hpi. capply IHHprv. intros ? []; subst; eauto using ksat_mon.
    - eapply IHHprv1. 3: eapply IHHprv2. all: eauto. reflexivity.
    - intros d. apply IHHprv. apply switch_map. intros psi Hpsi. rewrite ksat_comp. apply HA, Hpsi.
    - rewrite ksat_comp. eapply ksat_ext. 2: eapply (IHHprv u rho HA (eval rho t)).
      asimpl. now intros [].
    - apply ksemantic_explosion. 2: eapply IHHprv. all: eauto.
  Qed.

  Lemma strong_ksoundness T C phi :
    (b = expl -> kcon_subs kexploding C) -> @tprv _ intu _ T phi  -> kvalid_T C T phi.
  Proof.
    intros Hexp (A & HA1 & HA2) D M HM u rho HT. apply (ksoundness Hexp HA2 HM).
    firstorder.
  Qed.
End KSoundness.


Require Import List.
Require Import String.

Require Import InvTactics.

(** Definitions of HTTP request **)

(* A line in an HTTP request can be:
     (1) Req_InitialMessage: the first line, for example "GET / HTTP/1.1".
     (2) Req_HeaderLine: a common header line delimited by a colon.
     (3) Req_BrokenLine: if a value in a Req_HeaderLine is too long,
                         it can be broken in to multiple lines.
                         This represents a broken line: in a well formed
                         request, it must follows a Req_HeaderLine.
 *)
Inductive HttpRequestLine : Type :=
| Req_InitialMessage : string -> HttpRequestLine
| Req_HeaderLine : string -> HttpRequestLine
| Req_BrokenLine : string -> HttpRequestLine.

Definition HttpRequest : Type := list HttpRequestLine.

(** What it means for an HTTP request to be well formed/complete. **)

(* The `well_formed_request` we defined here is kind of weak,
     it actually represents the remaining part of a well formed HTTP request
     header (its first several lines have been processed by the server.
 *)
Inductive well_formed_request: HttpRequest -> Prop :=
| wf_empty : well_formed_request nil
| wf_cons_header_line : forall s req, well_formed_request req ->
                                 well_formed_request ((Req_HeaderLine s) :: req)
| wf_cons_broken_line : forall s req, well_formed_request req ->
                                 well_formed_request ((Req_BrokenLine s) :: req).

Hint Constructors well_formed_request.

(* A complete HTTP request must start with a `Req_InitialMessage`,
     followed by nothing or `Req_HeaderLine` and a list of request lines.
 *)
Inductive complete_request : HttpRequest -> Prop :=
| cr_only_initial: forall s,
    complete_request (Req_InitialMessage s :: nil)
| cr_start_with_initial: forall s1 s2 req,
    well_formed_request (Req_HeaderLine s1 :: req) ->
    complete_request (Req_InitialMessage s2 :: Req_HeaderLine s1 :: req).

Hint Constructors complete_request.

(** The same definitions as above, but defined in functions. **)

Definition not_initial_messgae (req: HttpRequestLine) : bool :=
  match req with
  | Req_InitialMessage _ => false
  | _ => true
  end.

Definition no_initial_message (req : HttpRequest) : bool :=
  forallb not_initial_messgae req.

Definition is_complete_request (req : HttpRequest) : bool :=
  match req with
  | (Req_InitialMessage _ :: Req_HeaderLine _ :: rs) =>
    no_initial_message rs
  | (Req_InitialMessage _ :: nil) => true
  | _ => false
  end.

(** Some theorems about well formed/complete HTTP requests. **)

Lemma well_formed_request_inverse: forall line req,
    well_formed_request (line :: req) -> well_formed_request req.
Proof.
  intros. remember (line :: req) as req'.
  induction H; inversion Heqreq'; subst; auto.
Qed.

Lemma complete_request_not_empty : forall req,
    complete_request req -> req <> nil.
Proof.
  intros. intro. try solve by inversion 2.
Qed.

Lemma complete_request_inverse: forall line req,
    complete_request (line :: req) -> well_formed_request req.
Proof.
  intros. remember (line :: req) as req'.
  inversion H. subst. inversion H0. auto.
  subst. inversion H1. assumption.
Qed.

Lemma completet_request_starts_with_initial: forall r req,
    complete_request (r :: req) ->
    exists s, r = (Req_InitialMessage s).
Proof.
  intros. inversion H.
  - exists s. reflexivity.
  - exists s2. reflexivity.
Qed.

Lemma complete_request_has_initial_and_header_line: forall r req,
    req <> nil ->
    complete_request (r :: req) ->
    exists s req', req = (Req_HeaderLine s) :: req'.
Proof.
  intros. inversion H0; subst.
  - exfalso. apply H. reflexivity.
  - exists s1. exists req0. reflexivity.
Qed.

(** Proof that our inductive definitions and function definitions are equivalent.
 **)
Theorem well_formed_iff_no_initial_message : forall req,
    well_formed_request req <-> no_initial_message req = true.
Proof.
  intro req. induction req as [| r rs].
  - simpl. split; intro H; inversion H; auto.
  - destruct r; split; destruct IHrs as [IHrs1 IHrs2];
      intro H; inversion H; subst;
        solve [apply IHrs1 in H1; rewrite <- H1;
               simpl; unfold no_initial_message; auto
              | apply IHrs2 in H1; auto ].
Qed.

Theorem complete_request_is_complete_request : forall req,
    is_complete_request req = true <-> complete_request req.
Proof.
  intro req. destruct req as [| r rs].
  - simpl. split; intro H; inversion H.
  - destruct r.
    + destruct rs as [| r' rs']; split; auto.
      * destruct r'; simpl; intros; try solve by inversion.
        constructor. constructor.
        apply well_formed_iff_no_initial_message. auto.
      * destruct r'; simpl; intros; try solve by inversion.
        inversion H; subst. inversion H1; subst.
        apply well_formed_iff_no_initial_message. auto.
    + split; intro H; try solve by inversion.
    + split; intro H; try solve by inversion.
Qed.


Require Import pdrvs.

Fixpoint ss(x:re) :=
  match x with
    | re0 => {}
    | re1 => {}
    | re_sy a => {a}
    | re_union z t => union (ss z) (ss t)
    | re_conc z t => union (ss z) (ss t)
    | re_star z => ss z
  end.

Instance ss_m : Proper(_eq ==> _eq) ss.
Proof.
  repeat red;
  intros x y H;
  intro a;
  split;intros;
  destruct(re_sy_dec x y);
  subst;auto;
  apply re_leibniz in H;
  contradiction.
Qed.

Inductive langSsy : set Z -> language :=
| nil_in_ss :
    forall r,
      nil ∈ langSsy r
| sy_in_ss_conc :
    forall s x,
      x \In s -> forall w, w ∈ langSsy s ->
                           (x::w) ∈ langSsy s.

Lemma langSsy_empty_set :
  forall w, w <> [] ->
            ~(w ∈ langSsy {}).
Proof.
  induction w.
  intro.
  elim H;auto.
  intros.
  intro.
  inversion_clear H0.
  inversion H1.
Qed.

Lemma langSsy_nil :
  forall s, [] ∈ langSsy s.
Proof.
  constructor.
Qed.

Lemma langSsy_one_sy_word :
  forall s x,
    x \In s -> [x] ∈ langSsy s.
Proof.
  induction s using set_induction.
  intros.
  apply H in H0.
  elim H0.

  intros.
  constructor.
  assumption.
  constructor.
Qed.

Lemma one_sy_word_in_langSsy :
  forall s a,
    [a] ∈ langSsy s -> exists t, t \In s /\ t === a.
Proof.
  induction s using set_induction.
  intros.
  inversion_clear H0.
  apply H in H1.
  elim H1.

  intros.
  inversion_clear H1.
  pose proof H2.
  apply H0 in H1.
  destruct H1.
  exists a.
  split;auto.
  exists a.
  split;auto.
Qed.

Lemma word_cons_in_elem_langSsy :
  forall a w s,
    (a :: w) ∈  langSsy s -> a \In s /\ w ∈ langSsy s.
Proof.
  intros.
  inversion_clear H.
  split;auto.
Qed.

Lemma in_langSsy_word_cons :
  forall a w s,
    a \In s -> w ∈ langSsy s -> (a :: w) ∈  langSsy s.
Proof.
  induction w;intros.
  constructor;auto.
  apply word_cons_in_elem_langSsy in H0.
  destruct H0.
  constructor;auto.
  constructor;auto.
Qed.

Lemma word_in_set_all_sy_in_langSsy :
  forall s w,
    w ∈  langSsy s ->
    forall a, List.In a w -> exists t, t \In s /\ t === a.
Proof.
  induction w;simpl;intros.
  elim H0.
  apply word_cons_in_elem_langSsy in H.
  destruct H.
  destruct H0.
  subst.
  exists a0;split;auto.
  destruct (IHw H1 a0 H0) as [t [H5 H6]].
  exists t;split;auto.
Qed.

Lemma word_concat_sy_in_langSsy :
  forall w a r1 r2,
    (w ++ [a])%list ∈  langSsy (ss r1 ++ ss r2) ->
    w ∈ langSsy (ss r1 ++ ss r2) /\
    [a] ∈ langSsy (ss r1 ++ ss r2).
Proof.
  induction w;simpl;intros.
  split;auto.
  constructor.
  apply word_cons_in_elem_langSsy in H.
  destruct H.
  split.
  constructor.
  assumption.
  apply IHw in H0.
  destruct H0.
  assumption.
  apply IHw in H0.
  destruct H0.
  assumption.
Qed.

Add Morphism langSsy : langSsy_m.
Proof.
  split_eq;
  revert x0 H0;
  induction x0;intros;
  constructor;
  inversion_clear H0;
  (try now (apply H;auto)||auto).
Qed.

Lemma in_union_ss_Ssy_l :
  forall w s1,
    w ∈ langSsy s1 ->
    forall s2,
      w ∈ langSsy (s1 ++ s2).
Proof.
  induction w;intros.
  constructor.
  apply word_cons_in_elem_langSsy in H.
  destruct H.
  apply in_langSsy_word_cons.
  apply union_2;auto.
  apply IHw.
  assumption.
Qed.

Lemma in_union_ss_Ssy_r :
  forall w s1,
    w ∈ langSsy s1 ->
    forall s2,
      w ∈ langSsy (s2 ++ s1).
Proof.
  induction w;intros.
  constructor.
  apply word_cons_in_elem_langSsy in H.
  destruct H.
  apply in_langSsy_word_cons.
  apply union_3;auto.
  apply IHw.
  assumption.
Qed.

Lemma not_in_langSsy_union :
  forall s1 s2 a,
    ~ [a] ∈  langSsy (s1 ++ s2) ->
    ~ [a] ∈ langSsy s1 /\ ~[a] ∈ langSsy s2.
Proof.
  intros;split;intro;
  apply H.
  apply in_union_ss_Ssy_l;auto.
  apply in_union_ss_Ssy_r;auto.
Qed.

Lemma concat_in_langSsy :
  forall w1 s1,
    w1 ∈  langSsy s1 ->
    forall w2 s2,
      w2 ∈  langSsy s2 ->
      (w1 ++ w2)%list ∈  langSsy (s1 ++ s2).
Proof.
  induction w1;intros.
  simpl.
  apply in_union_ss_Ssy_r;auto.
  rewrite <- app_comm_cons.
  apply in_langSsy_word_cons.
  apply word_cons_in_elem_langSsy in H.
  destruct H.
  apply union_2;auto.
  apply word_cons_in_elem_langSsy in H;destruct H.
  apply IHw1;auto.
Qed.

Lemma in_teste :
  forall r w,
    w ∈ (re2rel r) -> w ∈ langSsy (ss r).
Proof.
  induction r;simpl;intros.

  inversion_clear H.

  inversion_clear H.
  constructor.

  inversion_clear H.
  constructor;auto.
  apply singleton_2.
  symmetry;auto.
  constructor.

  inversion_clear H.
  apply in_union_ss_Ssy_l.
  apply IHr1;auto.
  apply in_union_ss_Ssy_r.
  apply IHr2;auto.

  inversion_clear H.
  clear w.
  apply IHr1 in H0.
  apply IHr2 in H1.
  apply concat_in_langSsy;auto.

  inversion_clear H.
  revert n w H0.
  induction n.
  intros.
  simpl in *.
  inversion_clear H0.
  constructor.

  simpl.
  intros.
  inversion_clear H0.
  apply IHn in H1.
  apply IHr in H.
  revert w1 w2 H H1.
  induction w1.
  simpl;auto.
  intros.
  apply word_cons_in_elem_langSsy in H.
  simpl.
  destruct H.
  constructor.
  assumption.
  apply IHw1;auto.
Qed.

Lemma sy_not_in_langSsy_pdrv_empty :
  forall r a,
    ~[a] ∈ langSsy (ss r) ->
    pdrv r a === {}.
Proof.
  induction r;simpl;intros;auto.

  case_eq(compare z a);intros.
  apply compare_2 in H0.
  rewrite H0 in H.
  elim H.
  constructor.
  apply singleton_2;auto.
  constructor.
  reflexivity.
  reflexivity.

  apply not_in_langSsy_union in H.
  destruct H;auto.
  apply IHr1 in H.
  apply IHr2 in H0.
  rewrite H,H0.
  vm_compute.
  split;auto.

  apply not_in_langSsy_union in H.
  destruct H.
  apply IHr1 in H.
  apply IHr2 in H0.
  case_eq(ε(r1));intros.
  rewrite H,H0.
  rewrite dsr_empty.
  unfold c_c_of_re.
  vm_compute;split;auto.

  rewrite H.
  rewrite dsr_empty.
  reflexivity.

  apply IHr in H.
  rewrite H.
  vm_compute.
  split;auto.
Qed.

Lemma word_not_in_langSsy_pdrv_empty :
  forall w a r,
    ~[a] ∈ langSsy (ss r) ->
    wpdrv r (a::w) === {}.
Proof.
  induction w.
  intros.
  apply sy_not_in_langSsy_pdrv_empty in H.
  unfold wpdrv.
  simpl.
  rewrite pdrv_set_singleton.
  rewrite H.
  reflexivity.

  intros.
  apply sy_not_in_langSsy_pdrv_empty in H.
  unfold wpdrv.
  simpl.
  rewrite pdrv_iw_app.
  simpl.
  rewrite pdrv_set_singleton.
  rewrite H.
  rewrite pdrv_iw_empty.
  reflexivity.
Qed.

Lemma word_of_langSsy_decide_equiv :
  forall r1 r2,
    (forall w, w ∈ langSsy ((ss r1)++(ss r2)) ->
               c_of_re_set(wpdrv r1 w) = c_of_re_set(wpdrv r2 w)) ->
    r1 ∼ r2.
Proof.
  intros.
  split;red;intros.
  pose proof H0.
  apply in_teste in H1.
  assert(x ∈ langSsy (ss r1 ++ ss r2)).
  apply in_union_ss_Ssy_l;auto.
  apply H in H2.
  apply word_in_pdrv in H0.
  apply word_in_pdrv_true.
  rewrite <- H2.
  rewrite H0.
  reflexivity.
  pose proof H0.
  apply in_teste in H0.
  assert(x ∈ langSsy (ss r1 ++ ss r2)).
  apply in_union_ss_Ssy_r;auto.
  apply H in H2.
  apply word_in_pdrv in H1.
  apply word_in_pdrv_true.
  rewrite H2.
  rewrite H1.
  reflexivity.
Qed.

Definition ss_set(s:set re) :=
  fold (fun x => union (ss x)) s {}.

Instance f_union_ss_m :
  Proper (_eq ==> _eq ==> _eq) (fun x : re => union (ss x)).
Proof.
  repeat red;intros.
  split;intros.
  rewrite H in H1.
  rewrite H0 in H1.
  auto.
  rewrite H,H0;auto.
Qed.

Lemma f_union_ss_trans : transpose _eq (fun x : re => union (ss x)).
Proof.
  repeat red;intros.
  split;intros.
  apply union_1 in H.
  destruct H.
  apply union_3;apply union_2;auto.
  apply union_1 in H;destruct H.
  apply union_2;auto.
  do 2 apply union_3;auto.
  apply union_1 in H.
  destruct H.
  apply union_3;apply union_2;auto.
  apply union_1 in H;destruct H.
  apply union_2;auto.
  do 2 apply union_3;auto.
Qed.

Hint Resolve f_union_ss_trans : typeclass_instances.

Instance ss_set_m : Proper(equiv ==> equiv) ss_set.
Proof.
  repeat red.
  induction x using set_induction;intros.
  split;intros.
  unfold ss_set in H1.
  rewrite fold_1b in H1;auto.
  inversion H1.
  rewrite H0 in H.
  unfold ss_set in H1.
  rewrite fold_1b in H1;auto;inversion H1.

  split;intros.
  unfold ss_set in H2.
  pose proof @fold_2 re _ _ _ x1 x2 x3 (set Z) _eq _ (@empty Z _ _)
       (fun x : re => union (ss x)) f_union_ss_m f_union_ss_trans.
  pose proof @fold_2 re _ _ _ x1 y x3 (set Z) _eq _ (@empty Z _ _)
       (fun x : re => union (ss x)) f_union_ss_m f_union_ss_trans.
  assert(Add x3 x1 y).
  apply Add_Equal in H0.
  apply Add_Equal.
  rewrite <- H1.
  assumption.
  rewrite (H3 H H0) in H2.
  rewrite (H4 H H5).
  clear H4 H5.
  simpl in H2.
  apply union_iff in H2.
  destruct H2.
  apply union_2;auto.
  apply union_3;auto.

  unfold ss_set in H2.
  pose proof @fold_2 re _ _ _ x1 x2 x3 (set Z) _eq _ (@empty Z _ _)
       (fun x : re => union (ss x)) f_union_ss_m f_union_ss_trans.
  pose proof @fold_2 re _ _ _ x1 y x3 (set Z) _eq _ (@empty Z _ _)
       (fun x : re => union (ss x)) f_union_ss_m f_union_ss_trans.
  assert(Add x3 x1 y).
  apply Add_Equal in H0.
  apply Add_Equal.
  rewrite <- H1.
  assumption.
  rewrite (H4 H H5) in H2.
  rewrite (H3 H H0).
  clear H4 H5.
  simpl in H2.
  apply union_iff in H2.
  destruct H2.
  apply union_2;auto.
  apply union_3;auto.
Qed.

Lemma ss_set_empty :
  ss_set {} === {}.
Proof.
  unfold ss_set.
  vm_compute;split;auto.
Qed.

Lemma ss_set_singleton :
  forall a, ss_set {a} === ss a.
Proof.
  intro.
  assert(Equal {a} {a;{}}).
  split;intros.
  apply add_1.
  apply singleton_1 in H.
  assumption.
  apply add_iff in H.
  destruct H.
  rewrite H.
  apply singleton_2;auto.
  inversion H.
  rewrite H.
  unfold ss_set.
  rewrite fold_2;eauto with typeclass_instances.
  rewrite fold_1b.
  split;intros.
  apply union_iff in H0.
  destruct H0;auto.
  inversion H0.
  apply union_2;auto.
  vm_compute.
  intros.
  inversion x0.
  intro.
  inversion H0.
Qed.

Lemma ss_set_add :
  forall s a,
    ss_set {a;s} === ss_set {a} ++ ss_set s.
Proof.
  induction s using set_induction;intros.
  unfold ss_set at 1.
  assert(~a \In s).
  intro.
  apply H in H0;elim H0.
  rewrite(@fold_add re _ _ _ (set Z) equiv _
                    (fun x : re => union (ss x)) _ f_union_ss_trans {} _ _ H0).
  rewrite ss_set_singleton.
  reflexivity.

  (*specialize IHs1 with a.*)
  apply Add_Equal in H0.
  rewrite H0.
  rewrite add_add.
  case_eq(eq_dec a x);intros;clear H1.
  rewrite e.
  rewrite add_equal.
  rewrite IHs1.
  symmetry.
  rewrite <- union_assoc.
  assert((ss_set {x})[<=](ss_set {x})).
  red;intros;auto.
  apply union_subset_equal in H1.
  rewrite H1.
  reflexivity.
  apply add_1;auto.
  unfold ss_set at 1.
  rewrite fold_add;auto with typeclass_instances.
  fold (ss_set {a;s1}).
  do 2 rewrite IHs1.
  repeat rewrite ss_set_singleton.
  rewrite <- union_assoc.
  rewrite (union_sym (ss x) (ss a)).
  rewrite union_assoc;reflexivity.
  unfold equiv;auto with typeclass_instances.
  intro.
  apply add_iff in H1.
  destruct H1.
  contradiction.
  contradiction.
Qed.

Require Import generic_set_theory.

Lemma ss_set_union :
  forall s1 s2,
    ss_set (s1 ++ s2) === ss_set s1 ++ ss_set s2.
Proof.
  induction s1 using set_induction;intros.
  transitivity (ss_set s2).
  apply empty_is_empty_1 in H.
  rewrite H.
  rewrite empty_union_left.
  reflexivity.
  apply empty_is_empty_1 in H.
  rewrite H.
  rewrite ss_set_empty.
  rewrite empty_union_left.
  reflexivity.

  apply Add_Equal in H0.
  rewrite H0.
  apply Add_Equal in H0.
  rewrite union_add.
  do  2 rewrite ss_set_add.
  rewrite IHs1_1.
  rewrite union_assoc.
  reflexivity.
Qed.