Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool.
From Coq Require Import Logic.Classical.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
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 Logic.Classical.
From Coq Require Import Classes.Equivalence.
From Coq Require Import Classes.Morphisms.
From CReal Require Import Dedekind.RBase.
From CReal Require Import Dedekind.ROrder.
From CReal Require Import Dedekind.RArith.
From CReal Require Import Cauchy.RBase.
From CReal Require Import Cauchy.RArith.
From CReal Require Import Cauchy.ROrder.
From CReal Require Import Cauchy.RAbs.
From CReal Require Import Cauchy.RComplete.
From CReal Require Import Cauchy.RFloor.
From CReal Require Import Cauchy.RFunc.
From Coq Require Import PArith.BinPosDef.
From Coq Require Import Psatz.
Import Pos.
Require Import CReal.Iso.Cauchy2Dedekind.
Require Import CReal.Iso.Dedekind2Cauchy.

Theorem Bijection: forall x y,(D2C x==y)%C <->(C2D y==x)%D.
Proof.
  intros. split.
- intros. destruct x. destruct y.
  unfold D2C in H. hnf in H. unfold "==". split.
  + hnf. intros. destruct H2. destruct H2. destruct H3.
    specialize H with ((1#2)*x0). destruct H. lra.
    assert(exists q:Q,CSeq (x1+x2+1)%nat q). apply Cauchy_exists. auto.
    destruct H4.
    specialize H3 with (x1+x2+1)%nat x3.
    assert(x+x0<x3). apply H3. omega. auto.
    assert((exists N : Z,
       A (N # 2 ^ of_nat (x1+x2+1)%nat) /\ ~ A (N + 1 # 2 ^ of_nat (x1+x2+1)%nat))).
    apply Dcut_P . auto. destruct H6.
    specialize H with (x1+x2+1)%nat (x4 # 2 ^ of_nat (x1 + x2 + 1)) x3.
    assert(Qabs ((x4 # 2 ^ of_nat (x1 + x2 + 1)) - x3) < (1 # 2) * x0).
    apply H. omega. exists x4. split.
    apply H6. split. apply H6. reflexivity. apply H4.
    assert(x<=x4 # 2 ^ of_nat (x1 + x2 + 1)).
    assert(x3-(x4 # 2 ^ of_nat (x1 + x2 + 1))<(1 # 2) * x0).
    apply Qle_lt_trans with (Qabs ((x4 # 2 ^ of_nat (x1 + x2 + 1)) - x3)).
    assert(Qabs ((x4 # 2 ^ of_nat (x1 + x2 + 1)) - x3)==Qabs (x3-(x4 # 2 ^ of_nat (x1 + x2 + 1))))%Q.
    rewrite<-Qabs_opp.
    assert(- ((x4 # 2 ^ of_nat (x1 + x2 + 1)) - x3)==x3 - (x4 # 2 ^ of_nat (x1 + x2 + 1)))%Q. lra.
    rewrite H8. reflexivity. rewrite H8. apply Qle_Qabs. auto. lra.
    destruct H0.
    apply Dedekind_properties2 with (x4 # 2 ^ of_nat (x1 + x2 + 1)).
    split. apply H6. apply H8.
  + hnf. intros.
    destruct H0.
    assert(exists r : Q, A r /\ x < r).  apply Dedekind_properties3.
    apply H2. destruct H0. destruct H0. exists ((1#4)*(x0-x)). split.
    lra. assert(exists q:Q,q==x0-x)%Q. exists (x0-x). reflexivity.
    destruct H4 as [eps H4].
    assert(exists n:nat,((2#1)/eps<=inject_Z(Z.of_nat n))).
    apply Inject_lemmas.inject_Z_of_nat_le. destruct H5.
    destruct H with ((1#4)*eps). lra.
    exists (x1+x2)%nat. intros.
    assert(exists N : Z,
         A (N # 2 ^ of_nat n) /\ ~ A (N + 1 # 2 ^ of_nat n)).
    apply Dcut_P. split. auto. auto. auto. auto. destruct H9.
    assert(Qabs ((x3 # 2 ^ of_nat n)-p ) < (1#4)*eps).
    apply H6 with n. omega. exists x3. split.
    apply H9. split. apply H9. reflexivity. auto.
    assert(((x3 # 2 ^ of_nat n) - p) < (1 # 4) * eps)%Q.
    apply Qle_lt_trans with (Qabs ((x3 # 2 ^ of_nat n) - p)).
    apply Qle_Qabs. auto.
    assert(x0-(1#2)*eps<(x3 # 2 ^ of_nat n)).
    assert(x0<x3+1# 2 ^ of_nat n). apply Dcut_lt with A.
    split;auto;auto;auto;auto. auto. apply H9.
    assert(1# 2^of_nat n<(1#2)*eps).
    apply Qlt_le_trans with (1#of_nat n). apply power_compare2. omega.
    assert(exists q:Q,q==(1 # 2) * eps)%Q. exists ((1 # 2) * eps).
    reflexivity. destruct H13. rewrite<-H13.
    assert((2 # 1) / eps==1/x4)%Q.
    rewrite H13.
    field. lra.
    rewrite H14 in H5.
    apply inject_compare with x1. lra. omega. auto.
    assert(x3 + 1 # 2 ^ of_nat n==(x3# 2 ^ of_nat n)+(1 # 2 ^ of_nat n))%Q.
    rewrite Qplus_sameden. reflexivity. rewrite H14 in H12.
    lra.
    lra.
- intros. destruct x,y. hnf. hnf in H. destruct H.
  hnf in H,H2. intros.
  assert(exists n : nat,
               forall m1 m2 : nat,
               (m1 > n)%nat ->
               (m2 > n)%nat ->
               forall q1 q2 : Q, CSeq m1 q1 -> CSeq m2 q2 -> Qabs (q1 - q2) < (1#4)*eps).
  apply H1. lra. destruct H4.
  assert(exists n:nat,((2#1)/eps<=inject_Z(Z.of_nat n))).
  apply Inject_lemmas.inject_Z_of_nat_le.
  destruct H5 as [t P].
  exists (x+t+1)%nat. intros.
  destruct H6. destruct H6. destruct H8.
  apply H2 in H6.
  destruct H6. destruct H6. destruct H10.
  assert(exists q:Q,CSeq (x+x2+1)%nat q) by apply H1. destruct H11.
  assert((x0 # 2 ^ of_nat m) + x1 < x3). apply H10 with (x+x2+1)%nat.
  omega. auto. assert(Qabs (q2 - x3) < (1 # 4) * eps) . apply H4 with m (x+x2+1)%nat.
  omega. omega. auto. auto.
  specialize H with (x0 + 1 # 2 ^ of_nat m).
  assert(~((exists t : Q,
       0 < t /\
       (exists N : nat,
          forall (n : nat) (p : Q),
          (n > N)%nat -> CSeq n p -> (x0 + 1 # 2 ^ of_nat m) + t < p)))).
  unfold not. intros. apply H8. apply H. auto.

  assert(~(q1+(1#(2^ (of_nat m)))+((1#2)*eps))<q2)%Q.
  unfold not. intros. apply H14.
  exists ((1#4)*eps). split. lra.

  exists (x+t+m)%nat.
  intros.
  rewrite<-Qplus_sameden. rewrite<-H9.
  apply Qlt_le_trans with (q2-(1#4)*eps). lra.
  assert(q2-p<(1#4)*eps).
  apply Qle_lt_trans with (Qabs(q2-p)).
  apply Qle_Qabs. apply H4 with m n. omega. omega. auto. auto.
  assert((1 # 2 ^ of_nat m)<(1#2)*eps).
  apply Qlt_le_trans with (1#of_nat m). apply power_compare2. omega.
    assert(exists q:Q,q==(1 # 2) * eps)%Q. exists ((1 # 2) * eps).
    reflexivity. destruct H19. rewrite<-H19.
    assert((2 # 1) / eps==1/x4)%Q.
    rewrite H19.
    field. lra.
    rewrite H20 in P.
    apply inject_compare with t. lra. omega. auto. lra.
  assert((1 # 2 ^ of_nat m)<(1#2)*eps).
  apply Qlt_le_trans with (1#of_nat m). apply power_compare2. omega.
    assert(exists q:Q,q==(1 # 2) * eps)%Q. exists ((1 # 2) * eps).
    reflexivity. destruct H16. rewrite<-H16.
    assert((2 # 1) / eps==1/x4)%Q.
    rewrite H16.
    field. lra.
    rewrite H17 in P.
    apply inject_compare with t. lra. omega. auto.
  assert(q2<q1+eps). lra.
  assert(q1<q2+(1#4)*eps).
  assert(x3-q2<(1#4)*eps).
  apply Qle_lt_trans with (Qabs (q2 - x3)).
  rewrite<-Qabs_opp. assert(- (q2 - x3)==x3-q2)%Q.
  lra. rewrite H18. apply Qle_Qabs. auto. lra.
  apply QArith_base_ext.Qabs_Qlt_condition. split.
  lra. lra.
Qed.

(* the definition of D.Rabs *)
Definition cut_positive(A:Q->Prop):Prop:=
A 0.
Definition Cut_abs :(Q->Prop)->(Q->Prop):=
fun A x=>(cut_positive A/\A x)\/(~cut_positive A/\Cut_opp A x).
Theorem Dedekind_Rabs_pre(A:Q->Prop):Dedekind A->Dedekind (Cut_abs A).
Proof.
  intros. split.
  - split. unfold Cut_abs. unfold cut_positive. unfold Cut_opp.
    assert(A 0\/~A 0) by apply classic. destruct H0.
    exists 0. left. auto. exists (-1#1)%Q. right. split. auto. exists 1.
    split. lra. unfold not. intros. apply H0. apply Dedekind_properties4 with ((- (-1 # 1) + - (1)))%Q.
    auto. lra. auto. unfold Cut_abs. unfold cut_positive. unfold Cut_opp.
    assert(A 0\/~A 0) by apply classic. destruct H0.
    assert(exists q:Q,~A q). apply Dedekind_properties1. auto. destruct H1.
    exists x.
    apply and_not_or. split.
    apply or_not_and. right. auto. apply or_not_and. left. auto.
     assert(exists q:Q,A q) as P. apply Dedekind_properties1. auto.
    destruct P as [q P].
    exists (-q)%Q. apply and_not_or. split. apply or_not_and. left. auto.
    apply or_not_and. right. unfold not. intros. destruct H1. destruct H1.
    apply H2. apply Dedekind_properties2  with q. auto. split.
    auto. lra.
  - unfold Cut_abs. unfold cut_positive. unfold Cut_opp. intros.
    destruct H0. destruct H0.
    + left. split. apply H0. apply Dedekind_properties2 with p. auto.
      split. apply H0. auto.
    + right. split. apply H0. destruct H0. destruct H2. exists x.
      split. destruct H2. auto. destruct H2. unfold not. intros.
      apply H3. apply Dedekind_properties2 with (- q + - x)%Q.
      auto. split. auto. lra.
  - unfold Cut_abs. unfold cut_positive. unfold Cut_opp.
    intros. destruct H0.
    + destruct H0. assert(exists r : Q, A r /\ (p < r))%Q. apply Dedekind_properties3. auto. auto.
      destruct H2. exists x. split. left. split. auto. apply H2. apply H2.
    + destruct H0. destruct H1. destruct H1. exists (p+(1#2)*x)%Q.
      split. right. split. auto. exists ((1#2)*x)%Q. split.
      lra. unfold not. intros. apply H2. apply Dedekind_properties4 with (- (p + (1 # 2) * x) + - ((1 # 2) * x))%Q.
      auto. lra. auto. lra.
  - unfold Cut_abs. unfold cut_positive. unfold Cut_opp. intros.
    destruct H1. destruct H1. left. split. auto. apply Dedekind_properties4 with p.
    auto. auto. auto. destruct H1. right. split. auto.
    destruct H2. exists x. split. apply H2. destruct H2. unfold not. intros.
    apply H3. apply Dedekind_properties4 with (- q + - x)%Q. auto.
    lra. auto.
Qed.
Definition Dedekind_Rabs(A:D1.Real):D1.Real:=
match A with
| Real_cons A HA =>Real_cons (Cut_abs A) (Dedekind_Rabs_pre A HA) end.
Lemma DCut_lt :forall(Dcut:Q->Prop),Dedekind Dcut->forall (p q:Q),
Dcut p->~Dcut q->(p<q)%Q.
Proof.
  intros. pose proof Dedekind_properties2 _ H p q.
assert(~q<=p)%Q;[tauto|]. apply Qnot_le_lt. apply H3.
Qed.
Lemma DRabs_positive:forall (A:D1.Real),(RBase.Rzero<A)%D->(A==Dedekind_Rabs A)%D.
Proof.
intros. unfold D2.Rlt in H. simpl in H. destruct A.
destruct H. destruct H1. destruct H1. hnf. split.
- hnf. intros. hnf. unfold cut_positive. unfold Cut_opp.
  assert(A 0\/~A 0). apply classic. destruct H4. left. split. auto. auto.
  right. split. auto. exists (-x0)%Q. split.
  assert(x0<0)%Q. apply DCut_lt with A. auto. auto. auto. lra.
  unfold not. intros. apply H4. apply Dedekind_properties2 with (- x0 + - - x0)%Q.
  auto. split. auto. lra.
- hnf. intros. hnf in H3. unfold cut_positive,Cut_opp in H3. destruct H3.
  apply H3. destruct H3. destruct H4. destruct H4. apply H.
  assert(0<=- x0 + - x1)%Q. assert(0 <= - x0 + - x1\/~0 <= - x0 + - x1)%Q by apply classic.
  destruct H6. auto. assert(- x0 + - x1<0)%Q by lra.
  assert False. apply H5. apply H. auto. destruct H8. lra.
Qed.
Lemma DRabs_notpositive:forall (A:D1.Real),(~RBase.Rzero<A)%D->(-A==Dedekind_Rabs A)%D.
Proof.
  intros. unfold D2.Rlt in H. simpl in H. destruct A.
  hnf. split.
  - hnf. unfold Cut_opp,Cut_abs. intros. unfold cut_positive,Cut_opp.
    apply not_and_or in H. destruct H. right. split. assert(A 0\/~A 0) by apply classic.
    destruct H2.
    assert False. apply H. intros. apply Dedekind_properties2 with 0. auto. split. auto. lra.
    destruct H3. auto. auto. assert(A 0\/~A 0)by apply classic. destruct H2.
    assert False. apply H. exists 0. split. auto. lra. destruct H3.
    right. split. auto. auto.
  - hnf. unfold Cut_opp,Cut_abs. intros. unfold cut_positive,Cut_opp.
    unfold cut_positive,Cut_opp in H1.
    apply not_and_or in H. destruct H.
    + destruct H1. destruct H1. assert False.
      apply H. intros. apply Dedekind_properties2 with 0. auto. split. auto. lra. destruct H3.
      destruct H1. auto.
    + destruct H1. assert False. apply H. exists 0. split. apply H1. lra. destruct H2.
      destruct H1. auto.
Qed.
(* the definition of D.Rabs *)

Theorem C2D_property10:forall (x:C1.Real),C2D (Rabs x)==Dedekind_Rabs (C2D x).
Proof.
  intros. assert(0%R<x\/~0%R<x)%C by apply classic.
  destruct H.
  - assert(Rabs x==x)%C. apply Rabs_positive. apply C2.Rpositive_gt_0. apply H.
    assert (C2D (Rabs x)==C2D x)%D. apply C2D_property3. auto.
    rewrite H1. apply DRabs_positive. rewrite<- C2D_property6. apply C2D_property4. auto.
  - assert(Rabs x==-x)%C. apply C2.Rnot_lt in H. destruct H.
    + rewrite<-H. rewrite Rabs_zero. apply C2.Rzero_opp_zero.
    + apply Rabs_negative. apply C2.Rnegative_lt_0. auto.
    +  assert (C2D (Rabs x)==C2D (-x))%D. apply C2D_property3. auto.
       rewrite H1. rewrite C2D_property7. apply DRabs_notpositive.
       rewrite <-C2D_property6. apply  Rnot_lt_le in H.
       apply Rle_not_lt. apply C2D_property5. auto.
Qed.
Theorem D2C_property10:forall (x:D1.Real),(D2C (Dedekind_Rabs x)==Rabs (D2C x))%C.
Proof.
  intros. assert(RBase.Rzero<x\/~RBase.Rzero<x)%D by apply classic.
  destruct H.
  - assert(0%R<D2C x)%C. rewrite<- D2C_property6. apply D2C_property4. auto.
    rewrite Rabs_positive.
    apply D2C_property3. symmetry. apply DRabs_positive. auto. apply C2.Rpositive_gt_0. auto.
  - assert(-x==Dedekind_Rabs x)%D. apply DRabs_notpositive. auto.
    assert(D2C (Dedekind_Rabs x)==D2C (-x))%C. apply D2C_property3. rewrite H0. reflexivity.
    rewrite H1. rewrite D2C_property7. symmetry.  apply Rabs_nonpositive.
    apply D2.Rnot_lt_le in H.
    assert(x==RBase.Rzero\/~x==RBase.Rzero)%D by apply classic.
    destruct H2.
    + apply RSign.Rzero_not_positive. rewrite<- D2C_property6.
      apply D2C_property3. auto.
    + apply RSign.Rnegative_not_positive. apply Rnegative_lt_0.
      rewrite<- D2C_property6.
      apply D2C_property4. apply D3.Rle_lt_eq in H. destruct H.
      assert False. apply H2. auto. destruct H3. auto.
Qed.
(* Definition of D.Rlimit *)
Class DR_seq (RS: nat -> D1.Real -> Prop) : Prop := {
  DRseq_exists : forall (n:nat), exists A1, RS n A1;
  DRseq_unique : forall (n:nat)  A1 A2,
      RS n A1 -> RS n A2 -> (A1 == A2)%D;
  DRseq_proper: forall n, Proper (Req ==> iff) (RS n);
}.
Inductive DReal_seq : Type :=
| DRseq_intro (RS : nat -> D1.Real -> Prop) (H: DR_seq RS).
Definition DRlimit (Rseq:DReal_seq) (Lim:D1.Real):Prop:=
forall Eps:D1.Real, (RBase.Rzero < Eps)%D -> exists N, forall n,
(n>=N)%nat -> forall A,
(match Rseq with DRseq_intro RS _ => RS end) n A -> (Dedekind_Rabs (A - Lim) < Eps)%D.
(* Definition of D.Rlimit *)

Definition C2D_seq_pre (RS:nat->C1.Real->Prop):nat->D1.Real->Prop:=
fun n x=>exists (y:C1.Real),RS n y/\C2D y==x.

Theorem C2D_seq_limit:forall (A:nat->C1.Real->Prop),R_seq A->DR_seq (C2D_seq_pre A).
Proof.
  intros. destruct H. split.
- intros. assert(exists A1 : Real, A n A1). apply Rseq_exists.
  destruct H. exists (C2D x). hnf. exists x. split. auto. reflexivity.
- intros. hnf in H,H0. destruct H,H0. destruct H,H0.
  assert(x==x0)%C. apply Rseq_unique with n. auto. auto.
  rewrite<-H1. rewrite<-H2. apply C2D_property3. auto.
- intros. hnf. intros. split.
  + unfold C2D_seq_pre. intros. destruct H0. destruct H0.
     exists x0. split. auto. rewrite<-H. auto.
  + unfold C2D_seq_pre. intros. destruct H0. destruct H0.
    exists x0. split. auto. rewrite H. auto.
Qed.

Definition C2D_seq (A:Real_seq):DReal_seq:=
match A with
|Rseq_intro RS H =>DRseq_intro (C2D_seq_pre RS) (C2D_seq_limit RS H) end.

Lemma DRabs_eq: forall (A B:D1.Real),A==B->Dedekind_Rabs A==Dedekind_Rabs B.
Proof.
  intros. hnf. split.
- hnf in H. destruct H. destruct A,B. unfold Dedekind_Rabs.
  hnf. intros. hnf in H. hnf in H0. hnf in H3.
  hnf. unfold cut_positive,Cut_opp in H3 . unfold cut_positive,Cut_opp.
  destruct H3.
  + left. split. apply H. apply H3. apply H. apply H3.
  + right. split. unfold not. intros. destruct H3. apply H3. apply H0. auto.
    destruct H3. destruct H4. destruct H4. exists x0. split.
    auto. unfold not. intros. apply H5. apply H0. auto.
- hnf in H. destruct H. destruct A,B. unfold Dedekind_Rabs.
  hnf. intros. hnf in H. hnf in H0. hnf in H3.
  hnf. unfold cut_positive,Cut_opp in H3 . unfold cut_positive,Cut_opp.
  destruct H3.
  + left. split. apply H0. apply H3. apply H0. apply H3.
  + right. split. unfold not. intros. destruct H3. apply H3. apply H. auto.
    destruct H3. destruct H4. destruct H4. exists x0. split.
    auto. unfold not. intros. apply H5. apply H. auto.
Qed.
Theorem C2D_property11:forall (Climit:C1.Real)(Seq:Real_seq),
Rlimit Seq Climit->DRlimit (C2D_seq Seq) (C2D Climit).
Proof.
  intros. hnf. intros.
  hnf in H. destruct Seq. unfold C2D_seq.
  destruct H with (D2C Eps). rewrite<- D2C_property6.
  apply D2C_property4. auto. exists x. intros.
  hnf in H4. destruct H4. destruct H4.
  assert(Rabs (x0 - Climit) < D2C Eps)%C. apply H2 with n.
  auto. auto.
  assert(C2D(Rabs (x0 - Climit)) < C2D(D2C Eps))%D.
  apply C2D_property4. auto.
  assert(C2D (D2C Eps)==Eps)%D. apply Bijection. reflexivity.
  rewrite H8 in H7. rewrite C2D_property10 in H7. unfold C3.Rminus in H7.
  assert((Dedekind_Rabs (C2D (x0 + - Climit))==(Dedekind_Rabs (A - C2D Climit))))%D.
  assert(C2D (x0 + - Climit)==(A - C2D Climit))%D. rewrite<- C2D_property1.
  rewrite H5. rewrite C2D_property7. reflexivity.
  apply DRabs_eq. auto.
  rewrite H9 in H7. auto.
Qed.
Definition D2C_seq_pre (RS:nat->D1.Real->Prop):nat->C1.Real->Prop:=
fun n x=>exists (y:D1.Real),RS n y/\(D2C y==x)%C.

Theorem D2C_seq_limit:forall (A:nat->D1.Real->Prop),DR_seq A->R_seq (D2C_seq_pre A).
Proof.
  intros. destruct H. split.
- intros. assert(exists A1 : D1.Real, A n A1). apply DRseq_exists0.
  destruct H. exists (D2C x). hnf. exists x. split. auto. reflexivity.
- intros. hnf in H,H0. destruct H,H0. destruct H,H0.
  assert(x==x0)%D. apply DRseq_unique0 with n. auto. auto.
  rewrite<-H1. rewrite<-H2. apply D2C_property3. auto.
- intros. hnf. intros. split.
  + unfold C2D_seq_pre. intros. destruct H0. destruct H0.
     exists x0. split. auto. rewrite<-H. auto.
  + unfold C2D_seq_pre. intros. destruct H0. destruct H0.
    exists x0. split. auto. rewrite H. auto.
Qed.

Definition D2C_seq (A:DReal_seq):Real_seq:=
match A with
|DRseq_intro RS H =>Rseq_intro (D2C_seq_pre RS) (D2C_seq_limit RS H) end.
Lemma CRabs_eq: forall (A B:C1.Real),(A==B)%C->(Rabs A==Rabs B)%C.
Proof.
  intros. unfold Rabs. destruct A,B. hnf. intros.
  hnf in H. destruct H with  eps. auto. exists x.
  intros. hnf in H5,H6.
  assert(exists q:Q, CSeq m q). apply Cauchy_exists. auto.
  assert(exists q:Q, CSeq0 m q). apply Cauchy_exists. auto.
  destruct H7,H8. specialize H5 with x0. specialize H6 with x1.
  assert(Qabs (x0 - x1) < eps)%Q.
  apply H3 with m. auto. auto. auto.
  apply H5 in H7. apply H6 in H8. rewrite H7,H8.
  apply Qle_lt_trans with (Qabs (x0 - x1)).
  assert(Qabs x0 - Qabs x1<=0\/~Qabs x0 - Qabs x1<=0)by apply classic.
  destruct H10. rewrite Qabs_neg. rewrite Qabs_Qminus.
  apply Qle_trans with (Qabs x1-Qabs x0). lra. apply Qabs_triangle_reverse.
  auto. rewrite Qabs_pos. apply Qabs_triangle_reverse. lra.
  auto.
Qed.
Theorem D2C_property11:forall (Seq:DReal_seq)(Dlimit:D1.Real),
DRlimit Seq Dlimit->Rlimit (D2C_seq Seq) (D2C Dlimit).
Proof.
  intros. hnf. intros.
  hnf in H. destruct Seq. unfold D2C_seq.
  destruct H with (C2D Eps). rewrite<- C2D_property6.
  apply C2D_property4. auto. exists x. intros.
  hnf in H4. destruct H4. destruct H4.
  assert(Dedekind_Rabs (x0 - Dlimit) < C2D Eps)%D. apply H2 with n.
  auto. auto.
  assert(D2C(Dedekind_Rabs (x0 - Dlimit)) < D2C(C2D Eps))%C.
  apply D2C_property4. auto.
  assert(D2C (C2D Eps)==Eps)%C. apply Bijection. reflexivity.
  rewrite H8 in H7. rewrite D2C_property10 in H7. unfold D3.Rminus in H7.
  assert(Rabs (D2C (x0 + - Dlimit))==Rabs (A - D2C Dlimit))%C.
  apply CRabs_eq. rewrite<- D2C_property1. rewrite H5.
  rewrite D2C_property7. reflexivity.
  rewrite H9 in H7. auto.
Qed.


Require Import List Arith Bool.
Require Import Expr Env.
Require Import EquivDec EqdepClass.
Require Import DepList.
Require Import Word Prover.
Require Import sep.Array IL.

Set Implicit Arguments.

Local Notation pcT := (tvType 0).
Local Notation stT := (tvType 1).
Local Notation wordT := (tvType 0).
Local Notation natT := (tvType 4).
Local Notation listWT := (tvType 5).

Local Notation wltF := 4.
Local Notation natToWF := 5.
Local Notation lengthF := 6.
Local Notation selF := 7.
Local Notation updF := 8.

Section ArrayBoundProver.
  Variable types' : list type.
  Definition types := Array.types types'.
  Variable funcs' : functions types.
  Definition funcs := Array.funcs funcs'.

  Fixpoint deupd (e : expr types) : expr types :=
    match e with
      | Func updF (e' :: _ :: _ :: nil) => deupd e'
      | _ => e
    end.

  Definition factIn (e : expr types) : option (expr types * expr types) :=
    match e with
      | Func wltF (i :: Func natToWF (Func lengthF (a :: nil) :: nil) :: nil) =>
        Some (i, deupd a)
      | _ => None
    end.

  Definition boundSummary := list (expr types * expr types).

  Definition boundLearn1 (summ : boundSummary) (e : expr types) : boundSummary :=
    match factIn e with
      | None => summ
      | Some fact => fact :: summ
    end.

  Fixpoint boundLearn (summ : boundSummary) (es : list (expr types)) : boundSummary :=
    match es with
      | nil => summ
      | e :: es => boundLearn1 (boundLearn summ es) e
    end.

  Definition boundSummarize := boundLearn nil.

  Fixpoint hypMatches (fact : expr types * expr types) (summ : boundSummary) : bool :=
    match summ with
      | nil => false
      | (i, a) :: summ' => (expr_seq_dec i (fst fact) && expr_seq_dec a (snd fact)) || hypMatches fact summ'
    end.

  Definition boundProve (summ : boundSummary) (goal : expr types) :=
    match factIn goal with
      | None => false
      | Some fact => hypMatches fact summ
    end.

  Fixpoint size (e : expr types) : nat :=
    match e with
      | Const _ _ => O
      | Var _ => O
      | UVar _ => O
      | Func _ es => fold_left plus (map size es) 1
      | Equal _ e1 e2 => size e1 + size e2
      | Not e1 => size e1
    end.

  Lemma plus_monotone : forall ls n, (fold_left plus ls n >= n)%nat.
    induction ls; simpl; intuition.
    specialize (IHls (n + a)); omega.
  Qed.

  Lemma deupd_correct : forall uvars vars sz (e : expr types),
    (size e <= sz)%nat
    -> match exprD funcs uvars vars e listWT with
         | None => True
         | Some ev =>
           match exprD funcs uvars vars (deupd e) listWT with
             | None => False
             | Some dv => length dv = length ev
           end
       end.
    induction sz; destruct e; simpl size; simpl deupd; simpl exprD; intuition eauto; try discriminate;
      try solve [ destruct (equiv_dec t listWT); auto
        | match goal with
            | [ |- match ?E with Some _ => _ | None => _ end ] => destruct E; auto
          end ].

    specialize (plus_monotone (map size l) 1); omega.

    Lemma repr_nth_error : forall A (v : A) r ls n,
      nth_error r.(footprint) n = Some (Some v)
      -> nth_error (repr r ls) n = Some v.
      destruct r; simpl; induction footprint; simpl; intuition.
      destruct n; simpl in *; discriminate.
      destruct n; simpl in *.
      injection H; clear H; intros; subst; reflexivity.
      eapply IHfootprint in H; clear IHfootprint.
      destruct a; eauto.
    Qed.

    do 8 (destruct f; [ t | ]).
    destruct f; [ | t ].

    replace (nth_error funcs 8) with (Some (upd_r types'))
      by (unfold funcs, Array.funcs; erewrite repr_nth_error; reflexivity).
    simpl.
    do 3 (destruct l; [ t | ]).
    destruct l; [ | t ].
    simpl.
    specialize (IHsz e).
    simpl in H.
    assert (size e <= sz)%nat by omega; intuition.
    destruct (exprD funcs uvars vars e listWT); auto.
    destruct (exprD funcs uvars vars (deupd e) listWT); try tauto.
    destruct (exprD funcs uvars vars e0 wordT); auto.
    destruct (exprD funcs uvars vars e1 wordT); auto.
    Require Import Arrays.
    rewrite upd_length; assumption.
  Qed.

  Ltac duh' := match goal with
                 | [ |- match ?E with Some _ => _ | _ => _ end ] => destruct E
               end; try tauto.

  Ltac duh := solve [ repeat duh' ].

  Lemma factIn_correct : forall uvars vars (e : expr types),
    match exprD funcs uvars vars e tvProp with
      | None => True
      | Some P => match factIn e with
                    | None => True
                    | Some (i, a) =>
                      exists iv, exprD funcs uvars vars i wordT = Some iv
                        /\ exists av, exprD funcs uvars vars a listWT = Some av
                          /\ (P = (iv < $(length av)))
                  end
    end.
    destruct e; simpl factIn; simpl exprD; intuition; try duh.
    do 5 (destruct f; try duh).
    do 3 (destruct l; try duh).

    Focus 2.
    destruct (nth_error funcs 4); auto.
    destruct (equiv_dec (Range s) tvProp); auto.
    destruct s; simpl in e2.
    hnf in e2; subst.

    simpl applyD.
    duh'.
    destruct e0; auto.
    do 6 (destruct f; auto).
    destruct l0; auto.
    destruct e0; auto.
    do 7 (destruct f; auto).
    do 2 (destruct l1; auto).
    destruct l0; auto.

    replace (nth_error funcs 4) with (Some (ILEnv.wlt_r types))
      by (unfold funcs, Array.funcs; erewrite repr_nth_error; reflexivity).
    match goal with
      | [ |- match ?E with None => _ | Some _ => _ end ] =>
        let E' := eval simpl in E in change E with E'
    end.
    case_eq (exprD funcs uvars vars e wordT); intuition.
    case_eq (exprD funcs uvars vars e0 wordT); intuition.
    destruct e0; auto.
    do 6 (destruct f; auto).
    destruct l; auto.
    destruct e0; auto.
    do 7 (destruct f; auto).
    do 2 (destruct l0; auto).
    destruct l; auto.
    simpl in H0.
    specialize (deupd_correct uvars vars (sz := size e0) e0).
    assert (size e0 <= size e0)%nat by auto; intuition.
    destruct (exprD funcs uvars vars e0 listWT); try discriminate.
    destruct (exprD funcs uvars vars (deupd e0) listWT); try tauto.
    do 2 esplit; eauto.
    do 2 esplit; eauto.
    injection H0; clear H0; intros; subst.
    rewrite H3.
    reflexivity.
  Qed.

  Section vars.
    Variables uvars vars : env types.

    Definition pairValid (p : expr types * expr types) :=
      exists i, exprD funcs uvars vars (fst p) wordT = Some i
        /\ exists a, exprD funcs uvars vars (snd p) listWT = Some a
          /\ i < $(length a).

    Definition boundValid (summ : boundSummary) :=
      List.Forall pairValid summ.

    Theorem boundLearn1Correct : forall sum,
      boundValid sum
      -> forall hyp, Provable funcs uvars vars hyp
        -> boundValid (boundLearn1 sum hyp).
    Proof.
      unfold Provable, boundLearn1, boundValid; intros.
      specialize (factIn_correct uvars vars hyp).
      destruct (exprD funcs uvars vars hyp tvProp); try tauto.
      destruct (factIn hyp); intuition.
      destruct p.
      do 2 destruct H1.
      do 2 destruct H2.
      subst.
      unfold pairValid.
      constructor; eauto.
    Qed.

    Hint Resolve boundLearn1Correct.

    Theorem boundLearnCorrect : forall sum,
      boundValid sum
      -> forall hyps, AllProvable funcs uvars vars hyps
        -> boundValid (boundLearn sum hyps).
    Proof.
      induction hyps; simpl; intuition.
    Qed.

    Theorem boundSummarizeCorrect : forall hyps,
      AllProvable funcs uvars vars hyps
      -> boundValid (boundSummarize hyps).
      intros; apply boundLearnCorrect; hnf; auto.
    Qed.

    Lemma hypMatchesCorrect : forall p sum,
      boundValid sum
      -> hypMatches p sum = true
      -> pairValid p.
      induction sum as [ | [ ] ]; simpl; intuition.
      apply orb_prop in H0; intuition.
      apply andb_prop in H1; intuition.
      apply expr_seq_dec_correct in H0.
      apply expr_seq_dec_correct in H2.
      subst.
      inversion H; auto.
      inversion H; auto.
    Qed.
  End vars.

  Hint Resolve boundLearnCorrect boundSummarizeCorrect.

  Theorem boundProverCorrect : ProverCorrect funcs boundValid boundProve.
    hnf; intros.
    unfold boundProve in H0.
    hnf.
    specialize (factIn_correct uvars vars goal).
    destruct H1.
    rewrite H1 in *.
    destruct (factIn goal); try discriminate.
    eapply hypMatchesCorrect in H0; eauto.
    destruct H0.
    destruct p.
    destruct H0.
    destruct H2.
    destruct H2.
    intro.
    destruct H4.
    destruct H4.
    destruct H5.
    destruct H5.
    subst.
    unfold fst, snd in *.
    congruence.
  Qed.

  Hint Resolve boundProverCorrect.

  Lemma boundValid_weaken : forall (u g : env types) (f : boundSummary)
    (ue ge : list (sigT (tvarD types))),
    boundValid u g f -> boundValid (u ++ ue) (g ++ ge) f.
    induction 1; simpl; intuition; constructor; auto.
    hnf in H; hnf.
    do 2 destruct H.
    do 2 destruct H1.
    eauto 10 using exprD_weaken.
  Qed.

  Hint Resolve boundValid_weaken.

  Definition boundProver : ProverT types :=
    {| Facts := boundSummary
      ; Summarize := boundSummarize
      ; Learn := boundLearn
      ; Prove := boundProve |}.

  Definition boundProver_correct : ProverT_correct boundProver funcs.
    eapply Build_ProverT_correct with (Valid := boundValid); eauto.
  Qed.

End ArrayBoundProver.

Definition BoundProver : ProverPackage :=
{| ProverTypes := Array.types_r
 ; ProverFuncs := Array.funcs_r
 ; Prover_correct := boundProver_correct
|}.


Definition g0 : guard := BAnd(BLe(AMult(APlus(AId  a)(AId  b))(AId  c))(ANum  1))(BGt(APlus(AId  c)(AId  d))(ANum   10)).
Definition g1 : guard := BGt(APlus(AId  a)(AId  b))(ANum  3).
Definition g2 : guard := BGt(APlus(AId  a)(AId  b))(ANum  3).
Definition g3 : guard := BLe(APlus(AId  a)(AId  b))(ANum  12).

Definition t3: trans := ("t3", 2, nil, "eid", g0, "eerror" :: nil, nil, 3, none).
Definition t2: trans := ("t2", 3, nil, "ecmd", g1, nil, nil, 2, shallow).
Definition t1: trans := ("t1", 0, nil, "eid", g2, nil, nil, 1, none).
Definition t4: trans := ("t4", 2, ("Spwd" :: nil), "epwd", g3, "eloginsucc" :: nil, nil, 3, none).
Definition t5: trans := ("t5", 5, nil, "eid", BTrue, nil, nil, 6, none).

Definition n0 : sc := basic_sc "Sid" (nil, nil).
Definition n1 : sc := basic_sc "Spwd" (nil, nil).
Definition n2 : sc := or_sc "Sident" (n0 :: n1 :: nil) 0 (t1 :: nil) (nil, "exlogin" :: nil).
Definition n3 : sc := basic_sc "SCmd" ("encmd" :: nil, nil).
Definition n4 : sc := or_sc "Sexecute" (n2 :: n3 :: nil) 0 (t3 :: t2 :: t4 :: nil) (nil, nil).
Definition n5 : sc := basic_sc "Lwait" (nil, nil).
Definition n6 : sc := basic_sc "Lwrite" (nil, nil).
Definition n7 : sc := or_sc "SLog" (n5 :: n6 :: nil) 0 (t5 :: nil) (nil, nil).
Definition n8 : sc := and_sc "Sserver" (n4 :: n7 :: nil) (nil, nil).


(** Concurrent bag specification from the HOCAP paper.
    "Modular Reasoning about Separation of Concurrent Data Structures"
    <http://www.kasv.dk/articles/hocap-ext.pdf>

This file: abstract bag specification
*)
From iris.heap_lang Require Export lifting notation.
From iris.base_logic.lib Require Export invariants.
From stdpp Require Import gmultiset.
Set Default Proof Using "Type".

Structure bag Σ `{!heapG Σ} := Bag {
  (* -- operations -- *)
  newBag : val;
  pushBag : val;
  popBag : val;
  (* -- predicates -- *)
  (* name is used to associate bag_contents with is_bag *)
  name : Type;
  is_bag (N: namespace) (γ: name) (b: val) : iProp Σ;
  bag_contents (γ: name) (X: gmultiset val) : iProp Σ;
  (* -- ghost state theory -- *)
  is_bag_persistent N γ b : Persistent (is_bag N γ b);
  bag_contents_timeless γ X : Timeless (bag_contents γ X);
  bag_contents_agree γ X Y: bag_contents γ X -∗ bag_contents γ Y -∗ ⌜X = Y⌝;
  bag_contents_update γ X X' Y:
    bag_contents γ X ∗ bag_contents γ X' ==∗
    bag_contents γ Y ∗ bag_contents γ Y;
  (* -- operation specs -- *)
  newBag_spec N :
    {{{ True }}} newBag #() {{{ x γ, RET x; is_bag N γ x ∗ bag_contents γ ∅ }}};
  pushBag_spec N P Q γ b v :
    □ (∀ (X : gmultiset val), bag_contents γ X ∗ P
                     ={⊤∖↑N}=∗ ▷ (bag_contents γ ({[v]} ⊎ X) ∗ Q)) -∗
    {{{ is_bag N γ b ∗ P }}}
      pushBag b (of_val v)
    {{{ RET #(); Q }}};
  popBag_spec N P Q γ b :
    □ (∀ (X : gmultiset val) (y : val),
               bag_contents γ ({[y]} ⊎ X) ∗ P
               ={⊤∖↑N}=∗ ▷ (bag_contents γ X ∗ Q (SOMEV y))) -∗
    □ (bag_contents γ ∅ ∗ P ={⊤∖↑N}=∗ ▷ (bag_contents γ ∅ ∗ Q NONEV)) -∗
    {{{ is_bag N γ b ∗ P }}}
      popBag b
    {{{ v, RET v; Q v }}};
}.

Arguments newBag {_ _} _.
Arguments popBag {_ _} _.
Arguments pushBag {_ _} _.
Arguments newBag_spec {_ _} _ _ _.
Arguments popBag_spec {_ _} _ _ _ _ _ _.
Arguments pushBag_spec {_ _} _ _ _ _ _ _ _.
Arguments is_bag {_ _} _ _ _ _.
Arguments bag_contents {_ _} _ _.
Arguments bag_contents_update {_ _} _ {_ _ _}.
Existing Instances is_bag_persistent bag_contents_timeless.


Require Import Bedrock.Platform.Cito.Syntax.
Require Import Bedrock.IL.

Set Implicit Arguments.

Inductive args_not_too_long : Stmt -> Prop :=
  | CallCase : forall x f args, goodSize (2 + length args) -> args_not_too_long (Call x f args)
  | SkipCase : args_not_too_long Skip
  | SeqCase : forall a b, args_not_too_long a -> args_not_too_long b -> args_not_too_long (Seq a b)
  | IfCase : forall e t f, args_not_too_long t -> args_not_too_long f -> args_not_too_long (If e t f)
  | WhileCase : forall e s, args_not_too_long s -> args_not_too_long (While e s)
  | LabelCase : forall x l, args_not_too_long (Label x l)
  | AssignCase : forall x e, args_not_too_long (Syntax.Assign x e).

Definition wellformed := args_not_too_long.


Require Import LTS.
Require Import IOTS.
Require Import TTS.
Require Import BE_trans_set_creator.
Require Import BE_syntax.
Require Import Coq.Lists.ListSet.
Require Import Coq.Lists.List.
Import Coq.Lists.List.ListNotations.
Require Import String.

Local Open Scope string_scope.

Definition event_to_str (e : Event) : string :=
  match e with
  | InternalEvent => "τ"
  | ExternalEvent n => n
  end.

Fixpoint process_behaviour_to_str (B : ProcessBehaviour) : string :=
  match B with
  | Prefix e B' => "(" ++ event_to_str e ++ ";" ++ process_behaviour_to_str B' ++ ")"
  | Choice (Values Bs) =>
    let fix expand_choice (l : list ProcessBehaviour) : string :=
       match l with
       | nil => "STOP"
       | B' :: nil => process_behaviour_to_str B'
       | B' :: tl => process_behaviour_to_str B' ++ " [] " ++ expand_choice tl
       end
    in "( " ++ expand_choice Bs ++ ")"
  | Parallel B1 g B2 =>
    "(" ++ process_behaviour_to_str B1 ++ " |[" ++ (concat ", " g) ++ "]| " ++
    process_behaviour_to_str B2 ++ ")"
  | Hide B' g =>
    "(HIDE { " ++ (concat ", " g) ++ " } IN " ++ process_behaviour_to_str B' ++ ")"
  | ProcessInstantiation p => p
  end.

Fixpoint generate_dot {State Event : Type} (lts : set (State * Event * State))
  (state_to_str : State -> string) (event_to_str : Event -> string) : string :=
  match lts with
  | nil => ""
  | (P, e, Q) :: tl =>
    " <" ++ state_to_str P ++ "> -> <" ++ state_to_str Q ++ ">" ++
    " [label=<" ++ event_to_str e ++ ">];" ++ (generate_dot tl state_to_str event_to_str)
  end.

Definition style_initial_state {State : Type} (q0 : State) (state_to_str : State -> string) : string :=
  "<" ++ state_to_str q0 ++ "> [style=bold, color=red];".

Definition generate_dot_behaviour_expressions
  (start_process : ProcessName) (ctx : BehaviourExpressions) (i : nat): string :=
  match createBehaviourTransSet ctx start_process i with
  | Some lts =>
    "digraph " ++ start_process ++ "_LTS { "
      ++
      match getProcessBehaviour start_process ctx with
      | Some B => style_initial_state B process_behaviour_to_str
      | _ => ""
      end
      ++
      (generate_dot lts process_behaviour_to_str event_to_str)
      ++ " }"
  | _ => ""
  end.

Definition digit_to_str (n : nat) : string :=
  match n with
  | 0 => "0"
  | 1 => "1"
  | 2 => "2"
  | 3 => "3"
  | 4 => "4"
  | 5 => "5"
  | 6 => "6"
  | 7 => "7"
  | 8 => "8"
  | _ => "9"
  end.

Fixpoint nat_to_str' (n i : nat) : string :=
  match i with
  | 0 => "0"
  | S i' => if Nat.ltb n 9
            then digit_to_str n
            else nat_to_str' (Nat.div n 10) i' ++ digit_to_str (Nat.modulo n 10)
  end.

Definition nat_to_str (n : nat) : string := nat_to_str' n n.

Definition transition_label_to_str (l : transition_label) : string :=
  match l with
  | event e => e
  | tau => "τ"
  end.

Definition generate_dot_lts (lts : LTS) : string :=
  "digraph LTS { "
    ++ style_initial_state lts.(q0) nat_to_str
    ++ (generate_dot lts.(T) nat_to_str transition_label_to_str)
    ++ " }".

Definition iolts_transition_label_to_str (Li : set label)
    (l : transition_label) : string :=
  match l with
  | event e =>
      if set_mem string_dec e Li
      then "?" ++ e
      else "!" ++ e
  | tau => "τ"
  end.

Definition generate_dot_IOLTS (iolts : IOLTS) : string :=
  "digraph IOLTS { "
  ++ style_initial_state iolts.(sc_lts).(lts).(q0) nat_to_str
  ++ (generate_dot iolts.(sc_lts).(lts).(T) nat_to_str
      (iolts_transition_label_to_str iolts.(L_i)))
  ++ " }".

Definition generate_dot_s_IOLTS (s_iolts : s_IOLTS) : string :=
  "digraph s_IOLTS { "
  ++ style_initial_state s_iolts.(iolts).(sc_lts).(lts).(q0) nat_to_str
  ++ (generate_dot s_iolts.(iolts).(sc_lts).(lts).(T) nat_to_str
      (iolts_transition_label_to_str s_iolts.(iolts).(L_i)))
  ++ generate_dot (map (fun x => (x, "δ", x)) s_iolts.(Ts)) nat_to_str id
  ++ " }".

Definition tts_transition_label_to_str (theta : label) (imp_Li : set label)
    (l : transition_label) : string :=
  match l with
  | event e =>
      if string_dec e theta
      then "θ"
      else
        if set_mem string_dec e imp_Li
        then "?" ++ e
        else "!" ++ e
  | tau => "τ"
  end.

Definition generate_dot_TTS (tts : TTS) : string :=
  "digraph TTS { "
  ++ style_initial_state tts.(iots).(embedded_iolts).(sc_lts).(lts).(q0) nat_to_str
  ++ "<" ++ nat_to_str tts.(pass_state) ++ "> [style=bold, label=pass];"
  ++ "<" ++ nat_to_str tts.(fail_state) ++ "> [style=bold, label=fail];"
  ++ (generate_dot tts.(iots).(embedded_iolts).(sc_lts).(lts).(T) nat_to_str
      (tts_transition_label_to_str tts.(theta) (tts).(imp_Li)))
  ++ " }".

Local Close Scope string_scope.


Require Import Coq.micromega.Lia.
Require Import Coq.Program.Program.
Require Import Coq.Classes.EquivDec.
Require Coq.Logic.Eqdep_dec.
Require Coq.Lists.List.

Require Import Leapfrog.FinType.
Require Import Leapfrog.Bisimulations.Semantic.
Require Import Leapfrog.HAList.
Require Import Leapfrog.WPProofs.
Require Import Leapfrog.Sum.
Require Import Leapfrog.P4automaton.
Require Import Leapfrog.Ntuple.
Require Leapfrog.Syntax.

Require Import MirrorSolve.HLists.

Open Scope list_scope.

Section SumProofs.
  Set Implicit Arguments.

  (* State identifiers. *)
  Variable (St1: Type).
  Context `{St1_eq_dec: EquivDec.EqDec St1 eq}.
  Context `{St1_finite: @Finite St1 _ St1_eq_dec}.

  Variable (St2: Type).
  Context `{St2_eq_dec: EquivDec.EqDec St2 eq}.
  Context `{St2_finite: @Finite St2 _ St2_eq_dec}.

  (* Header identifiers. *)
  Variable (Hdr1: Type).
  Variable (Hdr1_sz : Hdr1 -> nat).
  Context `{Hdr1_eq_dec: EquivDec.EqDec Hdr1 eq}.
  Context `{Hdr1_finite: @Finite Hdr1 _ Hdr1_eq_dec}.

  Variable (Hdr2: Type).
  Variable (Hdr2_sz : Hdr2 -> nat).
  Context `{Hdr2_eq_dec: EquivDec.EqDec Hdr2 eq}.
  Context `{Hdr2_finite: @Finite Hdr2 _ Hdr2_eq_dec}.

  Variable (a1: Syntax.t St1 Hdr1_sz).
  Variable (a2: Syntax.t St2 Hdr2_sz).

  Notation St := (St1 + St2)%type.

  Lemma find1 (s: Syntax.store Hdr1 Hdr1_sz) (s': Syntax.store Hdr2 Hdr2_sz) h:
    Syntax.find _ _ (inl h) (sum_stores s s') =
    Syntax.find _ _ h s.
  Proof.
    unfold Syntax.find.
    unfold Syntax.Env.get.
    unfold sum_stores.
    set (t1 := (HList.map_inj (fun h0 : Hdr Hdr1 Hdr2 => Syntax.v (Hdr_sz Hdr1_sz Hdr2_sz h0)) inl s)).
    set (l1 := List.map (@inl _ Hdr2) (enum Hdr1)) in *.
    assert (pf: List.In (inl h) l1).
    {
      unfold l1.
      rewrite List.in_map_iff.
      eexists.
      split; eauto.
      apply elem_of_enum.
    }
    eapply eq_trans.
    eapply HList.get_app_l with (t1 := t1) (pf' := pf); auto.
    unfold t1.
    erewrite HList.get_map_inj; eauto.
    intros.
    congruence.
  Qed.

  Lemma find2 (s: Syntax.store Hdr1 Hdr1_sz) (s': Syntax.store Hdr2 Hdr2_sz) h:
    Syntax.find _ _ (inr h) (sum_stores s s') =
    Syntax.find _ _ h s'.
  Proof.
    unfold Syntax.find.
    unfold Syntax.Env.get.
    unfold sum_stores.
    set (t2 := (HList.map_inj (fun h0 : Hdr Hdr1 Hdr2 => Syntax.v (Hdr_sz Hdr1_sz Hdr2_sz h0)) inr s')).
    set (l2 := List.map (@inr Hdr1 _) (enum Hdr2)) in *.
    assert (pf: List.In (inr h) l2).
    {
      unfold l2.
      rewrite List.in_map_iff.
      eexists.
      split; eauto.
      apply elem_of_enum.
    }
    eapply eq_trans.
    eapply HList.get_app_r with (t2 := t2) (pf' := pf);
      rewrite List.in_map_iff; firstorder congruence.
    unfold t2.
    erewrite HList.get_map_inj; eauto.
    intros.
    congruence.
  Qed.

  Lemma assign1 (s: Syntax.store Hdr1 Hdr1_sz) (s': Syntax.store Hdr2 Hdr2_sz) hdr v1 v2:
    v1 = v2 ->
    Syntax.assign _ _ (inl hdr) v1 (sum_stores s s') =
    sum_stores (Syntax.assign _ _ hdr v2 s) s'.
  Proof.
    intros; subst v1.
    unfold Syntax.store in *.
    simpl in *.
    unfold sum_stores.
    unfold Syntax.assign, Syntax.Env.bind.
    pose proof (HList.bind_app_l _ (HList.map_inj (fun h : Hdr Hdr1 Hdr2 => Syntax.v (Hdr_sz Hdr1_sz Hdr2_sz h)) inl s)
                                   (HList.map_inj (fun h : Hdr Hdr1 Hdr2 => Syntax.v (Hdr_sz Hdr1_sz Hdr2_sz h)) inr s')).
    erewrite H.
    f_equal.
    erewrite HList.bind_map_inj with (pf' := elem_of_enum hdr) by (intros; congruence).
    reflexivity.
    Unshelve.
    pose proof (@elem_of_enum Hdr1 _ _ _ hdr).
    apply List.in_map_iff.
    eexists.
    intuition eauto.
  Qed.

  Lemma assign2 (s: Syntax.store Hdr1 Hdr1_sz) (s': Syntax.store Hdr2 Hdr2_sz) hdr v1 v2:
    v1 = v2 ->
    Syntax.assign _ _ (inr hdr) v1 (sum_stores s s') =
    sum_stores s (Syntax.assign _ _ hdr v2 s').
  Proof.
    intros; subst v1.
    unfold Syntax.store in *.
    simpl in *.
    unfold sum_stores.
    unfold Syntax.assign, Syntax.Env.bind.
    pose proof (HList.bind_app_r _ (HList.map_inj (fun h : Hdr Hdr1 Hdr2 => Syntax.v (Hdr_sz Hdr1_sz Hdr2_sz h)) inl s)
                                   (HList.map_inj (fun h : Hdr Hdr1 Hdr2 => Syntax.v (Hdr_sz Hdr1_sz Hdr2_sz h)) inr s')).
    erewrite H
      by (rewrite List.in_map_iff; firstorder congruence).
    f_equal.
    erewrite HList.bind_map_inj with (pf' := elem_of_enum hdr); eauto.
    intros; congruence.
    Unshelve.
    pose proof (@elem_of_enum Hdr2 _ _ _ hdr).
    apply List.in_map_iff.
    eexists.
    intuition eauto.
  Qed.

  Lemma size1 (q: St1):
    Syntax.P4A.size' (Syntax.interp (sum a1 a2)) (inl (inl q)) = size' (Syntax.interp a1) (inl q).
  Proof.
    autorewrite with size'; simpl.
    unfold Syntax.size.
    unfold sum; simpl.
    now rewrite Syntax.state_fmapSH_size.
  Qed.

  Lemma size2 (q: St2):
    size' (Syntax.interp (sum a1 a2)) (inl (inr q)) = size' (Syntax.interp a2) (inl q).
  Proof.
    autorewrite with size'; simpl.
    unfold Syntax.size.
    unfold sum; simpl.
    now rewrite Syntax.state_fmapSH_size.
  Qed.

  Transparent Syntax.expr_fmapH.
  Transparent Syntax.eval_expr.

  Lemma eval_expr1 (s: Syntax.store Hdr1 Hdr1_sz) (s': Syntax.store Hdr2 Hdr2_sz) n e:
    Syntax.eval_expr _ _ n (sum_stores s s') (Syntax.expr_fmapH _ inl (fun _ => eq_refl) e) =
    Syntax.eval_expr _ _ n s e.
  Proof.
    revert s s'; dependent induction e; intros; simpl.
    - apply find1.
    - reflexivity.
    - now rewrite IHe.
    - now rewrite IHe1, IHe2.
  Qed.

  Lemma eval_expr2 (s: Syntax.store Hdr1 Hdr1_sz) (s': Syntax.store Hdr2 Hdr2_sz) n e:
    Syntax.eval_expr _ _ n (sum_stores s s') (Syntax.expr_fmapH _ inr (fun _ => eq_refl) e) =
    Syntax.eval_expr _ _ n s' e.
  Proof.
    revert s s'; dependent induction e; intros; simpl.
    - apply find2.
    - reflexivity.
    - now rewrite IHe.
    - now rewrite IHe1, IHe2.
  Qed.

  Opaque Syntax.expr_fmapH.
  Opaque Syntax.eval_expr.

  Transparent Syntax.op_fmapH.
  Transparent Syntax.eval_op.

  Lemma eval_op1 (s: Syntax.store Hdr1 Hdr1_sz) (s': Syntax.store Hdr2 Hdr2_sz) o buf1 buf2:
    buf1 ~= buf2 ->
    Syntax.eval_op _ _ (sum_stores s s') (Syntax.op_fmapH _ inl (fun _ => eq_refl) o) buf1 =
    sum_stores (Syntax.eval_op _ _ s o buf2) s'.
  Proof.
    revert s s'; dependent induction o; intros; simpl.
    - reflexivity.
    - erewrite IHo1; auto.
      erewrite IHo2; auto.
      + repeat rewrite Ntuple.rewrite_size_jmeq.
        apply t2l_eq.
        repeat rewrite Ntuple.t2l_n_tuple_skip_n.
        f_equal.
        * apply Syntax.op_fmapH_size.
        * now apply eq_t2l.
      + repeat rewrite Ntuple.rewrite_size_jmeq.
        apply t2l_eq.
        repeat rewrite Ntuple.t2l_n_tuple_take_n.
        f_equal.
        * apply Syntax.op_fmapH_size.
        * now apply eq_t2l.
    - erewrite assign1; auto.
      f_equal.
      apply JMeq_eq; auto.
    - erewrite assign1; auto.
      apply eval_expr1.
  Qed.

  Lemma eval_op2 (s: Syntax.store Hdr1 Hdr1_sz) (s': Syntax.store Hdr2 Hdr2_sz) o buf1 buf2:
    buf1 ~= buf2 ->
    Syntax.eval_op _ _ (sum_stores s s') (Syntax.op_fmapH _ inr (fun _ => eq_refl) o) buf1 =
    sum_stores s (Syntax.eval_op _ _ s' o buf2).
  Proof.
    revert s s'; dependent induction o; intros; simpl.
    - reflexivity.
    - erewrite IHo1, IHo2; auto.
      + repeat rewrite Ntuple.rewrite_size_jmeq.
        apply t2l_eq.
        repeat rewrite Ntuple.t2l_n_tuple_skip_n.
        f_equal.
        * apply Syntax.op_fmapH_size.
        * now apply eq_t2l.
      + repeat rewrite Ntuple.rewrite_size_jmeq.
        apply t2l_eq.
        repeat rewrite Ntuple.t2l_n_tuple_take_n.
        f_equal.
        * apply Syntax.op_fmapH_size.
        * now apply eq_t2l.
    - erewrite assign2; auto.
      f_equal.
      apply JMeq_eq; auto.
    - erewrite assign2; auto.
      apply eval_expr2.
  Qed.

  Opaque Syntax.eval_op.
  Opaque Syntax.op_fmapH.

  Lemma update1 (s: Syntax.store Hdr1 Hdr1_sz) (s': Syntax.store Hdr2 Hdr2_sz) (q: St1) buf1 buf2:
    buf1 ~= buf2 ->
    Syntax.P4A.update (Syntax.interp (sum a1 a2))
                      (inl q)
                      buf1
                      (sum_stores s s') =
    sum_stores (Syntax.P4A.update (Syntax.interp a1) q buf2 s) s'
  .
  Proof.
    intros.
    unfold Syntax.P4A.update; simpl.
    unfold Syntax.update; simpl.
    erewrite eval_op1; auto.
    repeat f_equal.
    now repeat rewrite eq_rect_jmeq.
  Qed.

  Lemma update2 (s: Syntax.store Hdr1 Hdr1_sz) (s': Syntax.store Hdr2 Hdr2_sz) (q: St2) buf1 buf2:
    buf1 ~= buf2 ->
    Syntax.P4A.update (Syntax.interp (sum a1 a2))
                      (inr q)
                      buf1
                      (sum_stores s s') =
    sum_stores s (Syntax.P4A.update (Syntax.interp a2) q buf2 s')
  .
  Proof.
    intros.
    unfold Syntax.P4A.update; simpl.
    unfold Syntax.update; simpl.
    erewrite eval_op2; auto.
    repeat f_equal.
    now repeat rewrite eq_rect_jmeq.
  Qed.

  Lemma eval_sel1:
    forall s s' ty (c: Syntax.cond Hdr1_sz ty) cases default,
      Syntax.eval_sel St (Hdr Hdr1 Hdr2) (Hdr_sz Hdr1_sz Hdr2_sz) (sum_stores s s')
                      (Syntax.cond_fmapH (Hdr_sz Hdr1_sz Hdr2_sz) inl (fun _ => eq_refl) c)
                      (List.map (Syntax.sel_case_fmapS inl) cases) (Syntax.state_ref_fmapS inl default) =
        match Syntax.eval_sel St1 Hdr1 Hdr1_sz s c cases default with
        | inl q' => inl (inl q')
        | inr b => inr b
        end.
  Proof.
    dependent induction cases; intros.
    - apply eq_refl.
    - simpl.
      rewrite IHcases.
      assert (
      Syntax.match_pat Hdr1 Hdr1_sz s c (Syntax.sc_pat a)
                       =
      Syntax.match_pat (Hdr Hdr1 Hdr2) (Hdr_sz Hdr1_sz Hdr2_sz) (sum_stores s s')
        (Syntax.cond_fmapH (Hdr_sz Hdr1_sz Hdr2_sz) inl (fun _ => eq_refl) c)
        (Syntax.sc_pat a)).
      {
        set (P ty (pat: Syntax.pat ty) cond :=
               Syntax.match_pat Hdr1 Hdr1_sz s cond pat
               =
                 Syntax.match_pat (Hdr Hdr1 Hdr2) (Hdr_sz Hdr1_sz Hdr2_sz) (sum_stores s s')
                                  (Syntax.cond_fmapH (Hdr_sz Hdr1_sz Hdr2_sz) inl (fun _ => eq_refl) cond)
                                  pat).
        cut (P _ (Syntax.sc_pat a) c); simpl; auto.
        generalize (Syntax.sc_pat a).
        generalize c.
        generalize ty.
        eapply pat_cond_ind; intros; unfold P in *.
        - unfold Syntax.cond_fmapH;
          autorewrite with match_pat.
          erewrite eval_expr1.
          auto.
        - auto.
        - autorewrite with match_pat.
          rewrite H, H0.
          auto.
      }
      simpl in *; rewrite <- H.
      destruct (Syntax.match_pat Hdr1 Hdr1_sz s c (Syntax.sc_pat a)); eauto.
  Qed.

  Lemma eval_sel2:
    forall s s' ty (c: Syntax.cond Hdr2_sz ty) cases default,
      Syntax.eval_sel St (Hdr Hdr1 Hdr2) (Hdr_sz Hdr1_sz Hdr2_sz) (sum_stores s s')
                      (Syntax.cond_fmapH (Hdr_sz Hdr1_sz Hdr2_sz) inr (fun _ => eq_refl) c)
                      (List.map (Syntax.sel_case_fmapS inr) cases) (Syntax.state_ref_fmapS inr default) =
        match Syntax.eval_sel St2 Hdr2 Hdr2_sz s' c cases default with
        | inl q' => inl (inr q')
        | inr b => inr b
        end.
  Proof.
    dependent induction cases; intros.
    - apply eq_refl.
    - simpl.
      rewrite IHcases.
      assert (
      Syntax.match_pat Hdr2 Hdr2_sz s' c (Syntax.sc_pat a)
                       =
      Syntax.match_pat (Hdr Hdr1 Hdr2) (Hdr_sz Hdr1_sz Hdr2_sz) (sum_stores s s')
        (Syntax.cond_fmapH (Hdr_sz Hdr1_sz Hdr2_sz) inr (fun _ => eq_refl) c)
        (Syntax.sc_pat a)).
      {
        set (P ty (pat: Syntax.pat ty) cond :=
               Syntax.match_pat Hdr2 Hdr2_sz s' cond pat
               =
                 Syntax.match_pat (Hdr Hdr1 Hdr2) (Hdr_sz Hdr1_sz Hdr2_sz) (sum_stores s s')
                                  (Syntax.cond_fmapH (Hdr_sz Hdr1_sz Hdr2_sz) inr (fun _ => eq_refl) cond)
                                  pat).
        cut (P _ (Syntax.sc_pat a) c); simpl; auto.
        generalize (Syntax.sc_pat a).
        generalize c.
        generalize ty.
        eapply pat_cond_ind; intros; unfold P in *.
        - unfold Syntax.cond_fmapH;
          autorewrite with match_pat.
          erewrite eval_expr2.
          auto.
        - auto.
        - autorewrite with match_pat.
          rewrite H, H0.
          auto.
      }
      simpl in *; rewrite <- H.
      destruct (Syntax.match_pat _ _ _ _ _); eauto.
  Qed.

  Lemma transition1 (s: Syntax.store Hdr1 Hdr1_sz) (s': Syntax.store Hdr2 Hdr2_sz) (q: St1):
    Syntax.P4A.transitions (Syntax.interp (sum a1 a2)) (inl q) (sum_stores s s') =
    match Syntax.P4A.transitions (Syntax.interp a1) q s with
    | inl q' => inl (inl q')
    | inr b => inr b
    end.
  Proof.
    simpl.
    unfold Syntax.transitions, Syntax.eval_trans.
    simpl in *.
    destruct (Syntax.st_trans (Syntax.t_states a1 q)); simpl.
    - unfold Syntax.state_ref_fmapS.
      reflexivity.
    - apply eval_sel1.
  Qed.

  Lemma transition2 (s: Syntax.store Hdr1 Hdr1_sz) (s': Syntax.store Hdr2 Hdr2_sz) (q: St2):
    Syntax.P4A.transitions (Syntax.interp (sum a1 a2)) (inr q) (sum_stores s s') =
    match Syntax.P4A.transitions (Syntax.interp a2) q s' with
    | inl q' => inl (inr q')
    | inr b => inr b
    end.
  Proof.
    simpl.
    unfold Syntax.transitions, Syntax.eval_trans.
    simpl in *.
    destruct (Syntax.st_trans (Syntax.t_states a2 q)); simpl.
    - unfold Syntax.state_ref_fmapS.
      reflexivity.
    - apply eval_sel2.
  Qed.

  Inductive embed_conf1:
    configuration (Syntax.interp a1) ->
    configuration (Syntax.interp (sum a1 a2)) ->
    Prop :=
  | EmbedConf1Inl:
    forall q
      st
      (c1: configuration (Syntax.interp a1))
      (c1': configuration (Syntax.interp (sum a1 a2))),
      conf_state c1 = inl q ->
      conf_state c1' = inl (inl q) ->
      conf_buf c1 ~= conf_buf c1' ->
      sum_stores (conf_store c1) st = conf_store c1' ->
      embed_conf1 c1 c1'
  | EmbedConf1Inr:
    forall q
      st
      (c1: configuration (Syntax.interp a1))
      (c1': configuration (Syntax.interp (sum a1 a2))),
      conf_state c1 = inr q ->
      conf_state c1' = inr q ->
      conf_buf c1 ~= conf_buf c1' ->
      sum_stores (conf_store c1) st = conf_store c1' ->
      embed_conf1 c1 c1'.

  Inductive embed_conf2:
    configuration (Syntax.interp a2) ->
    configuration (Syntax.interp (sum a1 a2)) ->
    Prop :=
  | EmbedConf2Inl:
    forall q
      st
      (c2: configuration (Syntax.interp a2))
      (c2': configuration (Syntax.interp (sum a1 a2))),
      conf_state c2 = inl q ->
      conf_state c2' = inl (inr q) ->
      conf_buf c2 ~= conf_buf c2' ->
      sum_stores st (conf_store c2) = conf_store c2' ->
      embed_conf2 c2 c2'
  | EmbedConf2Inr:
    forall q
      st
      (c2: configuration (Syntax.interp a2))
      (c2': configuration (Syntax.interp (sum a1 a2))),
      conf_state c2 = inr q ->
      conf_state c2' = inr q ->
      conf_buf c2 ~= conf_buf c2' ->
      sum_stores st (conf_store c2) = conf_store c2' ->
      embed_conf2 c2 c2'.

  Inductive split_bisim (R: configuration (Syntax.interp (sum a1 a2)) ->
                            configuration (Syntax.interp (sum a1 a2)) ->
                            Prop)
    : configuration (Syntax.interp a1) ->
      configuration (Syntax.interp a2) ->
      Prop :=
  | MkBisim: forall c1 c2 c1' c2',
      embed_conf1 c1 c1' ->
      embed_conf2 c2 c2' ->
      R c1' c2' ->
      split_bisim R c1 c2.

  Lemma embed_accepting1:
    forall c1 c1',
      embed_conf1 c1 c1' ->
      accepting c1 <-> accepting c1'.
  Proof.
    unfold accepting.
    destruct c1, c1'.
    split; intros.
    - inversion H; subst; simpl in *; congruence.
    - inversion H; subst; simpl in *; congruence.
  Qed.

  Lemma embed_accepting2:
    forall c2 c2',
      embed_conf2 c2 c2' ->
      accepting c2 <-> accepting c2'.
  Proof.
    unfold accepting.
    destruct c2, c2'.
    split; intros.
    - inversion H; subst; simpl in *; congruence.
    - inversion H; subst; simpl in *; congruence.
  Qed.

  Lemma embed_step1:
    forall c1 c1' b,
      embed_conf1 c1 c1' ->
      embed_conf1 (step c1 b) (step c1' b).
  Proof.
    intros.
    inversion H; subst;
    assert (conf_buf_len c1 = conf_buf_len c1')
      by (eapply inv_jmeq_size; exact H2).
    - unfold step.
      destruct (Compare_dec.le_lt_dec _ _),
               (Compare_dec.le_lt_dec _ _); try lia.
      + destruct c1, c1'; simpl in *.
        destruct conf_state, conf_state0; try discriminate.
        autorewrite with transitions'.
        autorewrite with update'.
        inversion H0; inversion H1; subst.
        erewrite update1.
        * match goal with
          | |- context[Syntax.P4A.transitions _ q ?c] =>
            set (conf_store_new := c)
          end.
          match goal with
          | |- context[Syntax.P4A.transitions _ (inl q) ?c] =>
            set (conf_store_new' := c)
          end.
          assert (conf_store_new' = sum_stores conf_store_new st)
            by (subst conf_store_new'; reflexivity).
          pose proof (transition1 conf_store_new st q).
          rewrite <- H3 in H4; simpl in *.
          destruct (Syntax.transitions St1 Hdr1 Hdr1_sz a1 q conf_store_new).
          -- eapply EmbedConf1Inl; simpl; now subst.
          -- eapply EmbedConf1Inr; simpl; now subst.
        * rewrite H2.
          erewrite <- Ntuple.rewrite_size_jmeq; symmetry.
          erewrite <- Ntuple.rewrite_size_jmeq; symmetry.
          unfold Ntuple.rewrite_size.
          repeat rewrite rew_opp_l.
          now apply pair_proper.
      + exfalso.
        replace (conf_state c1')
          with (inl (B := bool) (inl (B := St2) q))
          in l0 by now f_equal.
        rewrite size1 in l0.
        rewrite H0, H4 in l.
        eapply PeanoNat.Nat.lt_irrefl.
        eapply PeanoNat.Nat.le_lt_trans.
        * apply l.
        * apply l0.
      + exfalso.
        replace (conf_state c1')
          with (inl (B := bool) (inl (B := St2) q))
          in l0 by now f_equal.
        rewrite size1 in l0.
        rewrite H0, H4 in l.
        eapply PeanoNat.Nat.lt_irrefl.
        eapply PeanoNat.Nat.lt_le_trans.
        * apply l.
        * apply l0.
      + apply EmbedConf1Inl with (q := q) (st := st); auto; simpl.
        now apply pair_proper.
    - unfold step.
      destruct (Compare_dec.le_lt_dec _ _),
               (Compare_dec.le_lt_dec _ _).
      + destruct c1, c1'; simpl in *.
        destruct conf_state, conf_state0; try discriminate.
        autorewrite with transitions'.
        autorewrite with update'.
        now apply EmbedConf1Inr with (q := false) (st := st).
      + exfalso.
        replace (conf_state c1')
          with (inr (A := St) q)
          in l0 by now f_equal.
        autorewrite with size' in l0.
        lia.
      + exfalso.
        replace (conf_state c1)
          with (inr (A := St1) q)
          in l by now f_equal.
        autorewrite with size' in l.
        lia.
      + exfalso.
        replace (conf_state c1)
          with (inr (A := St1) q)
          in l by now f_equal.
        autorewrite with size' in l.
        lia.
  Qed.

  Lemma embed_step2:
    forall c2 c2' b,
      embed_conf2 c2 c2' ->
      embed_conf2 (step c2 b) (step c2' b).
  Proof.
    intros.
    inversion H; subst.
    - assert (conf_buf_len c2 = conf_buf_len c2')
        by (eapply inv_jmeq_size; exact H2).
      unfold step.
      destruct (Compare_dec.le_lt_dec _ _),
               (Compare_dec.le_lt_dec _ _); try lia.
      + destruct c2, c2'; simpl in *.
        destruct conf_state, conf_state0; try discriminate.
        autorewrite with transitions'.
        autorewrite with update'.
        inversion H0; inversion H1; subst.
        erewrite update2.
        * match goal with
          | |- context[Syntax.P4A.transitions _ q ?c] =>
            set (conf_store_new := c)
          end.
          match goal with
          | |- context[Syntax.P4A.transitions _ (inr q) ?c] =>
            set (conf_store_new' := c)
          end.
          assert (conf_store_new' = sum_stores st conf_store_new)
            by (subst conf_store_new'; reflexivity).
          pose proof (transition2 st conf_store_new q).
          rewrite <- H3 in H4; simpl in *.
          destruct (Syntax.transitions _ _ _ a2 q conf_store_new).
          -- eapply EmbedConf2Inl; simpl; now subst.
          -- eapply EmbedConf2Inr; simpl; now subst.
        * rewrite H2.
          erewrite <- Ntuple.rewrite_size_jmeq; symmetry.
          erewrite <- Ntuple.rewrite_size_jmeq; symmetry.
          unfold Ntuple.rewrite_size.
          repeat rewrite rew_opp_l.
          now apply pair_proper.
      + exfalso.
        replace (conf_state c2')
          with (inl (B := bool) (inr (A := St1) q))
          in l0 by now f_equal.
        rewrite size2 in l0.
        rewrite H0, H4 in l.
        eapply PeanoNat.Nat.lt_irrefl.
        eapply PeanoNat.Nat.le_lt_trans.
        * apply l.
        * apply l0.
      + exfalso.
        replace (conf_state c2')
          with (inl (B := bool) (inr (A := St1) q))
          in l0 by now f_equal.
        rewrite size2 in l0.
        rewrite H0, H4 in l.
        eapply PeanoNat.Nat.lt_irrefl.
        eapply PeanoNat.Nat.lt_le_trans.
        * apply l.
        * apply l0.
      + apply EmbedConf2Inl with (q := q) (st := st); auto; simpl.
        now apply pair_proper.
    - unfold step.
      destruct (Compare_dec.le_lt_dec _ _),
               (Compare_dec.le_lt_dec _ _).
      + destruct c2, c2'; simpl in *.
        destruct conf_state, conf_state0; try discriminate.
        autorewrite with transitions'.
        autorewrite with update'.
        now apply EmbedConf2Inr with (q := false) (st := st).
      + exfalso.
        replace (conf_state c2')
          with (inr (A := St) q)
          in l0 by now f_equal.
        autorewrite with size' in l0.
        lia.
      + exfalso.
        replace (conf_state c2)
          with (inr (A := St2) q)
          in l by now f_equal.
        autorewrite with size' in l.
        lia.
      + exfalso.
        replace (conf_state c2)
          with (inr (A := St2) q)
          in l by now f_equal.
        autorewrite with size' in l.
        lia.
  Qed.

  Lemma split_is_bisim:
    forall R,
      bisimulation R ->
      bisimulation (split_bisim R).
  Proof.
    unfold bisimulation; intros.
    inversion H0; subst.
    apply H in H3; destruct H3.
    split.
    - erewrite embed_accepting1 by eauto.
      erewrite embed_accepting2 by eauto.
      auto.
    - intros.
      econstructor.
      + apply embed_step1, H1.
      + apply embed_step2, H2.
      + apply H4.
  Qed.

  Lemma sum_thing:
    forall (q1: St1) (q2: St2),
      lang_equiv_state
        (Syntax.interp (sum a1 a2))
        (Syntax.interp (sum a1 a2))
        (inl q1)
        (inr q2) ->
      lang_equiv_state
        (Syntax.interp a1)
        (Syntax.interp a2)
        q1
        q2.
  Proof.
    unfold lang_equiv_state.
    intros.
    apply bisimilar_iff_lang_equiv.
    setoid_rewrite bisimilar_iff_lang_equiv in H.
    unfold bisimilar.
    simpl in s1, s2.
    pose (sum_stores s1 s2) as s0.
    specialize (H s0 s0).
    destruct H as [R [Hbisim Hrel]].
    exists (split_bisim R).
    split.
    - auto using split_is_bisim.
    - econstructor; eauto.
      + econstructor; simpl; eauto.
        unfold s0.
        reflexivity.
      + econstructor; simpl; eauto.
        unfold s0.
        reflexivity.
  Qed.

End SumProofs.


Set Implicit Arguments.

Require Import Bedrock.Platform.Cito.Syntax.
Import String Memory IL SyntaxExpr.
Require Import Bedrock.Platform.Cito.Notations3.
Require Import Bedrock.Platform.Cito.Semantics.
Require Import Bedrock.Platform.Cito.GeneralTactics.
Import SemanticsExpr.

Require Import Bedrock.StringSet.
Import StringSet.
Require Import Bedrock.Platform.Cito.StringSetFacts.
Require Import Bedrock.Platform.Cito.StringSetTactics.

Definition SET := t.

Ltac openhyp' :=
  repeat match goal with
           | H : context [In_dec ?A ?B] |- _ => destruct (In_dec A B)
           | |- context [In_dec ?A ?B] => destruct (In_dec A B)
           | H : context [ { _ | _ } ] |- _ => destruct H
         end.

Ltac unfold_all :=
  repeat match goal with
           | H := _ |- _ => unfold H in *; clear H
         end.

Ltac f_equal' :=
  match goal with
    | |- (if ?E1 then _ else _) = (if ?E2 then _ else _) => replace E2 with E1; try reflexivity
  end.

Section TopSection.

  Notation "m %%- k" := (remove k m) (at level 60).
  Infix "<=" := Subset : set_scope.
  Infix "+" := union.
  Infix "-" := diff.
  Notation "! x" := (singleton x) (at level 40).
  Notation "[]" := (@empty _).
  Open Scope set_scope.
  Open Scope stmt_scope.
  Infix "<-" := Syntax.Assign.

  Fixpoint used_vars e :=
    match e with
      | Const _ => empty
      | Var x => !x
      | Binop _ a b => used_vars a + used_vars b
      | TestE _ a b => used_vars a + used_vars b
    end.

  Require Import Bedrock.Platform.Cito.Union.

  Fixpoint used_vars_stmt s :=
    match s with
      | skip => empty
      | a ;; b => used_vars_stmt a + used_vars_stmt b
      | Syntax.If e t f => used_vars e + used_vars_stmt t + used_vars_stmt f
      | Syntax.While e body => used_vars e + used_vars_stmt body
      | _ <- e => used_vars e
      | Syntax.Label _ _ => empty
      | Syntax.Call _ f args => used_vars f + union_list (List.map used_vars args)
    end.

  Require Import Bedrock.Platform.Cito.Option.

  Fixpoint elim_dead s used : Stmt * SET :=
    match s with
      | skip => (s, used)
      | a ;; b =>
        let result := elim_dead b used in
        let b := fst result in
        let used := snd result in
        let result := elim_dead a used in
        let a := fst result in
        let used := snd result in
        (a ;; b, used)
      | Syntax.If e t f =>
        let result := elim_dead t used in
        let t := fst result in
        let used_t := snd result in
        let result := elim_dead f used in
        let f := fst result in
        let used_f := snd result in
        (Syntax.If e t f, used_vars e + used_t + used_f)
      | Syntax.While e body =>
        let result := elim_dead body (used + used_vars e + used_vars_stmt body) in
        let body := fst result in
        let used' := snd result in
        (Syntax.While e body, used + used' + used_vars e)
      | x <- e =>
        if In_dec x used then
          (s, used - !x + used_vars e)
        else
          (skip, used)
      | Syntax.Label x _ =>
        (s, used - !x)
      | Syntax.Call x f args =>
        (s, used - (default empty (option_map singleton x)) + used_vars f + union_list (List.map used_vars args))
    end.

  Definition opt s retvar := fst (elim_dead s (!retvar)).

  Hint Extern 0 (Subset _ _) => progress (simpl; subset_solver).
  Hint Resolve union_subset_1.
  Hint Resolve union_subset_2.
  Hint Resolve diff_subset.

  Definition agree_in a b s := forall x, In x s -> Locals.sel a x = Locals.sel b x.

  Lemma agree_in_symm : forall a b s, agree_in a b s -> agree_in b a s.
    unfold agree_in; intros; symmetry; eauto.
  Qed.

  Hint Resolve agree_in_symm.

  Lemma agree_in_subset : forall a b s s', agree_in a b s -> s' <= s -> agree_in a b s'.
    unfold agree_in, Subset; intros; eauto.
  Qed.

  Hint Resolve agree_in_subset.

  Require Import Bedrock.Platform.Cito.GeneralTactics2.

  Lemma upd_same_agree_in : forall a b s x w, agree_in a b (s - !x) -> agree_in (upd a x w) (upd b x w) s.
    unfold agree_in; intros.
    destruct (string_dec x x0).
    subst.
    repeat rewrite sel_upd_eq; eauto.
    repeat rewrite sel_upd_ne.
    eapply H; eauto.
    eapply diff_iff.
    split; eauto.
    not_not.
    eapply singleton_iff in H1; eauto.
    eauto.
    eauto.
  Qed.

  Hint Resolve upd_same_agree_in.

  Lemma upd_out_agree_in : forall a b s x w, agree_in a b s -> ~ In x s -> agree_in (upd a x w) b s.
    unfold agree_in; intros.
    destruct (string_dec x x0).
    subst; intuition.
    repeat rewrite sel_upd_ne; eauto.
  Qed.

  Hint Resolve upd_out_agree_in.

  Lemma elim_dead_upper_bound :
    forall s used,
      let result := elim_dead s used in
      let used' := snd result in
      used' <= used + used_vars_stmt s.
  Proof.
    induction s; simpl; intros; openhyp';
      lazymatch goal with
      | [ |- ?x <= ?y ]
        => intuition eauto using (@subset_trans _ (y - empty + x) _), subset_trans
      | _
        => intuition eauto using subset_trans
      end.
  Qed.

  Hint Resolve elim_dead_upper_bound.

  Lemma eval_agree_in : forall e a b, agree_in a b (used_vars e) -> eval a e = eval b e.
    induction e; simpl; intuition.
    eapply H; eapply singleton_iff; eauto.
    f_equal; eauto.
    f_equal'; f_equal; eauto.
  Qed.

  Lemma eval_agree_in_list : forall es a b, agree_in a b (union_list (List.map used_vars es)) -> List.map (eval a) es = List.map (eval b) es.
    induction es; simpl; intuition.
    f_equal.
    eapply eval_agree_in; eauto.
    eauto.
  Qed.

End TopSection.

Require Import Bedrock.Platform.Cito.ADT.

Module Make (Import E : ADT).

  Require Import Bedrock.Platform.Cito.GoodOptimizer.
  Module Import GoodOptimizerMake := GoodOptimizer.Make E.
  Require Import Bedrock.Platform.Cito.Semantics.
  Import SemanticsMake.

  Section TopSection.

    Hint Unfold RunsTo.
    Hint Constructors Semantics.RunsTo.
    Hint Unfold Safe.
    Hint Constructors Semantics.Safe.

    Notation "m %%- k" := (remove k m) (at level 60).
    Infix "<=" := Subset : set_scope.
    Infix "+" := union.
    Infix "-" := diff.
    Notation "! x" := (singleton x) (at level 40).
    Notation "[]" := (@empty _).
    Open Scope set_scope.
    Open Scope stmt_scope.
    Infix "<-" := Syntax.Assign.

    Hint Extern 0 (Subset _ _) => progress (simpl; subset_solver).
    Hint Resolve union_subset_1.
    Hint Resolve union_subset_2.
    Hint Resolve diff_subset.
    Hint Resolve agree_in_symm.
    Hint Resolve agree_in_subset.
    Hint Resolve upd_same_agree_in.
    Hint Resolve upd_out_agree_in.
    Hint Resolve elim_dead_upper_bound.

    Lemma while_case :
      forall fs t v v',
        RunsTo fs t v v' ->
        forall e body used vs,
          let s := Syntax.While e body in
          let result := elim_dead s used in
          let s' := fst result in
          let used' := snd result in
          let vt := fst v in
          let heap := snd v in
          let vt' := fst v' in
          let heap' := snd v' in
          t = s' ->
          agree_in vs vt used' ->
          (
            let s := body in

            forall (used : SET) (vs vt : vals) (heap : Heap)
                   (vt' : vals) (heap' : Heap),
              let result := elim_dead s used in
              let t := fst result in
              let used' := snd result in
              RunsTo fs t (vt, heap) (vt', heap') ->
              agree_in vs vt used' ->
              exists vs' : vals,
                RunsTo fs s (vs, heap) (vs', heap') /\ agree_in vs' vt' used
          ) ->
          exists vs',
            RunsTo fs s (vs, heap) (vs', heap') /\
            agree_in vs' vt' used.
    Proof.
      induction 1; simpl; intros; unfold_all; subst; intuition.

      injection H2; intros; subst.
      destruct v; simpl in *.
      destruct v'; simpl in *.
      eapply H4 in H0; eauto; openhyp.
      destruct v''; simpl in *.
      edestruct IHRunsTo2; try reflexivity.
      2 : eauto.
      eauto using subset_trans.
      openhyp.
      descend.
      econstructor.
      simpl.
      repeat erewrite (@eval_agree_in _ vs w) by eauto.
      eauto.
      eauto.
      eauto.
      eauto.

      injection H0; intros; subst.
      descend.
      eapply RunsToWhileFalse.
      simpl.
      repeat erewrite (@eval_agree_in _ vs (fst v)) by eauto.
      eauto.
      eauto.
    Qed.

    Lemma subset_diff_empty : forall s, s <= s - empty.
      unfold Subset; intros.
      eapply diff_iff; split; eauto.
      nintro.
      eapply empty_iff in H0; intuition.
    Qed.

    Hint Resolve subset_diff_empty.

    Lemma elim_dead_is_bp :
      forall fs s used vs vt heap vt' heap',
        let result := elim_dead s used in
        let t := fst result in
        let used' := snd result in
        RunsTo fs t (vt, heap) (vt', heap') ->
        agree_in vs vt used' ->
        exists vs',
          RunsTo fs s (vs, heap) (vs', heap') /\
          agree_in vs' vt' used.
    Proof.
      induction s; simpl; intros.

      (* skip *)
      inversion H; unfold_all; subst.
      descend.
      eauto.
      eauto.

      (* seq *)
      inversion H; unfold_all; subst.
      destruct v'; simpl in *.
      eapply IHs1 in H3; eauto; openhyp.
      eapply IHs2 in H6; eauto; openhyp.
      descend.
      eauto.
      eauto.

      (* if *)
      inversion H; unfold_all; subst.
      simpl in *.
      eapply IHs1 in H7; eauto; openhyp.
      descend.
      eapply RunsToIfTrue.
      simpl.
      repeat erewrite (@eval_agree_in _ vs vt) by eauto.
      eauto.
      eauto.
      eauto.

      simpl in *.
      eapply IHs2 in H7; eauto; openhyp.
      descend.
      eapply RunsToIfFalse.
      simpl.
      repeat erewrite (@eval_agree_in _ vs vt) by eauto.
      eauto.
      eauto.
      eauto.

      (* while *)
      eapply while_case in H; eauto.

      Focus 3.
      (* assign *)
      openhyp'; simpl in *.
      inversion H; unfold_all; subst.
      descend; intuition.
      econstructor.
      erewrite eval_agree_in by eauto.
      simpl in *; eauto.

      inversion H; unfold_all; subst.
      descend; intuition.
      econstructor.
      simpl in *; eauto.

      (* call *)
      destruct o; simpl in *.
      inversion H; unfold_all; subst; simpl in *.
      descend.
      eapply RunsToCallInternal; simpl in *; eauto.
      repeat erewrite (@eval_agree_in _ vs vt) by eauto.
      eauto.
      repeat erewrite (@eval_agree_in_list _ vs vt) by eauto.
      eauto.
      simpl in *.
      eauto.

      simpl in *.
      descend.
      eapply RunsToCallForeign; simpl in *; eauto.
      repeat erewrite (@eval_agree_in _ vs vt) by eauto.
      eauto.
      repeat erewrite (@eval_agree_in_list _ vs vt) by eauto.
      eauto.
      simpl in *.
      eauto.

      inversion H; unfold_all; subst; simpl in *.
      descend.
      eapply RunsToCallInternal; simpl in *; eauto.
      repeat erewrite (@eval_agree_in _ vs vt) by eauto.
      eauto.
      repeat erewrite (@eval_agree_in_list _ vs vt) by eauto.
      eauto.
      simpl in *.
      eauto.

      simpl in *.
      descend.
      eapply RunsToCallForeign; simpl in *; eauto.
      repeat erewrite (@eval_agree_in _ vs vt) by eauto.
      eauto.
      repeat erewrite (@eval_agree_in_list _ vs vt) by eauto.
      eauto.
      simpl in *.
      eauto.

      (* label *)
      openhyp'; simpl in *.
      inversion H; unfold_all; subst.
      descend; intuition.
      econstructor; eauto.
      simpl in *; eauto.

    Qed.

    Lemma elim_dead_is_sp :
      forall fs s used vs vt heap,
        let result := elim_dead s used in
        let t := fst result in
        let used' := snd result in
        Safe fs s (vs, heap) ->
        agree_in vs vt used' ->
        Safe fs t (vt, heap).
    Proof.
      induction s.

      Focus 4.
      intros.
      unfold_all.
      eapply
        (Safe_coind
           (fun t v =>
              (exists vs c b used,
                 let s := While c b in
                 let result := elim_dead s used in
                 let s' := fst result in
                 let used' := snd result in
                 let vt := fst v in
                 let heap := snd v in
                 Safe fs s (vs, heap) /\
                 agree_in vs vt used' /\
                 (let s := b in
                  forall (used : SET) (vs vt : vals) (heap : Heap),
                    Safe fs s (vs, heap) ->
                    agree_in vs vt (snd (elim_dead s used)) ->
                    Safe fs (fst (elim_dead s used)) (vt, heap)
                 ) /\
                 t = s') \/
              Safe fs t v
        )); [ .. | left; descend; simpl in *; intuition eauto ]; clear; simpl; intros; openhyp.

      (* seq *)
      intuition.

      inversion H; unfold_all; subst; intuition eauto.

      (* if *)
      intuition.

      inversion H; subst.
      unfold_all; openhyp.
      intuition eauto.
      right; intuition eauto.

      (* while *)
      injection H2; intros; subst.
      inversion H; unfold_all; subst.
      destruct v; simpl in *.
      left.
      repeat split.
      repeat erewrite (@eval_agree_in _ v x) by eauto.
      eauto.
      eauto.

      intros.
      left.
      destruct v'; simpl in *.
      eapply elim_dead_is_bp in H3; eauto; openhyp.
      descend.
      4 : eauto.
      eauto.
      eauto using subset_trans.
      eauto.

      simpl in *.
      right.
      destruct v; simpl in *.
      repeat erewrite (@eval_agree_in _ v x) by eauto.
      eauto.

      inversion H; unfold_all; subst.
      intuition eauto.
      right.
      intuition eauto.

      (* call *)
      intuition.

      inversion H; unfold_all; subst; eauto.

      left; descend; intuition eauto.
      right; descend; intuition eauto.

      (* label *)
      intuition.

      inversion H; unfold_all; subst; intuition eauto.

      (* end of while case *)

      (* skip *)
      simpl; intros.
      eauto.

      (* seq *)
      simpl in *; intros.
      inversion H; unfold_all; subst.
      econstructor.
      eapply IHs1; eauto.
      intros.
      destruct v'; simpl in *.
      eapply elim_dead_is_bp in H1; eauto; openhyp.
      eapply IHs2; eauto.

      (* if *)
      simpl in *; intros.
      inversion H; unfold_all; subst.
      openhyp.
      econstructor.
      left.
      split.
      simpl in *.
      repeat erewrite (@eval_agree_in _ vt vs) by eauto.
      eauto.
      eapply IHs1; eauto.

      econstructor.
      right.
      split.
      simpl in *.
      repeat erewrite (@eval_agree_in _ vt vs) by eauto.
      eauto.
      eapply IHs2; eauto.

      Focus 3.
      (* assign *)
      simpl; intros; openhyp'; simpl in *; eauto.

      (* call *)
      simpl; intros.
      inversion H; unfold_all; subst.
      econstructor; simpl in *; eauto.
      repeat erewrite (@eval_agree_in _ vt vs) by eauto.
      eauto.
      repeat erewrite (@eval_agree_in_list _ vt vs) by eauto.
      eauto.

      eapply SafeCallForeign; simpl in *; eauto.
      repeat erewrite (@eval_agree_in _ vt vs) by eauto.
      eauto.
      repeat erewrite (@eval_agree_in_list _ vt vs) by eauto.
      eauto.

      (* label *)
      simpl; intros; openhyp'; simpl in *; eauto.
      inversion_clear H.
      econstructor; eauto.
    Qed.

    Require Import Bedrock.Platform.Cito.FreeVars.

    Lemma elim_dead_footprint : forall s m, free_vars (fst (elim_dead s m)) <= free_vars s.
    Proof.
      induction s; simpl; intros; openhyp'; simpl in *; subset_solver; eauto using subset_trans.
    Qed.

    Open Scope nat.

    Require Import Bedrock.Platform.Cito.Depth.
    Require Import Coq.Arith.Le.
    Require Import Bedrock.Platform.Cito.MaxFacts.

    Hint Extern 0 (le _ _) => progress (simpl; max_solver).
    Hint Resolve both_le le_n_S.

    Lemma elim_dead_depth : forall s m, depth (fst (elim_dead s m)) <= depth s.
    Proof.
      induction s; simpl; intros; openhyp'; simpl in *; max_solver; eauto using le_trans.
    Qed.

    Require Import Bedrock.Platform.Cito.GoodOptimizer.

    Lemma same_agree_in : forall a s, agree_in a a s.
      unfold agree_in; intros; eauto.
    Qed.

    Hint Resolve same_agree_in.

    Lemma agree_in_singleton : forall a b x, agree_in a b (!x) -> sel a x = sel b x.
      intros.
      eapply H.
      eapply singleton_iff; eauto.
    Qed.

    Hint Resolve agree_in_singleton.

    Lemma PreserveRunsTo_opt : PreserveRunsTo opt.
      unfold PreserveRunsTo, opt; intros.
      destruct v.
      destruct v'; simpl in *.
      eapply elim_dead_is_bp in H; openhyp; eauto.
    Qed.

    Lemma PreserveSafe_opt : PreserveSafe opt.
      unfold PreserveSafe, opt; intros.
      destruct v.
      eapply elim_dead_is_sp in H; openhyp; eauto.
    Qed.

    Require Import Bedrock.Platform.Cito.GetLocalVars.
    Require Import Bedrock.Platform.Cito.GetLocalVarsFacts.
    Import NPeano.Nat.

    Lemma PreserveGoodSize_opt : PreserveGoodSize opt.
      unfold PreserveGoodSize, opt; intros.
      eapply goodSize_weaken; eauto.
      eapply add_le_mono.
      2 : eapply elim_dead_depth.
      eapply get_local_vars_cardinal.
      eapply elim_dead_footprint; eauto.
    Qed.

    Require Import Bedrock.Platform.Cito.CompileStmtSpec.
    Require Import Bedrock.Platform.Cito.SetoidListFacts.
    Require Import Bedrock.Platform.Cito.GeneralTactics2.

    Require Import Bedrock.Platform.Cito.WellFormed.

    Hint Constructors args_not_too_long.

    Lemma opt_wellformed : forall s m, wellformed s -> wellformed (fst (elim_dead s m)).
      unfold wellformed.
      induction s; simpl; intuition; openhyp'; inversion_clear H; simpl in *; eauto.
    Qed.

    Lemma PreserveSynReq_opt : PreserveSynReq opt.
      unfold PreserveSynReq, opt; intros.
      unfold syn_req in *.
      unfold in_scope in *.
      openhyp.
      repeat split; eauto.
      eapply get_local_vars_subset; eauto.
      eapply opt_wellformed; eauto.
    Qed.

    Lemma good_optimizer : GoodOptimizer opt.
      unfold GoodOptimizer.
      split.
      eapply PreserveRunsTo_opt.
      split.
      eapply PreserveSafe_opt.
      split.
      eapply PreserveGoodSize_opt.
      eapply PreserveSynReq_opt.
    Qed.

  End TopSection.

End Make.


(* (c) Copyright Christian Doczkal, Saarland University                   *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.

Require Import edone bcase fset base modular_hilbert.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** * Generic Lemmas for Literals and Support *)

Record slClass (form:choiceType) :=
  SLClass {
      supp' : {fset form * bool} -> form -> bool -> bool;
      supp_mon C D s : C `<=` D -> supp' C s.1 s.2 -> supp' D s.1 s.2;
      lit'  : form * bool -> bool;
      supp_lit C s b : lit' (s,b) -> supp' C s b = ((s,b) \in C);
      f_weight' : form -> nat;
      sweight_lit s : f_weight' s.1 = 0 <-> lit' s
    }.

Record slType := SLType { sl_form :> choiceType ; sl_class : slClass sl_form }.

Definition lit (form : slType) := lit' (sl_class form).
Definition supp (form : slType) := supp' (sl_class form).
Definition f_weight (form : slType) := f_weight' (sl_class form).

Section SuppC.
Variable form : slType.
Local Notation clause := {fset form * bool}.

Definition suppC (L C : clause) := [all s in C, supp L s.1 s.2].

Definition suppS S C := [some D in S, suppC D C].

Definition base S C := [fset D in S | suppC D C ].

Lemma suppCU L C C' : suppC L (C `|` C') = suppC L C && suppC L C'.
Proof. exact: allU. Qed.

Lemma suppCD L C C' : suppC L C' -> suppC L (C `\` C') -> suppC L C.
Proof.
  move/allP => S1 /allP S2. apply/allP => s inC.
  case (boolP (s \in C')) => inC'; auto. apply: S2. by rewrite inE; bcase.
Qed.

Lemma suppCWL L1 L2 C : suppC L2 C -> suppC (L1 `|` L2) C.
Proof. apply: sub_all => s. apply: supp_mon; auto with fset. Qed.

Lemma suppC_sub L C C' : C `<=` C' -> suppC L C' -> suppC L C.
Proof. move => H. apply: sub_all_dom. exact/subP. Qed.

Definition s_weight := [fun s : form * bool => f_weight s.1].

Definition weight C := fsum s_weight C.

Definition literalC (L : clause) := [all s in L, lit s].

Lemma suppxx C : literalC C -> suppC C C.
Proof.
  move/allP => lit_C. apply/allP => [[s b]] /= inC.
  rewrite /supp supp_lit //. exact: lit_C.
Qed.

Lemma weight0 L : (weight L = 0) -> literalC L.
Proof. move/fsum_eq0 => H. apply/allP => x /H. by move/sweight_lit. Qed.

Lemma weightS L : (0 < weight L) -> ~~ literalC L.
Proof.
  rewrite lt0n. apply: contra => /allP H. apply/eqP.
  by have/fsum_const : {in L, const 0 s_weight} by move => x /H /sweight_lit.
Qed.

End SuppC.

Arguments s_weight {form} : rename.
Arguments weight [form] C.

Record slpType := SLPType { slp_form :> pSystem ; slp_class : slClass slp_form }.

Definition slType_of (form : slpType) := SLType (slp_class form).
Coercion slType_of : slpType >-> slType.
Canonical local_formSLType (form : slpType) : slType := form.

Section slpTheory.
  Variable form : slpType.

  Local Notation sform := (form * bool) %type.
  Local Notation clause := {fset form * bool}.
  Local Notation "s ^-" := (s,false) (at level 20, format "s ^-").
  Local Notation "s ^+" := (s,true) (at level 20, format "s ^+").

  Definition interp (f:slpType) (s : f * bool) := match s with (t,true) => t | (t,false) => ~~: t end.

  Local Notation "[ 'af' C ]" := (\and_(s <- C) interp s) (at level 0, format "[ 'af'  C ]").

  (** Caveat: use of the lemmas below sometimes exposes an invisible (implicit)
  slpType instance (propositional reasoning) and needs to be simplified to the
  underlying formula type before further modal reasoning can be applied *)

  Lemma af1p (s : form) : mprv (s ---> [af [fset s^+]]).
  Proof. apply: bigAI => t. by rewrite !inE => /eqP ->. Qed.

  Lemma afp1 (s : form) : mprv ([af [fset s^+]] ---> s).
  Proof. change s with (interp (s^+)) at 2. apply: bigAE. by rewrite !inE. Qed.

  Lemma af1n (s : form) : mprv (Neg s ---> [af [fset s^-]]).
  Proof. apply: bigAI => t. by rewrite !inE => /eqP ->. Qed.

  Lemma afn1 (s : form) : mprv ([af [fset s^-]] ---> Neg s).
  Proof. change (Neg s) with (interp (s^-)). apply: bigAE. by rewrite !inE. Qed.

  Local Notation xaf := (fun C : clause => [af C]).

  Variable ssub : sform -> {fset sform}.

  Inductive decomp (s : sform) : Type :=
  | decomp_lit : @lit form s -> decomp s
  | decomp_ab (S : {fset clause}) :
      (forall (D : clause), D \in S -> D `<=` ssub s) ->
      (forall (D : clause), D \in S -> weight D < s_weight s) ->
      (forall (C D : clause), D \in S -> suppC C D -> supp C s.1 s.2) ->
      mprv (interp s ---> \or_(D <- S) [af D])
      -> decomp s.

  Hypothesis decompP : forall s, decomp s.

  Variable F : {fset sform}.
  Hypothesis ssub_F : forall s, s \in F -> ssub s `<=` F.

  Let LF : {fset clause} := [fset C in powerset F | literalC C].

  Lemma supp_aux C : C \in powerset F -> mprv ([af C] ---> \or_(D <- base LF C) [af D]).
  Proof.
    move: C. apply: @nat_size_ind _ _ (@weight _) _ => C IH inU.
    case: (posnP (weight C)) => [/weight0 lC |/weightS wC].
    - apply (bigOI xaf). by rewrite !inE suppxx; bcase.
    - case/allPn : wC => s inC nL.
      case: (decompP s) => [|S S1 S2 S3 S4]; first by rewrite (negbTE nL).
      rewrite -{1}(fsetUD1 inC). rewrite -> andU, bigA1, S4.
      rewrite -> bigODr. apply: bigOE => D inCs. rewrite <- andU.
      rewrite -> IH.
      + apply: bigOE => L'. rewrite !inE -andbA => /and3P [D1 D2 D3].
        apply: (bigOI xaf). rewrite !inE D1 D2 /=.
        move: D3. rewrite suppCU => /andP [D3]. apply: suppCD.
        rewrite /suppC all_fset1. exact: S3 D3.
      + apply: fsum_replace; rewrite ?fsub1 // fsum1. exact: S2.
      + rewrite powersetU  [_ `\` _ \in _](sub_power _ inU) // andbT.
        rewrite powersetE. apply: sub_trans (S1 _ inCs) _. apply ssub_F.
        rewrite powersetE in inU. exact: (subP inU).
  Qed.
End slpTheory.

Notation "[ 'af' C ]" := (\and_(s <- C) interp s) (at level 0, format "[ 'af'  C ]").
Arguments decomp_ab [form ssub s] S.