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

Require Import Arith Omega List Permutation.

Require Import utils ill_form ill_rules phase_sem.

Set Implicit Arguments.

Section Rules.

  Variable (s1 s2 : bool).

  Let P := (ill_proof s1 s2).

  Notation "Γ ⊨ A" := (P Γ A) (at level 70, no associativity).

  Implicit Types (X Y : list ill_form -> Type).

  Definition cl_ctx X Ω := forall Γ Δ A, (forall ϴ, X ϴ -> Γ++ϴ++Δ ⊨ A)
                                       ->                  Γ++Ω++Δ ⊨ A.

  Definition comp_ctx (Γ Δ ϴ : list ill_form) := Γ++Δ ~[s1] ϴ.

  Notation cl := cl_ctx.
  Notation comp := comp_ctx.

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

  Notation J := (fun Γ => cl (sg ∅) Γ * cl (sg Γ ∘ sg Γ) Γ)%type.
  Notation K := (fun Γ => { Δ | Γ = ‼Δ }).

  (* ⊆ ≃ ∩ ∪ ∘ ⊸ ⊛ ⟦ ⟧ ⟬߭ ⟭  ⟙   ⟘   𝝐  ﹠ ⊗  ⊕  ⊸  ❗   ‼  ∅  ⊢ Γ Δ ϴ ⊨ *)

  Fact cl_ctx_increase X : X ⊆ cl X.
  Proof. intros ? ? ? ?; auto. Qed.

  Fact cl_ctx_mono X Y : X ⊆ Y -> cl X ⊆ cl Y.
  Proof.
    intros H1 om Hom ga de x HY.
    apply Hom.
    intros; apply HY, H1; auto.
  Qed.

  Fact cl_ctx_idem X : cl (cl X) ⊆ cl X.
  Proof.
    intros om Hom ga de x HX.
    apply Hom.
    intros th Hth.
    apply Hth, HX.
  Qed.

  Hint Resolve cl_ctx_increase cl_ctx_mono cl_ctx_idem.

  Let P_perm : forall Γ Δ A, Γ ~[s1] Δ -> Γ ⊨ A -> Δ ⊨ A.
  Proof.
    intros ? ? ?; apply in_llp_perm.
  Qed.

  Hint Resolve perm_bang_t_refl.

  Local Fact cl_comm : s1 = true -> forall Γ Δ, sg Γ ∘ sg Δ ⊆ cl (sg Δ ∘ sg Γ).
  Proof.
    intros E ? ? _ [ ga de th ? ? Hth ]; subst Γ Δ.
    intros rho del x H; subst s1. apply H.
    constructor 1 with de ga; auto.
    revert Hth; unfold comp.
    apply ill_perm_t_trans; auto.
    subst s1; simpl.
    apply perm_t_app_comm.
  Qed.

  Local Fact cl_neutral_1 : forall Γ, cl (sg ∅ ∘ sg Γ) Γ.
  Proof.
    intros ga de th x H.
    apply H.
    constructor 1 with nil ga; auto.
    red; simpl; auto.
  Qed.

  Local Fact cl_neutral_3 : forall Γ, cl (sg Γ ∘ sg ∅) Γ.
  Proof.
    intros ga de th x H.
    apply H.
    constructor 1 with ga nil; auto.
    red; simpl; rewrite <- app_nil_end; auto.
  Qed.

  Local Fact cl_neutral_2 : forall Γ, sg ∅ ∘ sg Γ ⊆ cl (sg Γ).
  Proof.
    intros ga ? [ de th ka ? ? H1 ] rho om x G; subst th de.
    cbv in H1.
    generalize (G _ eq_refl).
    apply P_perm.
    do 2 (apply ill_perm_t_app; auto).
  Qed.

  Local Fact cl_neutral_4 : forall Γ, sg Γ ∘ sg ∅ ⊆ cl (sg Γ).
  Proof.
    intros ga ? [ de th ka ? ? H1 ] rho om x G; subst th de.
    red in H1; rewrite <- app_nil_end in H1.
    generalize (G _ eq_refl).
    apply P_perm.
    do 2 (apply ill_perm_t_app; auto).
  Qed.

  Fact cl_ctx_stable_l : forall X Y, cl X ∘ Y ⊆ cl (X ∘ Y).
  Proof.
    intros X Y _ [ ga de th H1 H2 H3 ] rho om x HXY.
    red in H1; red in H3.
    apply P_perm with (rho++ga++de++om).
    1: { apply ill_perm_t_app; auto.
         rewrite <- app_ass.
         apply ill_perm_t_app; auto. }
    apply H1.
    intros ka Hka.
    replace (rho ++ ka ++ de ++ om)
    with    (rho ++ (ka ++ de) ++ om) by solve list eq.
    apply HXY.
    constructor 1 with ka de; auto.
    red; auto.
  Qed.

  Fact cl_ctx_stable_r : forall X Y, X ∘ cl Y ⊆ cl (X ∘ Y).
  Proof.
    intros X Y _ [ ga de th H1 H2 H3 ] rho om x HXY.
    red in H2; red in H3.
    apply P_perm with ((rho++ga)++de++om).
    1: { rewrite app_ass.
         apply ill_perm_t_app; auto.
         rewrite <- app_ass.
         apply ill_perm_t_app; auto. }
    apply H2.
    intros ka Hka.
    replace ((rho ++ ga) ++ ka ++ om)
    with    (rho ++ (ga ++ ka) ++ om) by solve list eq.
    apply HXY.
    constructor 1 with ga ka; auto.
    red; auto.
  Qed.

  Local Fact cl_assoc_1 : forall Γ Δ ϴ, sg Γ ∘ (sg Δ ∘ sg ϴ) ⊆ cl ((sg Γ ∘ sg Δ) ∘ sg ϴ).
  Proof.
    intros ga de th _ [ ga' rho ka H2 H3 H4 ].
    destruct H3 as [ de' th' to ? ? H3 ]; subst ga' de' th'.
    red in H3, H4.
    intros u x v Hu.
    specialize (Hu ((ga++de)++th)).
    spec all in Hu.
    constructor 1 with (ga++de) th; auto.
    constructor 1 with ga de; auto.
    red; auto.
    red; auto.
    revert Hu.
    apply P_perm, ill_perm_t_app; auto.
    apply ill_perm_t_app; auto.
    rewrite app_ass.
    apply ill_perm_t_trans with (2 := H4).
    apply ill_perm_t_app; auto.
  Qed.

  Local Fact cl_assoc_2 : forall Γ Δ ϴ, (sg Γ ∘ sg Δ) ∘ sg ϴ ⊆ cl (sg Γ ∘ (sg Δ ∘ sg ϴ)).
  Proof.
    intros ga de th _ [ ga' rho ka H2 H3 H4 ].
    destruct H2 as [ de' th' to ? ? H2 ]. subst rho de' th'.
    red in H2, H4.
    intros u x v Hu.
    specialize (Hu (ga++de++th)).
    spec all in Hu.
    constructor 1 with (ga) (de++th); auto.
    constructor 1 with de th; auto.
    red; auto.
    red; auto.
    revert Hu.
    apply P_perm, ill_perm_t_app; auto.
    apply ill_perm_t_app; auto.
    apply ill_perm_t_trans with (2 := H4).
    rewrite <- app_ass.
    apply ill_perm_t_app; auto.
  Qed.

  Local Fact sub_monoid_1 : cl K ∅.
  Proof.
    intros ga de A H.
    apply H; exists ∅; auto.
  Qed.

  Local Fact sub_monoid_2 : K ∘ K ⊆ K.
  Proof.
    intros _ [ a b c [ga Ha] [de Hb] H ]; subst a b.
    red in H; simpl in H.
    unfold ill_lbang in H.
    rewrite <- map_app in H.
    revert H; apply ill_perm_t_map_inv_t; auto.
  Qed.

  Section sub_J_cs.

    Let P_weak : ∀ ϴ Γ Δ A, ϴ++Δ ⊨ A -> ϴ++‼Γ++Δ ⊨ A.
    Proof.
      intros ? ? ?; apply ill_weak_ctx.
    Qed.

    Let P_cntr : ∀ ϴ Γ Δ A, ϴ++‼Γ++‼Γ++Δ ⊨ A -> ϴ++‼Γ++Δ ⊨ A.
    Proof.
      intros ? ? ? ?; apply ill_cntr_ctx.
    Qed.

    Local Fact sub_J_1 : K ⊆ J.
    Proof.
      intros x (de & Hde); subst x.
      constructor; red.
      + intros ga th A H.
        specialize (H _ eq_refl); simpl in H.
        apply P_weak; auto.
      + intros ga th A H.
        specialize (H (‼de++‼de)).
        spec all in H.
        { constructor 1 with (‼de) (‼de); auto; red; auto. }
        rewrite app_ass in H.
        apply P_cntr; auto.
    Qed.

  End sub_J_cs.

  Section sub_J_cn.

    Hypothesis K_inc_J : K ⊆ J.

    Let J_banged Γ : J (‼Γ).
    Proof. apply K_inc_J; exists Γ; auto. Qed.

    Let weak Γ : cl (sg nil) (‼Γ).
    Proof. apply J_banged. Qed.

    Let cntr Γ : cl (sg (‼Γ) ∘ sg (‼Γ)) (‼Γ).
    Proof. apply J_banged. Qed.

    Local Fact sub_J_2 Γ Δ A : Δ ⊨ A -> ‼Γ++Δ ⊨ A.
    Proof.
      intros H.
      apply (weak _ nil).
      intros _ []; apply H.
    Qed.

    Local Fact sub_J_3 Γ Δ A : ‼Γ++‼Γ++Δ ⊨ A -> ‼Γ++Δ ⊨ A.
    Proof.
      intros H.
      apply (cntr _ nil).
      intros _ [ x y th [] [] H1 ].
      revert H; apply P_perm.
      rewrite <- app_ass.
      simpl; apply ill_perm_t_app; auto.
    Qed.

  End sub_J_cn.

  Fact sub_J_eq : K ⊆ J ≡ (∀ Γ Δ A, Δ ⊨ A -> ‼Γ++Δ ⊨ A)
                         * (∀ Γ Δ A, ‼Γ++‼Γ++Δ ⊨ A -> ‼Γ++Δ ⊨ A).
  Proof.
    split.
    + split.
      * apply sub_J_2; auto.
      * apply sub_J_3; auto.
    + intros; apply sub_J_1; tauto.
  Qed.

  Definition rules_nc_sound := ill_nc_soundness    cl_ctx_increase cl_ctx_mono
                                                   cl_ctx_idem
                                                   cl_ctx_stable_l
                                                   cl_ctx_stable_r
                                                   cl_neutral_1
                                                   cl_neutral_2
                                                   cl_neutral_3
                                                   cl_neutral_4
                                                   cl_assoc_1
                                                   cl_assoc_2
                                                   sub_monoid_1
                                                   sub_monoid_2
                                                   sub_J_1.

  Check rules_nc_sound.

  Section Comm.

    Hypothesis Hs1 : s1 = true.

    Definition rules_comm_sound := ill_comm_soundness    cl_ctx_increase cl_ctx_mono
                                                   cl_ctx_idem
                                                   (cl_comm Hs1)
                                                   cl_ctx_stable_l
                                                   cl_ctx_stable_r
                                                   cl_neutral_1
                                                   cl_neutral_2
                                                   cl_neutral_3
                                                   cl_neutral_4
                                                   cl_assoc_1
                                                   cl_assoc_2
                                                   sub_monoid_1
                                                   sub_monoid_2
                                                   sub_J_1.

  End Comm.

  Notation "↓" := (fun A Γ => Γ ⊨ A).

  Fact dc_closed A : cl (↓A) ⊆ ↓A.
  Proof.
    intros ga Hga; red in Hga.
    replace ga with (nil++ga++nil) by solve list eq.
    apply Hga.
    intro; rewrite <- app_nil_end; auto.
  Qed.

  Notation sg := (@eq _).
  Infix "⊸" := (Magicwand_l comp) (at level 51, right associativity).
  Infix "⟜" := (Magicwand_r comp) (at level 52, left associativity).

  Section equivalences.

    (* We show that each rule has an algebraic counterpart *)

    (* ⊆ ≃ ∩ ∪ ∘ ⊸ ⊛ ⟦ ⟧ ⟬߭ ⟭  ⟙   ⟘   𝝐  ﹠ ⊗  ⊕  ⊸  ❗   ‼  ∅  ⊢ Γ Δ ϴ ⊨ *)

    Fact rule_ax_eq A : ↓A (A::∅)
                    ≡ A::∅ ⊨ A.
    Proof. split; auto. Qed.

    Fact rule_limp_l_eq A B : (↓A ⊸ cl (sg (B::∅))) (A -o B::∅)
                          ≡ ∀ ϴ Γ Δ C, Γ ⊨ A -> ϴ++B::Δ ⊨ C -> ϴ++Γ++A -o B::Δ ⊨ C.
    Proof.
      split.
      + intros H Ga De Th C H1 H2.
        specialize (H (De++A -o B::nil)).
        spec all in H.
        constructor 1 with De (A -o B :: nil); auto; red; simpl; auto.
        replace (Ga++De++A -o B::Th) with (Ga++(De++A -o B::nil)++Th) by solve list eq.
        apply H; intros _ []; auto.
      + intros H0 th Hth de om C H.
        destruct Hth as [ rho ga th H1 H2 H3 ].
        subst ga; red in H3; simpl in H3.
        apply P_perm with (de++(rho++A -o B::nil)++om).
        { do 2 (apply ill_perm_t_app; auto). }
        rewrite app_ass; simpl; apply H0; auto.
        apply H with (ϴ := _::∅); auto.
    Qed.

    Fact rule_limp_r_eq A B : sg (A::∅) ⊸ ↓B ⊆ ↓(A -o B)
                          ≡ ∀ Γ, A::Γ ⊨ B -> Γ ⊨ A -o B.
    Proof.
      split.
      + intros H Ga H1.
        apply H.
        intros _ [ ? ? De [] [] H2 ].
        apply P_perm with (1 := H2).
        apply P_perm with (2 := H1); auto.
      + intros H th Hth.
        apply H, Hth.
        constructor 1 with (A :: nil) th; auto.
        red; auto.
    Qed.

    Fact rule_rimp_l_eq A B : (cl (sg (B::∅)) ⟜ ↓A) (B o- A::∅)
                          ≡ ∀ ϴ Γ Δ C, Γ ⊨ A -> ϴ++B::Δ ⊨ C -> ϴ++B o- A::Γ++Δ ⊨ C.
    Proof.
      split.
      + intros H Ga De Th C H1 H2.
        specialize (H (B o- A::De)).
        spec all in H.
        constructor 1 with (B o- A::nil) De; auto; red; simpl; auto.
        replace (Ga++B o- A::De++Th) with (Ga++(B o- A::De)++Th) by solve list eq.
        apply H; intros _ []; auto.
      + intros H0 th Hth de om C H.
        destruct Hth as [ rho ga th H1 H2 H3 ].
        subst rho; red in H3; simpl in H3.
        apply P_perm with (de++(B o- A::ga)++om).
        { do 2 (apply ill_perm_t_app; auto). }
        simpl; apply H0; auto.
        apply H with (ϴ := _::∅); auto.
    Qed.

    Fact rule_rimp_r_eq A B : ↓B ⟜ sg (A::∅) ⊆ ↓(B o- A)
                          ≡ ∀ Γ, Γ++A::nil ⊨ B -> Γ ⊨ B o- A.
    Proof.
      split.
      + intros H Ga H1.
        apply H.
        intros _ [ ? ? De [] [] H2 ].
        apply P_perm with (1 := H2).
        apply P_perm with (2 := H1); auto.
      + intros H th Hth.
        apply H, Hth.
        constructor 1 with th (A :: nil); auto.
        red; auto.
    Qed.

    Fact rule_times_l_eq A B : cl (sg (A::B::nil)) (A⊗B::nil)
                           ≡ ∀ ϴ Γ C, ϴ++A::B::Γ ⊨ C -> ϴ++A ⊗ B::Γ ⊨ C.
    Proof.
      split.
      + intros H Th Ga C H1.
        apply H; intros _ []; auto.
      + intros H0 ? ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_times_r_eq A B : ↓A ∘ ↓B ⊆ ↓(A⊗B)
                           ≡ ∀ Γ Δ, Γ ⊨ A -> Δ ⊨ B -> Γ++Δ ⊨ A ⊗ B.
    Proof.
      split.
      + intros H Ga De H1 H2.
        apply H.
        constructor 1 with Ga De; auto; red; auto.
      + intros H _ [ Ga Gb Gc HGa HGb HGc ].
        apply P_perm with (1 := HGc).
        apply H; auto.
    Qed.

    Fact rule_with_l1_eq A B : cl (sg (A::∅)) (A&B::∅)
                           ≡ ∀ ϴ Γ C, ϴ++A::Γ ⊨ C -> ϴ++A﹠B::Γ ⊨ C.
    Proof.
      split.
      + intros H Th Ga C H1; apply H; intros _ []; auto.
      + intros H0 ? ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_with_l2_eq A B : cl (sg (B::∅)) (A&B::∅)
                           ≡ ∀ ϴ Γ C, ϴ++B::Γ ⊨ C -> ϴ++A﹠B::Γ ⊨ C.
    Proof.
      split.
      + intros H The Ga C H1; apply H; intros _ []; auto.
      + intros H0 ? ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_with_r_eq A B : ↓A ∩ ↓B ⊆ ↓(A & B)
                          ≡ ∀ Γ, Γ ⊨ A -> Γ ⊨ B -> Γ ⊨ A﹠B.
    Proof.
      split.
      + intros H Ga H1 H2; apply H; auto.
      + intros H ? []; apply H; auto.
    Qed.

    Fact rule_plus_l_eq A B : cl (sg (A::∅) ∪ sg (B::∅)) (A⊕B::∅)
                          ≡ ∀ ϴ Γ C, ϴ++A::Γ ⊨ C -> ϴ++B::Γ ⊨ C -> ϴ++A⊕B::Γ ⊨ C.
    Proof.
      split.
      + intros H Th Ga C H1 H2.
        apply H; intros _ [ [] | [] ]; auto.
      + intros H0 ? ? ? H; apply H0; apply H with (ϴ := _::∅); auto.
    Qed.

    Fact rule_plus_r1_eq A B : ↓A ⊆ ↓(A⊕B)
                           ≡ ∀ Γ, Γ ⊨ A -> Γ ⊨ A⊕B.
    Proof.
      split.
      + intros H ? ?; apply H; auto.
      + intros H0 ?; apply H0.
    Qed.

    Fact rule_plus_r2_eq A B : ↓B ⊆ ↓(A⊕B)
                           ≡ ∀ Γ, Γ ⊨ B -> Γ ⊨ A⊕B.
    Proof.
      split.
      + intros H ? ?; apply H; auto.
      + intros H0 ?; apply H0.
    Qed.

    Fact rule_bang_l_eq A : cl (sg (A::∅)) (!A::∅)
                        ≡ ∀ ϴ Γ B, ϴ++A::Γ ⊨ B -> ϴ++!A::Γ ⊨ B.
    Proof.
      split.
      + intros H Th Ga B H1; apply H; intros _ []; auto.
      + intros H0 ? ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_bang_r_eq A : K ∩ ↓A ⊆ ↓(!A)
                        ≡   ∀ Γ, ‼ Γ ⊨ A -> ‼ Γ ⊨ !A.
    Proof.
      split.
      + intros H Ga H1.
        apply H; split; auto.
        exists Ga; auto.
      + intros H0 Ga [ (De & H1) H2 ]; subst.
        apply H0; auto.
    Qed.

    Fact rule_unit_l_eq : cl (sg ∅) (𝝐::nil)
                      ≡ ∀ ϴ Γ A, ϴ++Γ ⊨ A -> ϴ++𝝐 :: Γ ⊨ A.
    Proof.
      split.
      + intros H Th Ga A H1; apply H; intros _ []; auto.
      + intros H0 ? ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_unit_r_eq : sg ∅ ⊆ ↓𝝐  ≡ ∅ ⊨ 𝝐.
    Proof.
      split.
      + intros H; apply H; auto.
      + intros H x []; apply H.
    Qed.

    Fact rule_bot_l_eq : cl (fun _ => False) (⟘::∅)
                     ≡ ∀ ϴ Γ A, ϴ++⟘ :: Γ ⊨ A.
    Proof.
      split.
      + intros H Th Ga A; apply H; tauto.
      + intros H0 ? ? ? _; apply H0.
    Qed.

    Fact rule_top_r_eq : (fun _ => True) ⊆ ↓⟙ ≡ ∀ Γ, Γ ⊨ ⟙.
    Proof.
      split.
      + intros H Ga; apply H; auto.
      + intros H ? _; apply H.
    Qed.

  End equivalences.

End Rules.


Set Warnings "-notation-overridden,-parsing".
From PLF Require Import Maps.
From Coq Require Import Bool.Bool.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import omega.Omega.
From Coq Require Import FunctionalExtensionality.
From PLF Require Import Imp.

Definition Assertion := state -> Prop.

Module ExAssertations.
Definition as1 : Assertion := fun st => st X = 3.
Definition as2 : Assertion := fun st => st X <= st Y.
Definition as3 : Assertion :=
  fun st => st X = 3 \/ st X <= st Y.
Definition as4 : Assertion :=
  fun st => st Z * st Z <= st X /\
            not (((S (st Z)) * (S (st Z))) <= st X).
Definition as5 : Assertion := fun st => True.
Definition as6 : Assertion := fun st => False.

End ExAssertations.

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Notation "P ->> Q" := (assert_implies P Q)
                      (at level 80) : hoare_spec_scope.
Open Scope hoare_spec_scope.

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

Definition hoare_triple
           (P: Assertion) (c: com) (Q: Assertion): Prop :=
  forall st st',
    st =[ c ]=> st' ->
               P st ->
               Q st'.

Notation "{{ P }} c {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level)
  : hoare_spec_scope.

Theorem hoare_post_true : forall (P Q : Assertion) c,
  (forall st, Q st) ->
  {{P}} c {{Q}}.
Proof.
  intros P Q c H. unfold hoare_triple.
  intros st st' Heval HP.
  apply H.
Qed.

Theorem hoare_pre_false : forall (P Q : Assertion) c,
  (forall st, not (P st)) ->
  {{ P }} c {{ Q }}.
Proof.
  intros P Q c H. unfold hoare_triple.
  intros st st' Heval HP.
  unfold not in H. apply H in HP.
  inversion HP.
Qed.

Definition assn_sub X a P: Assertion :=
  fun (st: state) =>
    P (X !-> aeval st a; st).

Notation "P [ X |-> a ]" := (assn_sub X a P)
  (at level 10, X at next level).

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} X ::= a {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q X a st st' HE HQ.
  inversion HE. subst.
  unfold assn_sub in HQ. assumption. Qed.

Theorem hoare_asgn_fwd:
  forall m a P,
    {{fun st => P st /\ st X = m}}
      X ::= a
    {{fun st => P (X !-> m ; st) /\
             st X = aeval (X !-> m ; st) a}}.
Proof.
  unfold hoare_triple.
  intros.
  inversion H; subst.
  destruct H0.
  rewrite t_update_shadow.
  rewrite <- H1. rewrite t_update_same.
  auto.
Qed.

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q c Hhoare Himp.
  intros st st' Hc HP.
  apply (Hhoare st st'). assumption.
  apply Himp. assumption.
Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P Q Q' c Hhoare Himp.
  intros st st' Hc HP.
  apply Himp.
  apply (Hhoare st st').
  assumption. assumption. Qed.

Example hoare_asgn_example1 :
  {{fun st => True}} X ::= 1 {{fun st => st X = 1}}.
Proof.
  apply hoare_consequence_pre
    with (P' := (fun st => st X = 1) [X |-> 1]).
  apply hoare_asgn.
  intros st H.
  unfold assn_sub. auto.
Qed.

Theorem hoare_consequence : forall(P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->
  P ->> P' ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q Q' c Hht HPP' HQ'Q.
  apply hoare_consequence_pre with (P' := P').
  apply hoare_consequence_post with (Q' := Q').
  assumption. assumption. assumption. Qed.

Theorem hoare_skip : forall P,
     {{P}} SKIP {{P}}.
Proof.
  intros P st st' H HP. inversion H. subst.
  assumption. Qed.

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1;;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st st' H12 Pre.
  inversion H12; subst.
  apply (H1 st'0 st'); try assumption.
  apply (H2 st st'0); assumption. Qed.

Example hoare_asgn_example3 : forall a n,
  {{fun st => aeval st a = n}}
  X ::= a;; SKIP
  {{fun st => st X = n}}.
Proof.
  intros a n. eapply hoare_seq.
  - (* right part of seq *)
    apply hoare_skip.
  - (* left part of seq *)
    eapply hoare_consequence_pre. apply hoare_asgn.
    intros st H. subst. reflexivity.
Qed.

Definition swap_program : com :=
  Z ::= AId X ;; X ::= AId Y ;; Y ::= AId Z.

Theorem swap_ex:
  {{fun st => st X <= st Y}}
  swap_program
  {{fun st => st Y <= st X}}.
Proof.
  eapply hoare_seq. eapply hoare_seq.
  - eapply hoare_consequence_pre.
    apply hoare_asgn.
    intros st H. eauto.
  - eapply hoare_consequence_pre.
    apply hoare_asgn.
    intros st H. eauto.
  - eapply hoare_consequence_pre.
    apply hoare_asgn.
    intros st H. eauto.
Qed.

(* lift of bool *)
Definition bassn b: Assertion :=
  fun st => (beval st b = true).

Lemma bexp_eval_true : forall b st,
    beval st b = true -> (bassn b) st.
Proof.
  intros. unfold bassn. apply H.
Qed.

Lemma bexp_eval_false : forall b st,
    beval st b = false -> not ((bassn b) st).
Proof.
  intros. unfold bassn.
  rewrite H. auto. Qed.

Hint Unfold bassn.
Theorem hoare_if : forall P Q b c1 c2,
  {{fun st => P st /\ bassn b st}} c1 {{Q}} ->
  {{fun st => P st /\ not (bassn b st)}} c2 {{Q}} ->
  {{P}} TEST b THEN c1 ELSE c2 FI {{Q}}.
Proof.
  intros.
  intros st st' HE HP.
  inversion HE; subst.
  apply (H st); auto.
  apply (H0 st); auto.
  split. assumption. unfold bassn.
  rewrite H6. auto.
Qed.

Example if_example :
    {{fun st => True}}
  TEST X = 0
    THEN Y ::= 2
    ELSE Y ::= X + 1
  FI
    {{fun st => st X <= st Y}}.
Proof.
  (* WORKED IN CLASS *)
  apply hoare_if.
  - (* Then *)
    eapply hoare_consequence_pre. apply hoare_asgn.
    unfold bassn, assn_sub, t_update, assert_implies.
    simpl. intros st [_ H].
    apply eqb_eq in H.
    rewrite H. omega.
  - (* Else *)
    eapply hoare_consequence_pre. apply hoare_asgn.
    unfold assn_sub, t_update, assert_implies.
    simpl; intros st _. omega.
Qed.

Theorem if_minus_plus :
  {{fun st => True}}
  TEST X <= Y
    THEN Z ::= Y - X
    ELSE Y ::= X + Z
  FI
  {{fun st => st Y = st X + st Z}}.
Proof.
  apply hoare_if.
  - eapply hoare_consequence_pre.
    apply hoare_asgn.
    unfold bassn, assn_sub, assert_implies, t_update.
    simpl; intros st [_ Ht].
    Search (_ = _ + (_ - _)).
    Search (_ <=? _ = true).
    apply leb_le in Ht.
    apply le_plus_minus. assumption.
  - eapply hoare_consequence_pre.
    apply hoare_asgn.
    unfold bassn, assn_sub, assert_implies, t_update.
    simpl. auto.
Qed.

Theorem hoare_while : forall P b c,
  {{fun st => P st /\ bassn b st}} c {{P}} ->
  {{P}} WHILE b DO c END {{fun st => P st /\ not (bassn b st)}}.
Proof.
  intros P b c Hhoare st st' He HP.
  remember (WHILE b DO c END)%imp as wcom.
  induction He;
    try (inversion Heqwcom); subst.
  - split. assumption. unfold bassn.
    apply bexp_eval_false. assumption.
  - apply IHHe2. assumption.
    apply (Hhoare st). assumption.
    split. assumption. apply bexp_eval_true. assumption.
Qed.

Theorem always_loop_hoare : forall P Q,
  {{P}} WHILE true DO SKIP END {{Q}}.
Proof.
  (* WORKED IN CLASS *)
  intros P Q.
  apply hoare_consequence_pre with (P' := fun st : state => True).
  eapply hoare_consequence_post.
  apply hoare_while.
  - (* Loop body preserves invariant *)
    apply hoare_post_true. intros st. apply I.
  - (* Loop invariant and negated guard imply postcondition *)
    simpl. intros st [Hinv Hguard].
    exfalso. apply Hguard. reflexivity.
  - (* Precondition implies invariant *)
    intros st H. constructor. Qed.


Require Import String.
Add Rec LoadPath "../src/" as Ltac_ext.
Add ML Path "../src/".

Require Ltac_ext.

Section t.

  Variable a b c d e : nat.

  Goal  True -> True -> True.
  intros.
  iter_tac (fun x =>
              match type of x with
                | True => clear x
                | ?t => change t with (id t) in x
              end).

  Abort.
End t.

Section u.

  Inductive P : nat -> Prop :=
    p0 : P 0
  | p1 : forall n, P n -> P (S n).

  (* here we have a **syntactic** search for n in the list ns *)
  Require Import List.
  Ltac is_in_dec n ns := match ns with
                           | nil     => false
                           | n :: _  => true
                           | _ :: ?tl => is_in_dec n tl
                         end.

  (* Here the first case looks for new values by failing on old ones,
and the catch-all one allows the tactics to succeed when all the work
has been done.  cf. this bit of cpdt for more details on the behaviour
of the first match: http://adam.chlipala.net/cpdt/html/Match.html *)

  Ltac inverse_P ns := match goal with
                         | [ H: P ?x |- _ ] =>
                           let test := is_in_dec x ns in
                           match constr:test with
                             | true  => fail
                             | false =>
                               let H' := fresh "H" in
                               let m' := fresh "m" in
                               inversion H as [H' | m' H'] ;
                                 match type of H' with
                                   | P ?z => inverse_P (z :: x :: ns)
                                   | _ => inverse_P (x :: ns)
                                 end
                           end
                         | _ => idtac ""
                       end.

  (* Finally an example *)

  Goal forall x y z, P x -> P y -> P z.
  intros.
  inverse_P (@nil nat).
  Restart.
  intros. iter_tac (fun x =>
                      match type of x with
                          | P _ => inversion x
                          | _ => idtac
                      end).
  Admitted.

  Fixpoint test n :=
    match n with
      | 0 => True
      | S n => (forall x, P x -> test n)
    end.

  Goal test 10. compute.
  intros.
  Time inverse_P (@nil nat).      (*  10 s *)
  Restart.
  compute; intros.
  Time iter_tac (fun x =>
                      match type of x with
                          | P _ => inversion x
                          | _ => idtac
                      end).     (* 1.5 *)
  Admitted.

  Goal test 12. compute; intros.
  Time inverse_P (@nil nat).      (* 170 s *)
  Restart.
  compute; intros.
  Time iter_tac (fun x =>
                      match type of x with
                          | P _ => inversion x
                          | _ => idtac
                      end).     (* 12s *)

End u.


From Coq Require Import Strings.String.
From Coq Require Import Lists.List.
Import ListNotations.
From FY Require Export Utils.
From FY Require Export Syntax.
From FY Require Export Semantics.
From FY Require Export Assertion.
From FY Require Export Logic.

Definition X0 : string := "X0".
Definition X1 : string := "X1".

Definition TELEPORT : com :=
  <{
     q 1 *= GH;
     q 1 2 *= GCNOT;
     q 0 1 *= GCNOT;
     q 0 *= GH;
     X0 :=meas 0;
     X1 :=meas 1;
     if X0 == (0 % nat)
     then
       if X1 == (1 % nat) then q 2 *= GX else skip end
     else
       if X1 == (1 % nat) then q 2 *= GX; q 2 *= GZ else q 2 *= GZ end
     end
  }>.

Print TELEPORT.

Definition initial_state (a b: R) := (∣0⟩ ⊗ ∣0⟩ ⊗ (a * ∣0⟩ + b * ∣1⟩)) × ((a^* * ⟨1∣ + b^* * ⟨1∣) ⊗ ⟨0∣ ⊗ ⟨0∣).

Fixpoint satisfied_by_all_elements (n: nat) (state: State n)
  (P: bool_exp) : bool := match state with
  | [] => true
  | el :: st => andb (beval (fst el) P) (satisfied_by_all_elements n st P)
  end.

Theorem final_state: forall (a b: R),
ceval 3 3 TELEPORT
[(( _ !-> 0%nat), (initial_state a b)) ] [] .
Proof.
  intros.
    eapply E_Seq.
    apply E_AppOne.
    simpl.
    eapply E_Seq.
    simpl.
    apply E_AppTwo.
    simpl.
    eapply E_Seq.
    apply E_AppTwo.
    simpl.
    eapply E_Seq.
    apply E_AppOne.
    simpl.
    eapply E_Seq.
    apply E_Meas.
    simpl.
    eapply E_Seq.
    apply E_Meas.
    simpl.
Admitted.


Require Import Coq.Logic.Eqdep.
Require Import Coq.Logic.FunctionalExtensionality.

Require Export CatSem.COMP.PCF_rep.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

(** on our way to a category of representations:
    - an equality on morphisms of reps
*)

Inductive eq_Rep (P R : PCF_rep) : relation (PCF_rep_Hom P R) :=
 | eq_rep : forall (a c : PCF_rep_Hom P R),
            forall H : (forall t, tcomp c t = tcomp a t),
            (forall V, rep_Hom_monad a V ;; lift (M:=R) (Transp H V)
                                    ==
                       Transp H (P V) ;; rep_Hom_monad c V ) ->

             eq_Rep a c.

(** the defined relation is an equivalence and
    may hence serve as equality
*)

Lemma eq_Rep_equiv (P R: PCF_rep) :
   @Equivalence (PCF_rep_Hom P R)
     (@eq_Rep P R).
Proof.
 intros P R.
 split.

 unfold Reflexive.
 intro M.
 assert (H': forall t, tcomp M t = tcomp M t) by
       (intros; reflexivity).

 apply (eq_rep (H:=H')).

 simpl.
 intros V t y.
 destruct y as [t y].

 simpl.
 rewrite (UIP_refl _ _ (H' t)).
 simpl.
 assert (H:= lift_transp_id).
 simpl in *.
 rewrite H.
 auto.

  (* now symmetric *)

 unfold Symmetric.
 intros M N H.
 destruct H.
  assert (H': forall t, tcomp a t = tcomp c t) by auto.
 apply (eq_rep (H:=H')).
 simpl; intros V t y.
 destruct a.
 destruct c.
 simpl in *.
 assert (H3 : tcomp = tcomp0).
 apply (functional_extensionality).
 auto.

 generalize dependent y.
 generalize dependent H'.
 generalize dependent rep_Hom_monad0.
 generalize dependent rep_Hom_monad.
 generalize dependent ttriag.
 generalize dependent ttriag0.
 generalize dependent H.
 rewrite  H3.
 intros; simpl in *.
 rewrite transp_id.
 assert (H2:= lift_transp_id).
 simpl in H2.
 rewrite H2.
 assert (H4 := H0 V t y).
 rewrite transp_id in H4.
 rewrite H2 in H4.
 simpl in *; auto.

  (* finally transitive *)

  unfold Transitive.
  intros a b c H H'.
  destruct H;
  destruct H'.
  assert (Ht : forall t, tcomp c t = tcomp a t).
    intro t. transitivity (tcomp a0 t); auto.

  apply (eq_rep (H:=Ht)).
  simpl; intros V t y.
  destruct a;
  destruct a0;
  destruct c.
  simpl in *.
  assert (H5 : tcomp0 = tcomp1) by
    (apply functional_extensionality; intro; auto).

  assert (H6 : tcomp1 = tcomp) by
    (apply functional_extensionality; intro; auto).

  generalize dependent H2.
  generalize dependent H1.
  generalize dependent rep_Hom_monad.
  generalize dependent rep_Hom_monad1.
  generalize dependent rep_Hom_monad0.
  generalize dependent ttriag.
  generalize dependent ttriag1.
  generalize dependent ttriag0.
  generalize dependent H.
  generalize dependent Ht.
  rewrite  H5.
  rewrite  H6.

  clear H6 H5.
  clear tcomp0.
  clear tcomp1.

  intros.
  assert (H7:=H0 V t y).
  assert (H9:=H2 V t y).
  rewrite transp_id in *.
  simpl in *.
  assert (H8 := lift_transp_id).
  simpl in H8.
  rewrite H8 in *.
  transitivity (rep_Hom_monad0 V t y);
  auto.
Qed.

Definition eq_Rep_oid (P R : PCF_rep) := Build_Setoid (eq_Rep_equiv P R).

(** Identity Representation *)

Section id_rep.

Variable P : PCF_rep.

Definition id_rep_car:
(forall c : ITYPE (type_type P),
  (RETYPE (fun t : type_type P => t)) (P c) --->
  P ((RETYPE (fun t : type_type P => t)) c)) :=

 fun V t y =>
   match y with ctype _ z =>
     lift (M:=P) (@id_retype _ V) _ z end.

Obligation Tactic := idtac.

Program Instance blalala :
       colax_Monad_Hom_struct (P:=P) (Q:=P) (F0:=RETYPE (fun t => t))
       id_rep_car.
Next Obligation.
Proof.
  simpl.
  intros V W f t y.
  destruct y.
  simpl.
  assert (H:=lift_kleisli (M:= P)).
  simpl in *.
  rewrite H. simpl.
  assert (H':=kleisli_lift (M:=P)).
  simpl in H'.
  rewrite H'.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros V t y.
  destruct y.
  simpl.
  assert (H:=lift_weta P).
  simpl in H.
  rewrite H.
  auto.
Qed.

Definition id_Rep_monad := Build_colax_Monad_Hom blalala.

Program Instance Rep_id_struct :
         PCF_rep_Hom_struct (f := fun t => t)
         (fun t => eq_refl) id_Rep_monad.
Next Obligation.
Proof.
  simpl.
  intros V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(Succ(PCF_rep_s:=P)))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(Zero(PCF_rep_s:=P)))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(CondB(PCF_rep_s:=P)))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(CondN(PCF_rep_s:=P)))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(tttt(PCF_rep_s:=P)))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(ffff(PCF_rep_s:=P)))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros m V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(nats m(PCF_rep_s:=P)))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros t V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(bottom t(PCF_rep_s:=P)))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros t V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(rec t(PCF_rep_s:=P)))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros r s V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(app(PCF_rep_s:=P) r s ))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros r s V y.
  assert (H := mod_hom_mkl
     (Module_Hom_struct :=(abs(PCF_rep_s:=P) r s))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  apply f_equal.
  assert (H' := klkl P).
  simpl in H'.
  rewrite H'.
  assert (H'':= kl_eq P).
  simpl in *.
  apply H''.
  clear y.

  intros t y.
  assert (H4 := etakl P).
  simpl in H4.
  rewrite H4.
  simpl.
  destruct y as [t y | ].
  simpl.
  unfold lift.
  rewrite H4.
  simpl.
  auto.
  simpl.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros V y.
  assert (H := mod_hom_mkl
      (Module_Hom_struct :=(Pred(PCF_rep_s:=P)))).
  unfold lift.
  simpl in *.
  rewrite <- H.
  auto.
Qed.

Definition Rep_id := Build_PCF_rep_Hom (Rep_id_struct).

End id_rep.

Existing Instance eq_Rep_oid.
Existing Instance pcf_rep_struct.
Existing Instance rep_gen_Hom_monad_struct.


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

Set Implicit Arguments.
Set Strict Implicit.

Local Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).

(** * The Word Prover **)

Require Import Arith ILEnv Memory.

Section WordProver.
  Variable types' : list type.
  Definition types := repr bedrock_types_r types'.
  Variable funcs' : functions types.
  Definition funcs := repr (bedrock_funcs_r _) funcs'.

  Record equality := {
    Source : expr types;
    Destination : expr types;
    Difference : W
  }.

  Record word_summary := {
    Equalities : list equality;
    LessThans : list (expr types * expr types);
    NotEquals : list (expr types * expr types)
  }.

  Require Import Div2.

  Fixpoint natToWord' (sz n : nat) : word sz :=
    match sz with
      | O => WO
      | S sz' => WS (mod2 n) (natToWord' sz' (div2 n))
    end.

  Theorem natToWord'_def : natToWord' = natToWord.
    reflexivity.
  Qed.

  Definition zero := Eval compute in wzero 32.
  Definition pow32 := Eval compute in Npow2 32.

  Require Import NArith.

  Definition wplus' := @wordBin Nplus 32.
  Definition wneg' (w : W) := NToWord 32 (pow32 - wordToN w).
  Definition wminus' (x y : W) : W := wplus' x (wneg' y).

  Theorem wplus'_def : wplus' = @wplus _.
    reflexivity.
  Qed.

  Theorem wneg'_def : wneg' = @wneg _.
    reflexivity.
  Qed.

  Theorem wminus'_def : wminus' = @wminus _.
    reflexivity.
  Qed.

  Fixpoint decompose (e : expr types) : expr types * W :=
    match e with
      | Func 0%nat [e1, Func 5%nat (Const (tvType 4%nat) k :: nil)] =>
        let (e1', d) := decompose e1 in
          (e1', wplus' d (natToWord' _ k))
      | Func 1%nat [e1, Func 5%nat (Const (tvType 4%nat) k :: nil)] =>
        let (e1', d) := decompose e1 in
          (e1', wminus' d (natToWord' _ k))
      | _ => (e, zero)
    end.

  Definition combine (f1 f2 : equality) : list equality :=
    if expr_seq_dec (Destination f1) (Source f2)
      then {| Source := Source f1;
        Destination := Destination f2;
        Difference := wplus' (Difference f1) (Difference f2) |} :: nil
      else nil.

  Fixpoint combineAll (f : equality) (fs : list equality) : list equality :=
    match fs with
      | nil => fs
      | f' :: fs => combine f f' ++ combine f' f ++ combineAll f fs
    end.

  Fixpoint alreadyCovered' (f : equality) (fs : list equality) : bool :=
    match fs with
      | nil => false
      | f' :: fs' => (expr_seq_dec (Source f) (Source f')
        && expr_seq_dec (Destination f) (Destination f'))
      || alreadyCovered' f fs'
    end.

  Definition alreadyCovered (f : equality) (fs : list equality) : bool :=
    expr_seq_dec (Source f) (Destination f) || alreadyCovered' f fs.

  Fixpoint merge (fs1 fs2 : list equality) : list equality :=
    match fs1 with
      | nil => fs2
      | f :: fs1' => merge fs1' (if alreadyCovered f fs2 then fs2 else (f :: fs2))
    end.

  Definition wordLearn1 (sum : word_summary) (e : expr types) : word_summary :=
    match e with
      | Equal (tvType 0) e1 e2 =>
        let (b1, n1) := decompose e1 in
        let (b2, n2) := decompose e2 in
        let f1 := {| Source := b1;
          Destination := b2;
          Difference := wminus' n1 n2 |} in
        let f2 := {| Source := b2;
          Destination := b1;
          Difference := wminus' n2 n1 |} in
        let equalities := merge (f1 :: combineAll f1 sum.(Equalities)) sum.(Equalities) in
        let equalities := merge (f2 :: combineAll f2 equalities) equalities in
          {| Equalities := equalities;
            LessThans := sum.(LessThans);
            NotEquals := sum.(NotEquals) |}
      | Func 4 (e1 :: e2 :: nil) =>
        {| Equalities := sum.(Equalities);
          LessThans := (e1, e2) :: sum.(LessThans);
          NotEquals := sum.(NotEquals) |}
      | Not (Equal (tvType 0) e1 e2) =>
        {| Equalities := sum.(Equalities);
          LessThans := sum.(LessThans);
          NotEquals := (e1, e2) :: sum.(NotEquals) |}
      | _ => sum
    end.

  Fixpoint wordLearn (sum : word_summary) (hyps : list (expr types)) : word_summary :=
    match hyps with
      | nil => sum
      | h :: hyps' => wordLearn (wordLearn1 sum h) hyps'
    end.

  Definition equalitysEq (f1 f2 : equality) :=
    expr_seq_dec (Source f1) (Source f2)
    && expr_seq_dec (Destination f1) (Destination f2)
    && W_seq (Difference f1) (Difference f2).

  Fixpoint equalityMatches (f : equality) (fs : list equality) : bool :=
    match fs with
      | nil => false
      | f' :: fs' => equalitysEq f f' || equalityMatches f fs'
    end.

  Fixpoint lessThanMatches (e1 e2 : expr types) (lts : list (expr types * expr types)) (eqs : list equality) : bool :=
    match lts with
      | nil => false
      | (e1', e2') :: lts' => ((expr_seq_dec e1 e1'
        || equalityMatches {| Source := e1;
          Destination := e1';
          Difference := zero |} eqs)
      && (expr_seq_dec e2 e2'
        || equalityMatches {| Source := e2;
          Destination := e2';
          Difference := zero |} eqs)) || lessThanMatches e1 e2 lts' eqs
    end.

  Definition wordProve (sum : word_summary) (e : expr types) :=
    match e with
      | Equal (tvType 0) e1 e2 =>
        let (b1, n1) := decompose e1 in
        let (b2, n2) := decompose e2 in
          if expr_seq_dec b1 b2
            then W_seq n1 n2
            else equalityMatches {| Source := b1;
              Destination := b2;
              Difference := wminus' n1 n2 |} sum.(Equalities)
      | Func 4 (e1 :: e2 :: nil) =>
        lessThanMatches e1 e2 sum.(LessThans) sum.(Equalities)
      | Not (Equal (tvType 0) e1 e2) =>
        lessThanMatches e1 e2 sum.(NotEquals) sum.(Equalities)
      | _ => false
    end.

  Definition wordSummarize := wordLearn {| Equalities := nil;
    LessThans := nil;
    NotEquals := nil|}.

  Section vars.
    Variables uvars vars : env types.

    Definition equalityValid (f : equality) := exists v1, exprD funcs uvars vars (Source f) (tvType 0%nat) = Some v1
      /\ exists v2, exprD funcs uvars vars (Destination f) (tvType 0%nat) = Some v2
        /\ v2 = v1 ^+ Difference f.

    Definition lessThanValid (p : expr types * expr types) := exists v1, exprD funcs uvars vars (fst p) (tvType 0%nat) = Some v1
      /\ exists v2, exprD funcs uvars vars (snd p) (tvType 0%nat) = Some v2
        /\ v1 < v2.

    Definition notEqualValid (p : expr types * expr types) := exists v1, exprD funcs uvars vars (fst p) (tvType 0%nat) = Some v1
      /\ exists v2, exprD funcs uvars vars (snd p) (tvType 0%nat) = Some v2
        /\ v1 <> v2.

    Definition wordValid (sum : word_summary) :=
      Forall equalityValid sum.(Equalities)
      /\ Forall lessThanValid sum.(LessThans)
      /\ Forall notEqualValid sum.(NotEquals).

    Lemma addZ_0 : forall w : W, w = w ^+ zero.
      intros.
      rewrite wplus_comm.
      symmetry.
      apply wplus_unit.
    Qed.

    Hint Immediate addZ_0.

    Lemma decompose_correct : forall e, let (b, n) := decompose e in
      forall v, exprD funcs uvars vars e (tvType 0) = Some v
        -> exists v', exprD funcs uvars vars b (tvType 0) = Some v'
          /\ v = v' ^+ n.
    Proof.
      Opaque natToWord'.
      induction e; simpl; intuition.

      t; eauto.

      eauto.

      eauto.

      destruct f.
      destruct l; try discriminate.
      destruct l; try discriminate.
      eauto.

      destruct e0; eauto.
      do 6(destruct f; eauto).
      destruct l0; eauto.
      destruct e0; eauto.
      destruct t; eauto.
      do 5(destruct n; eauto).
      destruct l0; eauto.
      destruct l; eauto.
      simpl.
      inversion H; clear H; subst.
      inversion H3; clear H3; subst.
      clear H4.
      simpl in *.
      specialize (H1 _ (refl_equal _)); destruct H1; intuition; subst.
      clear H0.
      destruct (decompose e).
      intro.
      match goal with
        | [ |- context[match ?E with Some _ => _ | None => _ end] ] => destruct E
      end.
      specialize (H2 _ (refl_equal _)); destruct H2; intuition; subst.
      injection H0; clear H0; intros; subst.
      repeat esplit; eauto.
      rewrite natToWord'_def.
      rewrite wplus'_def.
      repeat rewrite wplus_assoc; reflexivity.
      discriminate.

      destruct f.
      destruct l; try discriminate.
      destruct l; try discriminate.
      eauto.

      destruct e0; eauto.
      do 6 (destruct f; eauto).
      destruct l0; eauto.
      destruct e0; eauto.
      destruct t; eauto.
      do 5 (destruct n; eauto).
      destruct l0; eauto.
      destruct l; eauto.
      simpl.
      inversion H; clear H; subst.
      inversion H3; clear H3; subst.
      clear H4.
      simpl in *.
      specialize (H1 _ (refl_equal _)); destruct H1; intuition; subst.
      clear H0.
      destruct (decompose e).
      intro.
      match goal with
        | [ |- context[match ?E with Some _ => _ | None => _ end] ] => destruct E
      end.
      specialize (H2 _ (refl_equal _)); destruct H2; intuition; subst.
      injection H0; clear H0; intros; subst.
      repeat esplit; eauto.
      rewrite wminus'_def.
      repeat rewrite wplus_assoc.
      repeat rewrite wminus_def.
      repeat rewrite wplus_assoc.
      reflexivity.
      discriminate.
      eauto.

      discriminate.
      discriminate.
    Qed.

    Lemma mergeCorrect : forall fs1,
      Forall equalityValid fs1
      -> forall fs2, Forall equalityValid fs2
        -> Forall equalityValid (merge fs1 fs2).
      induction 1; simpl; intuition.
      destruct (alreadyCovered x fs2); auto.
    Qed.

    Lemma combineCorrect : forall f1 f2,
      equalityValid f1
      -> equalityValid f2
      -> Forall equalityValid (combine f1 f2).
    Proof.
      unfold combine; intros.
      generalize (expr_seq_dec_correct (Destination f1) (Source f2)).
      destruct (expr_seq_dec (Destination f1) (Source f2)); intuition.
      repeat constructor.
      unfold equalityValid in *; simpl in *; intros.

      destruct H; intuition.
      destruct H3; intuition.
      destruct H0; intuition.
      destruct H5; intuition.
      rewrite H1.
      rewrite H5.
      repeat esplit.
      subst.
      rewrite H2 in H3.
      rewrite H0 in H3.
      injection H3; clear H3; intros; subst.
      symmetry; apply wplus_assoc.
    Qed.

    Hint Resolve combineCorrect Folds.Forall_app.

    Lemma combineAllCorrect : forall f fs,
      equalityValid f
      -> Forall equalityValid fs
      -> Forall equalityValid (combineAll f fs).
    Proof.
      induction 2; simpl; intuition.
    Qed.

    Lemma equalityValid_basic : forall hyp1 hyp2 e e0 w w0,
      Provable funcs uvars vars (Equal (tvType 0) hyp1 hyp2)
      -> (forall v : tvarD (repr bedrock_types_r types') (tvType 0),
        exprD funcs uvars vars hyp1 (tvType 0) = Some v ->
        exists v' : tvarD (repr bedrock_types_r types') (tvType 0),
          exprD funcs uvars vars e (tvType 0) = Some v' /\ v = v' ^+ w)
      -> (forall v : tvarD (repr bedrock_types_r types') (tvType 0),
        exprD funcs uvars vars hyp2 (tvType 0) = Some v ->
        exists v' : tvarD (repr bedrock_types_r types') (tvType 0),
          exprD funcs uvars vars e0 (tvType 0) = Some v' /\ v = v' ^+ w0)
      -> equalityValid {| Source := e0; Destination := e; Difference := wminus' w0 w |}.
    Proof.
      intros.
      hnf in H.
      simpl in *.
      case_eq (exprD funcs uvars vars hyp1 (tvType 0)); intros.
      simpl in *.
      rewrite H2 in *.
      case_eq (exprD funcs uvars vars hyp2 (tvType 0)); intros.
      simpl in *.
      rewrite H3 in *.
      subst.
      specialize (H1 _ (refl_equal _)).
      specialize (H0 _ (refl_equal _)).
      destruct H1; destruct H0; intuition.
      subst.
      hnf.
      repeat (esplit; simpl).
      eauto.
      rewrite H.
      f_equal.
      rewrite wminus'_def.
      apply (f_equal (fun z => z ^- w)) in H5.
      repeat rewrite wminus_def in *.
      repeat rewrite wplus_assoc in *.
      rewrite H5.
      rewrite <- wplus_assoc.
      rewrite wminus_inv.
      rewrite wplus_comm.
      symmetry; apply wplus_unit.

      simpl in *.
      rewrite H3 in *.
      tauto.

      simpl in *.
      rewrite H2 in *.
      tauto.
    Qed.

    Lemma Provable_swap : forall hyp1 hyp2,
      Provable funcs uvars vars (Equal (tvType 0) hyp1 hyp2)
      -> Provable funcs uvars vars (Equal (tvType 0) hyp2 hyp1).
    Proof.
      unfold Provable; simpl; intros.
      case_eq (exprD funcs uvars vars hyp2 (tvType 0)); intros.
      simpl in *; rewrite H0 in *.
      case_eq (exprD funcs uvars vars hyp1 (tvType 0)); intros.
      simpl in *; rewrite H1 in *.
      auto.
      simpl in *; rewrite H1 in *; auto.
      simpl in *; rewrite H0 in *; auto.
      case_eq (exprD funcs uvars vars hyp1 (tvType 0)); intros; simpl in *.
      rewrite H1 in *; auto.
      rewrite H1 in *; auto.
    Qed.

    Hint Immediate Provable_swap.
    Hint Resolve equalityValid_basic mergeCorrect combineAllCorrect.

    Lemma Forall_if : forall (b : bool) ls1 ls2,
      Forall equalityValid ls1
      -> Forall equalityValid ls2
      -> Forall equalityValid (if b then ls1 else ls2).
    Proof.
      destruct b; auto.
    Qed.

    Hint Resolve Forall_if.

    Lemma wordLearn1Correct : forall sum,
      wordValid sum -> forall hyp,
        Provable funcs uvars vars hyp ->
        wordValid (wordLearn1 sum hyp).
    Proof.
      destruct hyp; simpl; intuition.

      do 5 (destruct f; auto).
      do 3 (destruct l; auto).
      destruct H; split; simpl; auto.
      split.
      constructor; auto.
      hnf; simpl.
      red in H0; simpl in H0.
      simpl in *.
      do 2 (match type of H0 with
              | match match ?E with Some _ => _ | _ => _ end _ _ with Some _ => _ | _ => _ end => destruct E
            end; try tauto).
      eauto.
      tauto.
      tauto.

      destruct t; auto.
      destruct n; auto.
      specialize (decompose_correct hyp1); intro Hy1.
      specialize (decompose_correct hyp2); intro Hy2.
      destruct (decompose hyp1); destruct (decompose hyp2).

      destruct H.
      split; simpl; auto.
      apply mergeCorrect; try apply Forall_if; eauto 15.

      destruct hyp; auto.
      destruct t; auto.
      destruct n; auto.
      destruct H.
      destruct H1.
      repeat split; simpl; auto.
      constructor; auto.
      hnf; simpl.
      red in H0; simpl in H0.
      simpl in *.
      match goal with
        | [ |- exists v1, ?E = _ /\ (exists v2, ?F = _ /\ _) ] => destruct E; try tauto;
          destruct F; try tauto
      end.
      eauto.
    Qed.

    Hint Resolve wordLearn1Correct.

    Theorem wordLearnCorrect : forall sum,
      wordValid sum
      -> forall hyps, AllProvable funcs uvars vars hyps
        -> wordValid (wordLearn sum hyps).
    Proof.
      intros; generalize dependent sum; induction hyps; simpl in *; intuition.
    Qed.

    Hint Unfold wordValid.

    Theorem wordSummarizeCorrect : forall hyps,
      AllProvable funcs uvars vars hyps
      -> wordValid (wordSummarize hyps).
    Proof.
      intros; apply wordLearnCorrect; auto.
      repeat split; constructor.
    Qed.

    Lemma equalitysEq_correct : forall f1 f2,
      equalitysEq f1 f2 = true
      -> f1 = f2.
    Proof.
      unfold equalitysEq; intros.
      apply andb_prop in H; intuition.
      apply andb_prop in H0; intuition.
      destruct f1; destruct f2; simpl in *.
      f_equal; auto.
      apply expr_seq_dec_correct; auto.
      apply expr_seq_dec_correct; auto.
      apply (Eqb_correct bedrock_type_W); auto.
    Qed.

    Lemma equalityMatches_correct : forall f eqs,
      Forall equalityValid eqs
      -> equalityMatches f eqs = true
      -> equalityValid f.
    Proof.
      induction 1; simpl; intuition.
      apply orb_prop in H1; intuition.
      apply equalitysEq_correct in H2; congruence.
    Qed.

    Lemma lessThanMatches_correct : forall e1 e2 eqs,
      Forall equalityValid eqs
      -> forall lts, Forall lessThanValid lts
        -> lessThanMatches e1 e2 lts eqs = true
        -> lessThanValid (e1, e2).
    Proof.
      induction 2; simpl; intuition.
      destruct x.
      apply orb_prop in H2; intuition.
      apply andb_prop in H3; intuition.
      apply orb_prop in H2; intuition;
        apply orb_prop in H4; intuition.
      apply expr_seq_dec_correct in H3.
      apply expr_seq_dec_correct in H2.
      congruence.

      apply equalityMatches_correct in H2; auto.
      destruct H2; intuition.
      destruct H5; intuition.
      subst.
      simpl in *.
      apply expr_seq_dec_correct in H3; subst.
      destruct H0; intuition.
      destruct H3; intuition.
      simpl in *.
      hnf.
      simpl.
      repeat esplit.
      eauto.
      eauto.
      rewrite wplus_comm in H5.
      rewrite wplus_unit in H5.
      congruence.

      apply equalityMatches_correct in H3; auto.
      destruct H3; intuition.
      destruct H5; intuition.
      subst.
      simpl in *.
      apply expr_seq_dec_correct in H2; subst.
      destruct H0; intuition.
      destruct H3; intuition.
      simpl in *.
      hnf.
      simpl.
      repeat esplit.
      eauto.
      eauto.
      rewrite wplus_comm in H5.
      rewrite wplus_unit in H5.
      congruence.

      apply equalityMatches_correct in H3; auto.
      apply equalityMatches_correct in H2; auto.
      destruct H3; intuition.
      destruct H5; intuition.
      subst.
      destruct H2; intuition.
      destruct H6; intuition.
      subst.
      simpl in *.
      rewrite wplus_comm in H5.
      rewrite wplus_unit in H5.
      rewrite wplus_comm in H6.
      rewrite wplus_unit in H6.
      destruct H0; intuition.
      destruct H7; intuition.
      simpl in *.
      hnf.
      repeat esplit.
      eauto.
      eauto.
      congruence.
    Qed.

    Lemma lessThanMatches_notEqual_correct : forall e1 e2 eqs,
      Forall equalityValid eqs
      -> forall lts, Forall notEqualValid lts
        -> lessThanMatches e1 e2 lts eqs = true
        -> notEqualValid (e1, e2).
    Proof.
      induction 2; simpl; intuition.
      destruct x.
      apply orb_prop in H2; intuition.
      apply andb_prop in H3; intuition.
      apply orb_prop in H2; intuition;
        apply orb_prop in H4; intuition.
      apply expr_seq_dec_correct in H3.
      apply expr_seq_dec_correct in H2.
      congruence.

      apply equalityMatches_correct in H2; auto.
      destruct H2; intuition.
      destruct H5; intuition.
      subst.
      simpl in *.
      apply expr_seq_dec_correct in H3; subst.
      destruct H0; intuition.
      destruct H3; intuition.
      simpl in *.
      hnf.
      simpl.
      repeat esplit.
      eauto.
      eauto.
      rewrite wplus_comm in H5.
      rewrite wplus_unit in H5.
      congruence.

      apply equalityMatches_correct in H3; auto.
      destruct H3; intuition.
      destruct H5; intuition.
      subst.
      simpl in *.
      apply expr_seq_dec_correct in H2; subst.
      destruct H0; intuition.
      destruct H3; intuition.
      simpl in *.
      hnf.
      simpl.
      repeat esplit.
      eauto.
      eauto.
      rewrite wplus_comm in H5.
      rewrite wplus_unit in H5.
      congruence.

      apply equalityMatches_correct in H3; auto.
      apply equalityMatches_correct in H2; auto.
      destruct H3; intuition.
      destruct H5; intuition.
      subst.
      destruct H2; intuition.
      destruct H6; intuition.
      subst.
      simpl in *.
      rewrite wplus_comm in H5.
      rewrite wplus_unit in H5.
      rewrite wplus_comm in H6.
      rewrite wplus_unit in H6.
      destruct H0; intuition.
      destruct H7; intuition.
      simpl in *.
      hnf.
      repeat esplit.
      eauto.
      eauto.
      congruence.
    Qed.
  End vars.

  Hint Resolve equalityMatches_correct.

  Theorem wordProverCorrect : ProverCorrect funcs wordValid wordProve.
  Proof.
    hnf; intros.
    destruct H.
    destruct goal; simpl in *; try discriminate.

    do 5 (destruct f; try discriminate).
    do 3 (destruct l; try discriminate).
    apply (@lessThanMatches_correct uvars vars) in H0; auto.
    destruct H0; intuition.
    destruct H5; intuition.
    hnf.
    simpl in *.
    rewrite H2.
    rewrite H5.
    assumption.
    tauto.

    destruct t; try discriminate.
    destruct n; try discriminate.
    specialize (decompose_correct uvars vars goal1); intro Hy1.
    specialize (decompose_correct uvars vars goal2); intro Hy2.
    destruct (decompose goal1); destruct (decompose goal2).
    simpl in *.

    hnf in H1; simpl in H1.
    destruct H1.
    case_eq (exprD funcs uvars vars goal1 (tvType 0)); simpl; intros.
    rewrite H3 in *.
    case_eq (exprD funcs uvars vars goal2 (tvType 0)); simpl; intros.
    rewrite H4 in *.
    injection H1; clear H1; intros; subst.
    specialize (Hy1 _ (refl_equal _)); destruct Hy1.
    specialize (Hy2 _ (refl_equal _)); destruct Hy2.
    intuition; subst.
    hnf; simpl.
    rewrite H3.
    rewrite H4.

    generalize (expr_seq_dec_correct e e0).
    destruct (expr_seq_dec e e0); intuition; subst.

    apply (Expr.Eqb_correct bedrock_type_W) in H0.
    congruence.

    clear H5.
    eapply equalityMatches_correct in H0; eauto.
    destruct H0; simpl in *; intuition.
    destruct H8; intuition.
    subst.
    rewrite H5 in H2; injection H2; clear H2; intros; subst.
    rewrite H8 in H1; injection H1; clear H1; intros; subst.
    rewrite wminus'_def.
    rewrite wminus_def.
    repeat rewrite <- wplus_assoc.
    rewrite (wplus_comm (^~ w0) w0).
    rewrite wminus_inv.
    rewrite (wplus_comm w (wzero 32)).
    rewrite wplus_unit.
    reflexivity.

    rewrite H4 in *; discriminate.
    rewrite H3 in *; discriminate.

    destruct goal; try discriminate.
    destruct t; try discriminate.
    destruct n; try discriminate.
    apply (@lessThanMatches_notEqual_correct uvars vars) in H0; auto.
    destruct H0; intuition.
    destruct H5; intuition.
    hnf.
    simpl in *.
    rewrite H2.
    rewrite H5.
    assumption.
    tauto.
  Qed.

  Lemma wordValid_weaken : forall (u g : env types) (f : word_summary)
    (ue ge : list (sigT (tvarD types))),
    wordValid u g f -> wordValid (u ++ ue) (g ++ ge) f.
  Proof.
    unfold wordValid; intuition.
    induction H0; eauto.
    econstructor; eauto. unfold equalityValid in *.
    repeat match goal with
             | [ H : exists x, _ |- _ ] => destruct H
             | [ H : _ /\ _ |- _ ] => destruct H
             | [ |- _ ] => erewrite exprD_weaken by eauto
             | [ |- exists x, _ ] => eexists; split; [ reflexivity | ]
           end; auto.
    induction H; eauto.
    econstructor; eauto. clear IHForall. unfold lessThanValid in *.
    repeat match goal with
             | [ H : exists x, _ |- _ ] => destruct H
             | [ H : _ /\ _ |- _ ] => destruct H
             | [ |- _ ] => erewrite exprD_weaken by eauto
             | [ |- exists x, _ ] => eexists; split; [ reflexivity | ]
           end; auto.
    induction H2; eauto.
    econstructor; eauto. clear IHForall. unfold notEqualValid in *.
    repeat match goal with
             | [ H : exists x, _ |- _ ] => destruct H
             | [ H : _ /\ _ |- _ ] => destruct H
             | [ |- _ ] => erewrite exprD_weaken by eauto
             | [ |- exists x, _ ] => eexists; split; [ reflexivity | ]
           end; auto.
  Qed.

  Definition wordProver : ProverT types :=
  {| Facts := word_summary
   ; Summarize := wordSummarize
   ; Learn := wordLearn
   ; Prove := wordProve
   |}.

  Definition wordProver_correct : ProverT_correct wordProver funcs.
    eapply Build_ProverT_correct with (Valid := wordValid);
      eauto using wordValid_weaken, wordSummarizeCorrect, wordLearnCorrect, wordProverCorrect.
  Qed.

End WordProver.

Definition WordProver : ProverPackage :=
{| ProverTypes := bedrock_types_r
 ; ProverFuncs := bedrock_funcs_r
 ; Prover_correct := wordProver_correct
|}.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D M : Universe, ((wd_ A C /\ (wd_ B D /\ (col_ A B C /\ (col_ A M C /\ col_ B M D)))) -> col_ A B M)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import EqNat.

Inductive tp : Set :=
  | tp_nat : tp
  | tp_exp : tp -> tp -> tp.

Notation "a --> b" := (tp_exp a b) (at level 51, right associativity).

Fixpoint beq_tp (a b : tp) : bool :=
  match a, b with
  | tp_nat, tp_nat => true
  | a0 --> a1, b0 --> b1 => andb (beq_tp a0 b0) (beq_tp a1 b1)
  | _, _ => false
  end.

Inductive term : tp -> Set :=
  | term_var a : nat -> term a
  | term_app a b : term (a --> b) -> term a -> term b
  | term_abs a b : nat -> term b -> term (a --> b)
  | term_let a b : nat -> term a -> term b -> term b
  | term_zero : term tp_nat
  | term_succ : term (tp_nat --> tp_nat)
  | term_pred : term (tp_nat --> tp_nat)
  | term_ifz a : term tp_nat -> term a -> term a -> term a
  | term_fix a : term (a --> a) -> term a
  | term_join a : term a -> term a -> term a
  | term_rand a : term a -> term a -> term a.

(* This fails to type check
Fixpoint subs {a : tp} (x : term a) :
  forall nb : nat * tp, term (snd nb) -> term a :=
  let s := subs in
  match x with
  | term_var a n => fun na' =>
      let (n', a') := na' in
      if andb (beq_nat n n') (beq_tp a a')
      then fun y => y
      else fun y => x
  | term_app a b x0 x1 => fun na y =>
      term_app a b (s x0 na y) (s x1 na y)
  | term_abs a b n x0 => fun na' y =>
      let (n', a') := na' in
      if andb (beq_nat n n') (beq_tp a a')
      then x
      else term_abs a b n (s x0 na' y)
  | term_let a b n z0 x0 => fun na' y =>
      let (n', a') := na' in
      if andb (beq_nat n n') (beq_tp a a')
      then term_let a b n (s z0 na' y) x0
      else term_let a b n (s z0 na' y) (s x0 na' y)
  | term_zero => fun na y => term_zero
  | term_succ => fun na y => term_succ
  | term_pred => fun na y => term_pred
  | term_ifz a x0 x1 x2 => fun na y =>
      term_ifz (s x0 na y) (s x1 na y) (s x2 na y)
  | term_fix a x0 => fun na y => fun na y =>
      term_fix a (s x0 na y)
  | term_join a x0 x1 => fun na y =>
      term_app (s x0 na y) (s x1 na y)
  | term_rand a x0 x1 => fun na y =>
      term_app (s x0 na y) (s x1 na y)
  end.
*)

(* This fails to type check
Fixpoint subs {a b : tp} (v : nat) (x : term a) (y : term b) : term b :=
  let s := subs v x in
  match y with
  | term_var a v' => if beq_nat v v' then x else y
  | term_app a b y0 y1 => term_app a b (s y0) (s y1)
  | term_abs a b v' y0 => if beq_nat v v' then y else term_abs a b v (s y0)
  | term_let a b v' x0 y0 =>
      if beq_nat v v'
      then term_let a b v (s x0) y0
      else term_let a b v (s x0) (s y0)
  | term_zero => term_zero
  | term_succ => term_succ
  | term_pred => term_pred
  | term_ifz a y0 y1 y2 => term_ifz (s y0) (s y1) (s y2)
  | term_fix a y0 => term_fix a (s y0)
  | term_join a y0 y1 => term_app (s y0) (s y1)
  | term_rand a y0 y1 => term_app (s y0) (s y1)
  end.
*)

(*
Inductive step : forall a, term a -> term a -> Set :=
  | step_
*)


From S5 Require Export maximal.
From S5 Require Export inference_modal.

Record can_world := {
  world_set :> form -> Prop;
  world_set_mcs : max_consistent world_set;
}.

Definition can_rel (F G : can_world) : Prop :=
  forall f, G f -> F (Diamond f).

Definition can_val (G : can_world) (x : var) : Prop :=
  G (Var x).

Definition world_from_set (G : form_set) (conG : consistent G) : can_world :=
  let G' := max_consistent_set G in
  {| world_set := G';
    world_set_mcs := max_consistent_set_correct G conG |}.

Lemma world_closed_derv (G : can_world) (f g : form) :
  (ax_s5 G f -> ax_s5 G g) -> G f -> G g.
Proof.
  intros H Ff. apply max_consistent_member.
  { apply G. }
  apply H, a_0, Ff.
Qed.

Lemma can_relation (F G : can_world):
  can_rel F G <-> (forall f, F (Box f) -> G f).
Proof.
  split.
  - assert (orG : forall x, G x \/ G (Neg x)).
    { apply G. }
    intros R f Fbf. destruct (orG f) as [Gf | Gnf].
    { assumption. } unfold can_rel in R.
    specialize (R _ Gnf). eapply world_closed_derv in Fbf.
    2:{ apply ax_s5_df_box. }
    exfalso. eapply (consistent_member F).
    + apply F.
    + apply R.
    + assumption.
  - assert (orF : forall x, F x \/ F (Neg x)).
    { apply F. }
    intros H f Gf. specialize (orF (Diamond f)). destruct orF as [Fdf | Fndf].
    { assumption. }
    unfold Diamond in Fndf. eapply world_closed_derv in Fndf.
    2:{ apply ax_s5_dne_infer. }
    specialize (H _ Fndf). exfalso. eapply (consistent_member G).
    + apply G.
    + apply Gf.
    + assumption.
Qed.

Lemma can_rel_reflex :
  reflexive _ can_rel.
Proof.
  intros G f H. apply (can_relation G G).
  - intros g. apply world_closed_derv. apply mp. apply a_t.
  - assumption.
Qed.

Lemma can_rel_trans :
  transitive _ can_rel.
Proof.
  intros E F G R1 R2 f H. unfold can_rel in R1, R2.
  eapply world_closed_derv.
  - apply ax_s5_4_diamond.
  - apply R1, R2, H.
Qed.

Lemma can_rel_sym :
  symmetric _ can_rel.
Proof.
  intros F G R f H. apply (can_relation F G).
  - assumption.
  - eapply world_closed_derv.
    + apply mp. apply a_b.
    + assumption.
Qed.

Lemma can_rel_equiv :
  equiv _ can_rel.
Proof.
  split; [ | split ].
  - apply can_rel_reflex.
  - apply can_rel_trans.
  - apply can_rel_sym.
Qed.

Definition can_model : model :=
  {| world := can_world;
     rel := can_rel;
     val := can_val;
     eq := can_rel_equiv;
  |}.

Definition can_rel_box_set (w : can_model) : form_set :=
  fun f => w (Box f).

Lemma subset_can_rel_box_set (w : can_model) :
  subset (can_rel_box_set w) w.
Proof.
  intros f H. unfold can_rel_box_set in H. apply (world_closed_derv _ (Box f)).
  - apply mp, a_t.
  - assumption.
Qed.

Lemma consistent_can_rel_box_set (w : can_model) :
  consistent (can_rel_box_set w).
Proof.
  apply (consistent_subset _ w).
  - apply w.
  - apply subset_can_rel_box_set.
Qed.

Lemma ax_s5_can_rel_box_set (w : can_model) f :
  ax_s5 (can_rel_box_set w) f -> ax_s5 w (Box f).
Proof.
  intros H. remember (can_rel_box_set w) as G. revert HeqG.
  induction H; intros H1; subst.
  - unfold can_rel_box_set in H. apply a_0. assumption.
  - apply nec. apply a_1.
  - apply nec. apply a_2.
  - apply nec. apply a_3.
  - apply nec. apply a_k.
  - apply nec. apply a_t.
  - apply nec. apply a_4.
  - apply nec. apply a_b.
  - assert (IH1: ax_s5 w (Box f)).
    { apply IHax_s5_2. reflexivity. }
    assert (IH2: ax_s5 w (Box (Impl f g))).
    { apply IHax_s5_1. reflexivity. }
    eapply mp.
    + eapply mp.
      * apply a_k.
      * apply IH2.
    + apply IH1.
  - apply nec. apply nec. assumption.
Qed.

Lemma existence_lemma (w1 : can_model) (f : form) :
  w1 (Diamond f) -> exists w2, can_rel w1 w2 /\ w2 f.
Proof.
  intros H1. pose (G := can_rel_box_set w1).
  assert (conGf: consistent (add_singleton G f)).
  { destruct (excluded_middle(consistent (add_singleton G f))) as [conGf | nconGf].
    { assumption. }
    exfalso. apply (consistent_member w1 (Box (Neg f))).
    { apply w1. }
    2:{ assumption. }
    apply max_consistent_member, ax_s5_can_rel_box_set.
    { apply w1. }
    apply deduction_theorem, double_negation_elimination, nconGf.
  }
  pose (w2 := world_from_set (add_singleton G f) conGf).
  exists w2. split.
  - apply can_relation. intros x H2. simpl. exists 0. simpl.
    apply subset_add_singleton. assumption.
  - exists 0. simpl. apply member_add_singleton.
Qed.

Lemma world_impl (G : can_world) (f g : form) :
  (G f -> G g) <-> G (Impl f g).
Proof.
  split.
  - intros Gfg. assert (max_consistent G) as [conG orG].
    { apply G. }
    destruct (orG g) as [Gg | Gng].
    + apply (world_closed_derv _ g).
      2:{ assumption. }
      intros H. apply (mp _ g).
      * apply a_1.
      * assumption.
    + destruct (orG f) as [Gf | Gnf].
      * exfalso. apply Gfg in Gf.
        apply (consistent_member G g conG); assumption.
      * eapply world_closed_derv.
        { apply mp, a_3. }
        apply (world_closed_derv _ (Neg f)).
        2:{ assumption. }
        intros H. apply (mp _ (Neg f)).
        -- apply a_1.
        -- assumption.
  - intros Gfg Gf.
    apply (world_closed_derv _ (Impl f g)).
    2:{ assumption. }
    intros H. apply (mp _ _ _ H).
    apply (max_consistent_member G).
    + apply G.
    + assumption.
Qed.

Lemma truth_lemma :
  forall (f : form) (w1 : can_model) , w1 f <-> interpret f can_model w1.
Proof.
  induction f; simpl; split; intros H1.
  - apply w1, a_0, H1.
  - contradiction.
  - assumption.
  - assumption.
  - intros H2. apply IHf2. apply (world_impl _ f1).
    { assumption. }
    apply IHf1, H2.
  - apply world_impl. intros H2. apply IHf2, H1, IHf1, H2.
  - intros w2 R. apply IHf. apply (can_relation w1); assumption.
  - assert (max_consistent w1) as [_ orW1].
    { apply w1. }
    specialize (orW1 (Box f)) as [w1bf | w1nbf ].
    { assumption. }
    apply (world_closed_derv w1 _ (Neg (Box (Neg (Neg f))))) in w1nbf.
    2:{ apply mp. eapply mp.
        { apply a_3. }
         apply ax_s5_impl_2_neg_1, ax_s5_impl_2_neg_2, ax_s5_box_dne. }
    eapply existence_lemma in w1nbf as [w2 [R w2f]].
    specialize (H1 w2 R). apply IHf in H1. exfalso.
    apply (consistent_member w2 f).
    + apply w2.
    + assumption.
    + assumption.
Qed.


Load loadpath.
Require Import Coq.ZArith.ZArith Coq.Lists.List Coq.Sorting.Permutation
               Coq.Logic.Classical.
Require Import VST.msl.Axioms VST.msl.predicates_sa.
Require Import veristar.datatypes veristar.clauses veristar.list_denote
               veristar.model_type veristar.model veristar.spred_lemmas
               veristar.basic.

Module Type CLAUSIFY_SOUND.
Declare Module VSM : VERISTAR_MODEL.
Import VSM VeriStarLogic.

Axiom cnf_correct : forall (e : entailment),
  entailment_denote e =
  forall s, ~ list_denote clause_denote (@andp state) TT (cnf e) s.

End CLAUSIFY_SOUND.

Module Clausify_Sound (VSM : VERISTAR_MODEL) : CLAUSIFY_SOUND
  with Module VSM := VSM.
Module VSM := VSM.
Import VSM VeriStarLogic.

Module SPredLems := SPredLemmas VSM. Import SPredLems.

Lemma clausify_single_purepos : forall purea,
  listd pure_atom_denote (@andp state) TT (purea :: nil) =
  clause_denote (mkPureClause nil (order_eqv_pure_atom purea :: nil)).
Proof.
intros; extensionality s; simpl.
apply prop_ext; split; intros.
destruct H. left.
rewrite <- pure_atom_denote_order_eqv_pure_atom. auto.
destruct H. auto.
repeat split; auto.
rewrite <- pure_atom_denote_order_eqv_pure_atom in H. auto.
destruct H.
Qed.

Lemma clausify_single_pureneg : forall purea,
  list_denote (neg oo pure_atom_denote) (@andp state) TT (purea :: nil) =
  clause_denote (mkPureClause (order_eqv_pure_atom purea :: nil) nil).
Proof.
intros. extensionality s. simpl.
apply prop_ext; split; intros.
destruct H. destruct H0. destruct H.
rewrite <- pure_atom_denote_order_eqv_pure_atom in H0. auto.
repeat split; auto. unfold neg,compose. intro Contra.
destruct H.
rewrite <- pure_atom_denote_order_eqv_pure_atom.
split; auto.
Qed.

Lemma clausify_purepos : forall l : list pure_atom,
  list_denote pure_atom_denote (@andp state) TT l =
  list_denote clause_denote (@andp state) TT
    (map (fun a => mkPureClause nil (order_eqv_pure_atom a::nil)) l).
Proof.
intros. extensionality s.
induction l; simpl; apply prop_ext; split; intros; auto.
split. rewrite <- clausify_single_purepos. simpl.
destruct H as [H _]. repeat split; auto.
rewrite <- IHl.
destruct H as [_ H]. repeat split; auto.
destruct H. rewrite <- clausify_single_purepos in H. simpl in H.
destruct H. rewrite <- IHl in H0.
repeat split; auto.
Qed.

Lemma clausify_pureposP : forall (l : list pure_atom) P,
  list_denote pure_atom_denote (@andp state) P l =
  list_denote clause_denote (@andp state) P
    (map (fun a => mkPureClause nil (order_eqv_pure_atom a::nil)) l).
Proof.
intros. extensionality s.
induction l; simpl; apply prop_ext; split; intros; auto.
split. rewrite <- clausify_single_purepos. simpl.
destruct H as [H _]. repeat split; auto.
rewrite <- IHl.
destruct H as [_ H]. repeat split; auto.
destruct H. rewrite <- clausify_single_purepos in H. simpl in H.
destruct H. rewrite <- IHl in H0.
repeat split; auto.
Qed.

Lemma clausify_pureneg : forall l : list pure_atom,
  list_denote (neg oo pure_atom_denote) (@andp state) TT l =
  list_denote clause_denote (@andp state) TT
    (map (fun a => mkPureClause (order_eqv_pure_atom a::nil) nil) l).
Proof.
intros. extensionality s.
induction l; simpl; apply prop_ext; split; intros; auto.
split. rewrite <- clausify_single_pureneg. simpl.
destruct H as [H _]. split; auto.
rewrite <- IHl. simpl. destruct H; auto.
destruct H. rewrite <- clausify_single_pureneg in H.
destruct H. rewrite <- IHl in H0. split; auto.
Qed.

Lemma clausify_space : forall l : list space_atom,
  space_denote l = clause_denote (PosSpaceClause nil nil l).
Proof.
intros. extensionality s.
apply prop_ext; split; intros.
simpl in *; auto.
simpl in *. apply H; auto.
Qed.

Lemma pure_atom_list_neg2 : forall (l: list pure_atom) s,
  (~(list_denote pure_atom_denote (@orp state) FF l s)) =
  list_denote (neg oo pure_atom_denote) (@andp state) TT l s.
Proof.
intros. apply prop_ext; split; intros.
induction l; simpl in *; auto.
unfold neg,compose in * |-.
assert (~pure_atom_denote a s /\
        ~list_denote pure_atom_denote (@orp state) FF l s).
  clear IHl. firstorder.
  destruct H0; split; auto.
intro Contra. induction l; simpl in *; auto. apply H; auto.
destruct Contra; auto.
exfalso. destruct H. apply IHl; auto.
Qed.

Lemma mk_pureR_denote1: forall pnatoms purepos pureneg P s,
  mk_pureR pnatoms = (purepos, pureneg) ->
  listd pn_atom_denote inter P pnatoms s ->
  (listd pure_atom_denote inter P purepos s /\
    ~listd pure_atom_denote (@orp state) FF pureneg s).
Proof.
intros pnatoms.
induction pnatoms; intros.
  inversion H; subst. simpl. split. trivial.
  intros N. apply N.
destruct H0 as [HD TL].
  simpl in *.
  remember (mk_pureR pnatoms) as mkP. destruct mkP.
  destruct (IHpnatoms _ _ _ _ (eq_refl _) TL) as [IHP IHN]. clear IHpnatoms TL.
  destruct a. inversion H; subst. clear H.
    simpl. split; trivial.
    split. generalize (pure_atom_denote_order_eqv_pure_atom (Eqv e e0)) as H1; intro.
           unfold order_eqv_pure_atom in H1. rewrite <-H1.
           apply HD. apply IHP.
  inversion H; subst. clear H.
    simpl. split; trivial.
     intros N. destruct N. simpl in HD. apply HD.
         generalize (pure_atom_denote_order_eqv_pure_atom (Eqv e e0)) as H1; intro.
         unfold order_eqv_pure_atom in H1. rewrite <-H1 in H; auto.
         apply IHN. apply H.
Qed.

Lemma mk_pureR_denote2: forall pnatoms purepos pureneg P s,
  mk_pureR pnatoms = (purepos, pureneg) ->
  listd pure_atom_denote inter P purepos s ->
  ~ listd pure_atom_denote (@orp state) FF pureneg s ->
  listd pn_atom_denote inter P pnatoms s.
Proof.
intros pnatoms.
induction pnatoms; simpl; intros.
  inversion H; subst. trivial.
remember (mk_pureR pnatoms) as mkP. destruct mkP.
destruct a. inversion H; subst. clear H. simpl in *.
  destruct H0. split.
  generalize (pure_atom_denote_order_eqv_pure_atom (Eqv e e0)) as H2; intro.
    unfold order_eqv_pure_atom in H2. rewrite <-H2 in H; auto.
  eapply  IHpnatoms. reflexivity. assumption.
  apply H1.
inversion H; subst. clear H.
  rewrite pure_atom_list_neg2 in H1.
  simpl in *. destruct H1.
  split. unfold compose in H.
    generalize (pure_atom_denote_order_eqv_pure_atom (Eqv e e0)) as H2; intro.
    unfold order_eqv_pure_atom in H2. rewrite <-H2 in H; auto.
  eapply IHpnatoms; clear IHpnatoms. reflexivity. apply H0.
  rewrite pure_atom_list_neg2. apply H1.
Qed.

Lemma mk_pureR_denote: forall pnatoms purepos pureneg P s,
  mk_pureR pnatoms = (purepos, pureneg) ->
  listd pn_atom_denote inter P pnatoms s =
  (listd pure_atom_denote inter P purepos s /\
    ~listd pure_atom_denote (@orp state) FF pureneg s).
Proof.
intros.
apply prop_ext.
split; intros.
  eapply (mk_pureR_denote1 _ _ _ _ _ H H0).
destruct H0.
  eapply (mk_pureR_denote2 _ _ _ _ _ H H0 H1).
Qed.

Lemma mk_pureR_denote3: forall pnatoms purepos pureneg P s,
  mk_pureR pnatoms = (purepos, pureneg) ->
  listd pure_atom_denote inter P purepos s ->
  ~ listd pn_atom_denote inter P pnatoms s ->
  listd pure_atom_denote (@orp state) FF pureneg s.
Proof.
intros.
rewrite (mk_pureR_denote _ _ _ _ s H) in H1.
apply not_and_or in H1.
destruct H1.
apply Decidable.not_not; auto.
apply classic.
apply Decidable.not_not; auto.
apply classic.
Qed.

Lemma clausify_succ : forall pnatoms (purepos pureneg : list pure_atom)
  (space : list space_atom) (s : state)
  (Hyp: mk_pureR pnatoms = (purepos, pureneg)),
  (~assertion_denote (Assertion pnatoms space) s) =
  (clause_denote (NegSpaceClause purepos space pureneg) s).
Proof.
intros. simpl.
rewrite (@listd_unfold_inter _ state).
pattern (list_denote (neg oo pure_atom_denote) (@andp state)
  (space_denote space) pureneg).
rewrite (@listd_unfold_inter _ state).
pattern (list_denote pure_atom_denote (@andp state) (space_denote space) purepos).
rewrite (@listd_unfold_inter _ state).
apply prop_ext; split; intros.
destruct H0.
apply Decidable.not_and in H.
2: apply classic.
destruct H.
  eapply mk_pureR_denote3. apply Hyp. apply H0. apply H.
destruct (H H1).

intros N. destruct N.
  destruct (mk_pureR_denote1 _ _ _ _ s Hyp H0). clear H0.
  apply H3. apply H. split; assumption.
Qed.

Lemma clausify_succClassic : forall pnatoms (purepos pureneg : list pure_atom)
  (space : list space_atom) (s : state)
  (Hyp: mk_pureR pnatoms = (purepos, pureneg)),
   (assertion_denote (Assertion pnatoms space) s) =
  (~clause_denote (NegSpaceClause purepos space pureneg) s).
Proof.
intros. rewrite <- (clausify_succ pnatoms).
apply prop_ext; split; intros.
  intros N. apply (N H).
apply Decidable.not_not; auto.
 apply classic.
assumption.
Qed.

Lemma mk_pureL_denote: forall a s,
  clause_denote (mk_pureL a) s -> pn_atom_denote a s.
Proof.
intros.
destruct a; simpl in *.
  assert (T : TT s). trivial.
  assert (HH := H T). clear H T.
  remember (expr_cmp e e0) as b; destruct b; simpl in *.
    destruct HH. assumption. contradiction.
    destruct HH. apply var_eq_sym. apply H. contradiction.
    destruct HH. assumption. contradiction.
intros N. apply H. clear H.
  remember (expr_cmp e e0) as b; destruct b; simpl in *.
    split; trivial.
    split; trivial. apply var_eq_sym. assumption.
    split; trivial.
Qed.

Lemma mk_pureL_denoteInv: forall a s,
  pn_atom_denote a s -> clause_denote (mk_pureL a) s.
Proof.
intros.
destruct a; simpl in *. intros X. clear X.
  remember (expr_cmp e e0) as b; destruct b; simpl in *.
    left; trivial.
    left. apply var_eq_sym. assumption.
    left. trivial.
  intros HH. apply H. clear H.
  remember (expr_cmp e e0) as b; destruct b; simpl in *.
    destruct HH. assumption.
    destruct HH. apply var_eq_sym. apply H.
    destruct HH. assumption.
Qed.

Lemma mk_pureL_denoteEq: forall a,
  pn_atom_denote a = clause_denote (mk_pureL a).
Proof.
intros.
apply extensionality. intros s.
apply prop_ext; split; intros.
 apply mk_pureL_denoteInv. apply H.
  apply mk_pureL_denote. apply H.
Qed.

Lemma mk_pureL_clause_denote: forall pi P s,
  listd clause_denote inter P (map mk_pureL pi) s ->
  listd pn_atom_denote inter P pi s.
Proof.
intros pi.
induction pi; intros; simpl in *. trivial.
destruct H.
split. apply (mk_pureL_denote _ _ H).
apply IHpi. apply H0.
Qed.

Lemma mk_pureL_clause_denoteInv: forall pi P s,
  listd pn_atom_denote inter P pi s ->
  listd clause_denote inter P (map mk_pureL pi) s.
Proof.
intros pi.
induction pi; intros; simpl in *. trivial.
destruct H.
split. apply (mk_pureL_denoteInv _ _ H).
apply IHpi. apply H0.
Qed.

Lemma mk_pureL_clause_denoteEq:forall pi P,
  listd pn_atom_denote inter P pi =
  listd clause_denote inter P (map mk_pureL pi).
Proof.
intros.
apply extensionality. intros s.
apply prop_ext; split; intros.
 apply mk_pureL_clause_denoteInv. apply H.
  apply mk_pureL_clause_denote. apply H.
Qed.

Lemma listd_pure_atoms_heap_expand atms :
  listd pure_atom_denote inter emp atms |--
  listd pure_atom_denote inter TT atms.
Proof with simpl; auto.
induction atms... intros s [H1 H2]. split...
Qed.

Theorem cnf_correct1 : forall (e : entailment),
  entailment_denote e ->
  forall s, ~ list_denote clause_denote (@andp state) TT (cnf e) s.
Proof.
intros.
destruct e. unfold entailment_denote.
intro.
unfold cnf in H0.
destruct a. destruct a0 as [pi' sigma'].
remember (mk_pureR pi') as mkR. destruct mkR as[purepos pureneg].
repeat rewrite listd_app in H0.
repeat rewrite (@listd_separate _ _ state) in H0.
destruct H0.
destruct H1. simpl in H1.
destruct H1. simpl in H1.
destruct sigma' as [|s0' sigma'].
(* sigma' nil case *)
destruct sigma as [|s0 sigma].
destruct H2. simpl in H2.
assert (H5 : assertion_denote (Assertion pi' nil) s).
  apply H. unfold assertion_denote; simpl.
  rewrite (@listd_unfold_inter _ state); split; auto.
  rewrite mk_pureL_clause_denoteEq; auto. apply H1; auto.
rewrite clausify_succClassic with (purepos:=purepos)(pureneg:=pureneg) in H5; auto.
apply H5; simpl in H5; simpl; intro H6. apply H2.
apply listd_pure_atoms_heap_expand; auto.
destruct H2.
assert (H11 := H1 H3). clear H1.
clear H3 H4.
apply eq_sym in HeqmkR.
rewrite <- (clausify_succ _ _ _ nil s HeqmkR) in H2.
apply H2. apply H. clear H2 H.
simpl.
assert (Q: (andp (listd pn_atom_denote inter TT pi) (space_denote (s0::sigma)))%pred s).
  split. apply (mk_pureL_clause_denote _ _ _ H0).
  apply H11.
assert (XX: ((listd pn_atom_denote inter (space_denote (s0::sigma)) pi s) =
    (listd pn_atom_denote inter TT pi && space_denote (s0::sigma))%pred s)).
  assert (X:= (@listd_unfold_inter pn_atom state pn_atom_denote (space_denote (s0::sigma)) pi)).
  unfold pred in X. rewrite X.
  trivial.
simpl in XX. rewrite XX. apply Q.
(* sigma' cons case *)
  (* sigma nil case *)
destruct sigma as [|s0 sigma].
destruct H2.
assert (H11 := H1 H3). clear H1.
clear H3 H4.
apply eq_sym in HeqmkR.
rewrite <- (clausify_succ _ _ _ (s0'::sigma') s HeqmkR) in H2.
apply H2. apply H. clear H2 H.
simpl.
assert (Q: (andp (listd pn_atom_denote inter TT pi) (space_denote nil))%pred s).
  split. apply (mk_pureL_clause_denote _ _ _ H0).
  apply H11.
assert (XX: ((listd pn_atom_denote inter (space_denote nil) pi s) =
    (listd pn_atom_denote inter TT pi && space_denote nil)%pred s)).
  assert (X:= (@listd_unfold_inter pn_atom state pn_atom_denote (space_denote nil) pi)).
  unfold pred in X. rewrite X.
  trivial.
simpl in XX. rewrite XX. apply Q.
  (* sigma cons case *)
destruct H2.
assert (H11 := H1 H3). clear H1.
clear H3 H4.
apply eq_sym in HeqmkR.
rewrite <- (clausify_succ _ _ _ (s0'::sigma') s HeqmkR) in H2.
apply H2. apply H. clear H2 H.
simpl.
assert (Q: (andp (listd pn_atom_denote inter TT pi) (space_denote (s0::sigma)))%pred s).
  split. apply (mk_pureL_clause_denote _ _ _ H0).
  apply H11.
assert (XX: ((listd pn_atom_denote inter (space_denote (s0::sigma)) pi s) =
    (listd pn_atom_denote inter TT pi && space_denote (s0::sigma))%pred s)).
  assert (X:= (@listd_unfold_inter pn_atom state pn_atom_denote (space_denote (s0::sigma)) pi)).
  unfold pred in X. rewrite X.
  trivial.
simpl in XX; rewrite XX. apply Q.
Qed.

Theorem cnf_correct2 : forall (e : entailment),
  (forall s, ~ list_denote clause_denote (@andp state) TT (cnf e) s) ->
   entailment_denote e.
Proof.
intros.
destruct e; simpl.
intros s K. specialize (H s).
destruct (classic (assertion_denote a0 s)); auto.
contradict H.
unfold cnf.
destruct a. destruct a0 as [pi' sigma'].
remember (mk_pureR pi') as mkR. destruct mkR as[purepos' pureneg'].
repeat rewrite listd_app.
repeat rewrite (@listd_separate _ _ state).
simpl in H0.
assert (XL : ~ listd clause_denote inter (space_denote sigma') (map mk_pureL pi') s).
  rewrite (mk_pureL_clause_denoteEq) in H0. assumption.
apply eq_sym in HeqmkR.
rewrite (mk_pureR_denote _ _ _ _ _ HeqmkR) in H0.
simpl in *.
repeat rewrite andp_TT.
rewrite (mk_pureL_clause_denoteEq) in K.
rewrite (@listd_prop clause state clause_denote) in K.
destruct K as [K1 K2].
split. assumption.
split. rewrite clausify_space in K2. apply K2.

destruct sigma. destruct sigma'.
  simpl. split; auto. intros HH.
assert (H1: listd pure_atom_denote inter emp purepos' s).
  simpl in K2. rewrite (@listd_unfold_inter _ state). split; auto.
apply Decidable.not_and in H0.
destruct H0. destruct (H H1).
   apply Decidable.not_not in H. apply H.
   apply classic.
apply classic.
remember (s0 :: sigma') as sigma''.
simpl. split; auto. intros HH.
apply Decidable.not_and in H0.
destruct H0. destruct (H HH).
   apply Decidable.not_not in H. apply H.
   apply classic.
apply classic.
apply Decidable.not_and in H0.
destruct H0. simpl. split; auto. intros HH. destruct (H HH).
   apply Decidable.not_not in H.
   split; simpl; auto.
   apply classic.
apply classic.
Qed.

Theorem cnf_correct : forall (e : entailment),
  entailment_denote e =
  forall s, ~ list_denote clause_denote (@andp state) TT (cnf e) s.
Proof.
intros.
apply prop_ext.
split; intros.
  eapply cnf_correct1. apply H.
 eapply cnf_correct2. apply H.
Qed.

End Clausify_Sound.