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.


Require Import Verdi.

Require Import FunctionalExtensionality.

Require Import SeqNum.

Section SeqNumCorrect.
  Context {orig_base_params : BaseParams}.
  Context {orig_multi_params : MultiParams orig_base_params}.

  Lemma processPackets_correct :
    forall n l n' l',
      processPackets n l = (n', l') ->
      forall p,
        In p l' ->
        n' > (tmNum (snd p)).
  Proof using.
    induction l; intros; simpl in *.
    - find_inversion. simpl in *. intuition.
    - break_match. find_inversion. simpl in *. intuition.
      + subst. simpl. omega.
      + eauto using le_gt_trans, le_plus_l.
  Qed.

  Lemma processPackets_num_monotonic :
    forall n l n' l',
      processPackets n l = (n', l') ->
      n' >= n.
  Proof using.
    induction l; intros; simpl in *.
    - intros. find_inversion. intuition.
    - break_match. find_inversion.
      find_insterU. find_insterU. conclude_using eauto.
      omega.
  Qed.

  Lemma processPackets_ge_start :
    forall n l n' l',
      processPackets n l = (n', l') ->
      forall p,
        In p l' ->
        n <= (tmNum (snd p)).
  Proof using.
    induction l; intros; simpl in *.
    - invcs H. intuition.
    - break_match.
      invcs H. intuition.
      + subst. simpl.
        apply processPackets_num_monotonic in Heqp0. intuition.
      + specialize (IHl n0 l0). apply IHl; auto.
  Qed.

  Lemma processPackets_nums_unique :
    forall n l n' l' p p',
      processPackets n l = (n', l') ->
      In p l' ->
      In p' l' ->
      p <> p' ->
      (tmNum (snd p)) <> (tmNum (snd p')).
  Proof using.
    induction l; intros; simpl in *.
    - invcs H. intuition.
    - break_match. invcs H.
      intuition.
      + subst. intuition.
      + subst. simpl in *.
        apply processPackets_correct with (p := p') in Heqp0; intuition.
      + subst. simpl in *.
        apply processPackets_correct with (p := p) in Heqp0; intuition.
      + apply IHl with n0 l0 p p'; intuition.
  Qed.

  Lemma processPackets_seq_eq :
    forall n l n' l' x y,
      processPackets n l = (n', l') ->
      In x l' ->
      In y l' ->
      tmNum (snd x) = tmNum (snd y) ->
      x = y.
  Proof using.
    induction l; intros; simpl in *.
    - find_inversion. simpl in *. intuition.
    - break_match. find_inversion. simpl in *.
      intuition; subst; simpl in *; eauto;
      subst; eapply processPackets_correct in Heqp; eauto; omega.
  Qed.

  Lemma processPackets_NoDup : forall n l n' l',
                                  processPackets n l = (n', l') ->
                                  NoDup l'.
  Proof using.
    induction l; intros.
    - simpl in *. find_inversion. constructor.
    - simpl in *. break_match. find_inversion.
      specialize (IHl n0 l0). concludes.
      constructor; auto.
      intro.

      eapply processPackets_correct in H; eauto.
      simpl in *. omega.
  Qed.

  Lemma processPackets_preserves_messages :
    forall n l,
      map (fun p => (fst p, tmMsg (snd p))) (snd (processPackets n l)) = l.
  Proof using.
    induction l.
    - auto.
    - simpl. break_match. simpl in *. rewrite IHl. destruct a. auto.
  Qed.

  Definition orig_packet := @packet _ orig_multi_params.
  Definition orig_network := @network _ orig_multi_params.
  Definition seq_num_packet := @packet _ multi_params.
  Definition seq_num_network := @network _ multi_params.

  Definition revertPacket (p : seq_num_packet) : orig_packet :=
    @mkPacket _ orig_multi_params (pSrc p) (pDst p) (tmMsg (pBody p)).

  Definition pkt_eq_dec (x y : seq_num_packet) : {x = y} + {x <> y}.
    repeat decide equality.
    apply msg_eq_dec.
    apply name_eq_dec.
    apply name_eq_dec.
  Defined.

  Definition revertNetwork (net: seq_num_network) : orig_network :=
    mkNetwork
      (map revertPacket
           (filter (fun (p : seq_num_packet) =>
                      if member (tmNum (pBody p)) (tdSeen (nwState net (pDst p))
                                                          (pSrc p))
                      then false else true)
                   (dedup pkt_eq_dec
                          (nwPackets net))))
      (fun h => (tdData (nwState net h))).

  Lemma network_eq (net net' : orig_network) :
    nwState net = nwState net' ->
    nwPackets net = nwPackets net' ->
    net = net'.
  Proof using.
    intros; destruct net, net'.
    simpl in *.
    subst.
    auto.
  Qed.

  Definition sequence_sane (net : seq_num_network) :=
    (forall p,
       In p (nwPackets net) ->
       tmNum (pBody p) < (tdNum ((nwState net) (pSrc p)))).

  Lemma reachable_sane :
    true_in_reachable step_d step_m_init sequence_sane.
  Proof using.
    apply inductive_invariant_true_in_reachable. unfold inductive_invariant, inductive.
    unfold sequence_sane. simpl in *. intuition.
    match goal with
      | [ H : step_d _ _ _ |- _ ] =>
        invcs H
    end; try find_inversion.
    - (* deliver case *)
      unfold seq_num_net_handlers in *.
      simpl in *.
      do_in_app. intuition.
      + (* p is a new packet *)
        do_in_map.
        subst; simpl in *.
        repeat break_match; try find_inversion; simpl in *; intuition.
        eapply processPackets_correct; eauto.
      + (* p is an old packet *)
        simpl in *.
        repeat find_rewrite.
        do_in_app.
        repeat break_match; try find_inversion.
        * rewrite <- e. intuition.
        * apply processPackets_num_monotonic in Heqp0.
          apply lt_le_trans with (m := (tdNum (nwState a (pDst p0)))); auto.
          rewrite <- e. intuition.
        * intuition.
        * intuition.
    - unfold seq_num_input_handlers in *. simpl in *. do_in_app. intuition.
      + do_in_map. subst; simpl in *.
        repeat break_match; try find_inversion; simpl in *; intuition.
        eapply processPackets_correct; eauto.
      + simpl in *.
        repeat break_match; try find_inversion;
        simpl in *; find_apply_lem_hyp processPackets_num_monotonic;
        find_apply_hyp_hyp; try omega.
    - in_crush; eauto with *.
  Qed.

  Definition sequence_seen (net : seq_num_network) :=
    forall h h' n,
      In n (tdSeen (nwState net h') h) ->
      n < (tdNum (nwState net h)).

  Lemma reachable_seen :
    true_in_reachable step_d step_m_init sequence_seen.
  Proof using.
    apply true_in_reachable_reqs;
    unfold sequence_seen; simpl in *; intuition.
    find_apply_lem_hyp reachable_sane.
    unfold sequence_sane in *.
    match goal with H : step_d _ _ _ |- _ => invcs H end.
    - (* step case *)
      unfold seq_num_net_handlers in *.
      repeat (break_match; try find_inversion; simpl in *; eauto);
      match goal with
        | [ H : processPackets _ _ = _ |- _ ] =>
          apply processPackets_num_monotonic in H
      end;
      try break_if; simpl in *; intuition; subst; eauto;
      repeat find_rewrite; (eapply lt_le_trans; [|eauto]; eauto).
    - unfold seq_num_input_handlers in *.
      repeat (break_match; try find_inversion; simpl in *; eauto);
      match goal with
        | [ H : processPackets _ _ = _ |- _ ] =>
          apply processPackets_num_monotonic in H
      end;
      try break_if; simpl in *; intuition; subst; eauto;
      repeat find_rewrite;
      (eapply lt_le_trans; [|eauto]; eauto).
    - eauto.
  Qed.

  Definition sequence_equality (net : seq_num_network) :=
    forall p p',
      In p (nwPackets net) ->
      In p' (nwPackets net) ->
      (tmNum (pBody p)) = (tmNum (pBody p')) ->
      pSrc p = pSrc p' ->
      p = p'.

  Theorem reachable_equality :
    true_in_reachable step_d step_m_init sequence_equality.
  Proof using.
    apply true_in_reachable_reqs;
    unfold sequence_equality; simpl in *; intuition.
    match goal with
        H : reachable _ _ _ |- _ =>
        apply reachable_sane in H
    end.
    unfold sequence_sane, sequence_equality in *.
    intros.
    match goal with H : step_d _ _ _ |- _ => invcs H end; simpl in *; find_inversion.
    - unfold seq_num_net_handlers in *.
      repeat do_in_app.
      repeat find_rewrite.
      repeat break_match; find_inversion; simpl in *; intuition;
      repeat do_in_map; subst; simpl in *.
      + repeat do_in_app. intuition.
      + find_inversion.
        match goal with
          | x : prod _ _, x' : prod _ _ |- _ =>
            replace x with x' by (eapply processPackets_seq_eq; eauto)
        end; auto.
      + match goal with H : processPackets _ _ = _ |- _ =>
                        eapply processPackets_ge_start in H
        end; eauto.
        match goal with
            _ : In ?p _, H : forall _ : packet, In _ _ -> _ |- _ =>
            specialize (H p); forward H; [in_crush|]; [concludes]
        end. simpl in *. repeat find_rewrite. omega.
      + find_inversion.
        match goal with H : processPackets _ _ = _ |- _ =>
                        eapply processPackets_ge_start in H
        end; eauto.
        match goal with
            _ : In ?p _, H : forall _ : packet, In _ _ -> _ |- _ =>
            specialize (H p); forward H; [in_crush|]; [concludes]
        end. simpl in *. repeat find_rewrite. omega.
      + match goal with
            H : forall _ _ : packet, In _ _ -> _ |- ?p = ?p' =>
            specialize (H p p'); repeat (forward H; [in_crush|]; concludes)
        end; auto.
    - unfold seq_num_input_handlers in *.
      repeat do_in_app.
      repeat break_match; find_inversion; simpl in *; intuition;
      repeat do_in_map; subst; simpl in *.
      + find_inversion.
        match goal with
          | x : prod _ _, x' : prod _ _ |- _ =>
            replace x with x' by (eapply processPackets_seq_eq; eauto)
        end; auto.
      + match goal with H : processPackets _ _ = _ |- _ =>
                        eapply processPackets_ge_start in H
        end; eauto.
        match goal with
            _ : In ?p _, H : forall _ : packet, In _ _ -> _ |- _ =>
            specialize (H p); forward H; [in_crush|]; [concludes]
        end. simpl in *. repeat find_rewrite. omega.
      + find_inversion.
        match goal with H : processPackets _ _ = _ |- _ =>
                        eapply processPackets_ge_start in H
        end; eauto.
        match goal with
            _ : In ?p _, H : forall _ : packet, In _ _ -> _ |- _ =>
            specialize (H p); forward H; [in_crush|]; [concludes]
        end. simpl in *. repeat find_rewrite. omega.
    - repeat find_rewrite. in_crush.
  Qed.

  Lemma revertNetwork_In :
    forall net (p : seq_num_packet),
      In p (nwPackets net) ->
      ~ In (tmNum (pBody p)) (tdSeen (nwState net (pDst p)) (pSrc p)) ->
      In (revertPacket p) (nwPackets (revertNetwork net)).
  Proof using.
    intros. unfold revertNetwork. simpl in *.
    in_crush.
    apply filter_In. intuition.
    - apply dedup_In. auto.
    - break_if; intuition.
  Qed.

  Lemma revertNetwork_packets :
    forall xs net (p : seq_num_packet) ys,
      ~ In (tmNum (pBody p)) (tdSeen (nwState net (pDst p)) (pSrc p)) ->
      nwPackets net = xs ++ p :: ys ->
      exists xs' ys',
        nwPackets (revertNetwork net) =
        xs' ++ (revertPacket p) :: ys'.
  Proof using.
    intros.
    apply in_split. apply revertNetwork_In; repeat find_rewrite; in_crush.
  Qed.

  Lemma processPackets_dedup :
    forall processed (rest : list seq_num_packet) n' l h net,
      (forall p, In p rest -> In p (nwPackets net)) ->
      sequence_sane net ->
      processPackets (tdNum (nwState net h)) l = (n', processed) ->
      dedup pkt_eq_dec ((@send_packets _ multi_params h processed) ++ rest)
      = (send_packets h processed) ++ (dedup pkt_eq_dec rest).
  Proof using.
    intros. simpl in *.
    rewrite dedup_app; f_equal.
    - apply dedup_NoDup_id.
      apply NoDup_map_injective; eauto using processPackets_NoDup.
      intros. find_inversion.
      rewrite surjective_pairing at 1.
      rewrite surjective_pairing.
      unfold msg in *. simpl in *.
      repeat find_rewrite. auto.
    - intuition.
      subst.
      find_apply_lem_hyp in_map_iff. break_exists. intuition.
      find_eapply_lem_hyp processPackets_ge_start; eauto.
      match goal with
        | _ : In ?p _, net : network |- _ =>
          assert (In p (nwPackets net)) by eauto
      end.
      unfold sequence_sane in *.
      find_apply_hyp_hyp. simpl in *. subst. simpl in *. omega.
  Qed.

  Lemma revertNetwork_deliver_step :
    forall (st : seq_num_network) p xs ys (d : @data orig_base_params) l l' n,
      sequence_sane st ->
      sequence_seen st ->
      sequence_equality st ->
      nwPackets st = xs ++ p :: ys ->
      ~ In (tmNum (pBody p)) (tdSeen (nwState st (pDst p)) (pSrc p)) ->
      processPackets (tdNum (nwState st (pDst p))) l = (n, l') ->
      exists xs' ys',
        nwPackets (revertNetwork st) = xs' ++ revertPacket p :: ys' /\
        revertNetwork
          (@mkNetwork _ multi_params
                      (map
                         (fun m : name * seq_num_msg =>
                            {| pSrc := pDst p; pDst := fst m; pBody := snd m |})
                         l' ++ xs ++ ys)
                      (update (nwState st) (pDst p)
                              (@mkseq_num_data _ orig_multi_params
                                               n
                                               (fun nm : name =>
                                                  if name_eq_dec nm (pSrc p)
                                                  then
                                                    tmNum (pBody p)
                                                          :: tdSeen (nwState st (pDst p)) (pSrc p)
                                                  else tdSeen (nwState st (pDst p)) nm)
                                               d)))
        = {|
          nwPackets := (@send_packets _ orig_multi_params (pDst p) l) ++ xs' ++ ys';
          nwState := update (nwState (revertNetwork st)) (pDst p) d
        |}.
  Proof using.
    intros.
    simpl in *.
    unfold revertNetwork.
    simpl in *.
    repeat find_rewrite.
    match goal with
        [ |- context [ dedup ?eq (map ?f ?l ++ ?xs ++ ?ys) ] ] =>
        assert (dedup eq (map f l ++ xs ++ ys) = (map f l) ++ (dedup eq (xs ++ ys)))
          by (find_eapply_lem_hyp processPackets_dedup;
              eauto; repeat find_rewrite; in_crush)
    end.
    find_rewrite.
    rewrite filter_app.
    rewrite map_app.
    assert (In p (nwPackets st)) by (find_rewrite; in_crush).
    match goal with
      | H : In _ _ |- _ =>
        apply dedup_In with (A_eq_dec := pkt_eq_dec) in H
    end.
    find_apply_lem_hyp in_split. break_exists. repeat find_rewrite.
    find_copy_apply_lem_hyp dedup_partition.
    unfold seq_num_packet in *.
    repeat find_rewrite.
    assert (NoDup (x ++ p :: x0)) by (repeat find_reverse_rewrite; apply NoDup_dedup).
    match goal with
      | [ |- context [ filter ?f (?xs ++ ?p :: ?ys) ] ] =>
        assert (In p (filter f (xs ++ p :: ys)))
          by (apply filter_In; repeat break_if; intuition)
    end. find_apply_lem_hyp in_split. break_exists.
    repeat find_rewrite.
    exists (map revertPacket x1), (map revertPacket x2).
    intuition; map_crush; auto.
    simpl in *.
    f_equal. f_equal.
    - rewrite filter_true_id.
      + match goal with
          | _ : processPackets ?n ?l = _ |- _ =>
            rewrite <- (processPackets_preserves_messages n l)
        end.
        find_rewrite. simpl in *.
        unfold revertPacket.
        repeat rewrite map_map. auto.
      + intros.
        in_crush.
        find_eapply_lem_hyp processPackets_ge_start; [|eauto].
        match goal with
            p : packet |- _ =>
            assert (tmNum (pBody p) < tdNum (nwState st (pSrc p))) by
                (eapply_prop sequence_sane; find_rewrite; in_crush)
        end.
        repeat (break_if; simpl in *; repeat find_rewrite; intuition);
          unfold sequence_seen in *; find_apply_hyp_hyp; omega.
    - rewrite <- filter_except_one
      with (f := (fun p0 : seq_num_packet =>
                    if member (tmNum (pBody p0)) (tdSeen (nwState st (pDst p0)) (pSrc p0))
                    then false
                    else true)) (x := p) (A_eq_dec := pkt_eq_dec).
      + unfold seq_num_packet in *. repeat find_rewrite.
        rewrite filter_app.
        find_apply_lem_hyp filter_partition; intuition.
        repeat find_rewrite. eauto using map_app.
      + intros. repeat (break_if; simpl in *; repeat find_rewrite; intuition).
        exfalso.
        match goal with H : _ = _ -> False |- _ => apply H end.
        eapply_prop sequence_equality; repeat find_rewrite; in_crush.
        find_apply_lem_hyp in_dedup_was_in. in_crush.
      + repeat (break_if; simpl in *; intuition).
    - apply functional_extensionality. intros; repeat break_if; simpl in *; intuition.
  Qed.

  Theorem revertNetwork_input :
    forall (st : seq_num_network) h (d : @data orig_base_params) l l' n,
      sequence_sane st ->
      sequence_seen st ->
      sequence_equality st ->
      processPackets (tdNum (nwState st h)) l = (n, l') ->
      revertNetwork
        (@mkNetwork _ multi_params
                    (send_packets h l' ++ nwPackets st)
                    (update (nwState st) h
                            (@mkseq_num_data _ orig_multi_params
                                             n
                                             (tdSeen (nwState st h))
                                             d)))
        = {|
          nwPackets := (@send_packets _ orig_multi_params h l) ++ (nwPackets (revertNetwork st));
          nwState := update (nwState (revertNetwork st)) h d
        |}.
  Proof using.
    intros.
    unfold revertNetwork.
    simpl in *.
    match goal with
        [ |- context [ dedup ?eq (map ?f ?l ++ ?l') ] ] =>
        assert (dedup eq (map f l ++ l') = (map f l) ++ (dedup eq l'))
          by (find_eapply_lem_hyp processPackets_dedup;
              eauto; repeat find_rewrite; in_crush)
    end.
    find_rewrite.
    rewrite filter_app. rewrite map_app. f_equal. f_equal.
    - rewrite filter_true_id.
      + match goal with
          | _ : processPackets ?n ?l = _ |- _ =>
            rewrite <- (processPackets_preserves_messages n l)
        end.
        find_rewrite. simpl in *.
        unfold revertPacket.
        repeat rewrite map_map. auto.
      + intros.
        in_crush.
        find_eapply_lem_hyp processPackets_ge_start; [|eauto].
        repeat (break_if; simpl in *; repeat find_rewrite; intuition);
          unfold sequence_seen in *; find_apply_hyp_hyp; omega.
    - f_equal. apply filter_fun_ext_eq.
      intros. repeat (break_if; simpl in *; repeat find_rewrite; intuition).
    - apply functional_extensionality. intros; repeat break_if; simpl in *; intuition.
  Qed.

  (* We need this for dedup_eliminates_duplicates *)
  Arguments dedup _ _ _ : simpl nomatch.

  Lemma reachable_revert_step :
    forall st st' out,
      reachable step_d step_m_init st ->
      step_d st st' out ->
      (exists out, step_m (revertNetwork st) (revertNetwork st') out)
      \/ revertNetwork st = revertNetwork st'.
  Proof using.
    intros.
    find_copy_apply_lem_hyp reachable_sane.
    find_copy_apply_lem_hyp reachable_seen.
    find_copy_apply_lem_hyp reachable_equality.
    break_exists.
    match goal with H : step_d _ _ _ |- _ => invcs H end.
    - unfold seq_num_net_handlers in *. break_if.
      + right. find_inversion. simpl in *.
        unfold revertNetwork. simpl in *. intuition.
        f_equal.
        * f_equal. find_rewrite. symmetry.
          match goal with
            | |- filter ?f _ = filter ?g _ =>
              assert (f = g) by
                  (apply functional_extensionality;
                   intros; repeat break_if; repeat find_rewrite; intuition)
          end.
          find_rewrite.
          apply filter_dedup.
          break_if; intuition.
        * apply functional_extensionality.
          intros. break_if; subst; intuition.
      + left. repeat break_let. find_inversion.
        eexists.
        find_eapply_lem_hyp revertNetwork_deliver_step; eauto.
        break_exists.
        intuition.
        econstructor; eauto.
    - left. unfold seq_num_input_handlers in *. repeat break_let.
      find_inversion.
      eexists. find_eapply_lem_hyp revertNetwork_input; eauto.
      econstructor 2; simpl; eauto.
    - right.
      unfold revertNetwork.
      f_equal. f_equal. f_equal.
      simpl. find_rewrite. eauto using dedup_eliminates_duplicates.
  Qed.

  Theorem reachable_revert :
    true_in_reachable step_d step_m_init
                      (fun st =>
                         reachable step_m step_m_init (revertNetwork st)).
  Proof using.
    apply true_in_reachable_reqs.
    - unfold revertNetwork. simpl.
      unfold reachable. exists []. constructor.
    - intros.
      find_apply_lem_hyp reachable_revert_step; auto.
      intuition.
      + unfold reachable in *.
        break_exists.
        eexists.
        apply refl_trans_n1_1n_trace.
        econstructor; eauto using refl_trans_1n_n1_trace.
      + find_rewrite. auto.
  Qed.

  Theorem true_in_reachable_transform :
    forall P,
      true_in_reachable step_m step_m_init P ->
      true_in_reachable step_d step_m_init (fun net => P (revertNetwork net)).
  Proof using.
    intros. find_apply_lem_hyp true_in_reachable_elim. intuition.
    apply true_in_reachable_reqs; eauto.
    intros. find_copy_apply_lem_hyp reachable_revert.
    find_apply_lem_hyp reachable_revert_step; auto.
    intuition.
    - break_exists. eauto.
    - repeat find_rewrite. auto.
  Qed.

End SeqNumCorrect.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint double (double_arg0 : natural) : natural
           := match double_arg0 with
              | Zero => Zero
              | Succ n => Succ (Succ (double n))
              end.

Lemma lem: forall m n, Succ (plus m n) = plus m (Succ n).
Proof.
   induction m.
   - intros. simpl. rewrite IHm. reflexivity.
   - intros. reflexivity.
Qed.

Theorem theorem0 : forall (x : natural), eq (double x) (plus x x).
Proof.
   induction x.
   - simpl. f_equal. rewrite IHx. lfind. Admitted.


From Coq Require Import ZArith.
From mathcomp Require Import ssreflect ssrbool ssrnat seq.
From Common Require Import Var Bits.
From mQhasm Require Import bvDSL bvVerify Options zVerify.

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

Open Scope N_scope.
Open Scope bvdsl_scope.

(* This is an alternative implementation of fe25519_mul121666. *)

Definition fe25519_mul121666 : program :=

let         wsize :=   64%nat in

let            x0 :=   0 in
let            x1 :=   1 in
let            x2 :=   2 in
let            x3 :=   3 in
let            x4 :=   4 in

let            r0 :=  10 in
let            r1 :=  11 in
let            r2 :=  12 in
let            r3 :=  13 in
let            r4 :=  14 in

let           rax :=  20 in
let           rdx :=  21 in

[::
bvAssign rax (bvVar x0);
bvMulf rdx rax (bvVar rax) (bvConst (fromPosZ 121666%Z));
bvConcatShl rdx rax (bvVar rdx) (bvVar rax) (fromNat 13);
bvAssign r0 (bvVar rax);
bvAssign r1 (bvVar rdx);
      (*    *)
bvAssign rax (bvVar x1);
bvMulf rdx rax (bvVar rax) (bvConst (fromPosZ 121666));
bvConcatShl rdx rax (bvVar rdx) (bvVar rax) (fromNat 13);
bvAdd r1 (bvVar r1) (bvVar rax);
bvAssign r2 (bvVar rdx);
      (*    *)
bvAssign rax (bvVar x2);
bvMulf rdx rax (bvVar rax) (bvConst (fromPosZ 121666));
bvConcatShl rdx rax (bvVar rdx) (bvVar rax) (fromNat 13);
bvAdd r2 (bvVar r2) (bvVar rax);
bvAssign r3 (bvVar rdx);
      (*    *)
bvAssign rax (bvVar x3);
bvMulf rdx rax (bvVar rax) (bvConst (fromPosZ 121666));
bvConcatShl rdx rax (bvVar rdx) (bvVar rax) (fromNat 13);
bvAdd r3 (bvVar r3) (bvVar rax);
bvAssign r4 (bvVar rdx);
      (*    *)
bvAssign rax (bvVar x4);
bvMulf rdx rax (bvVar rax) (bvConst (fromPosZ 121666));
bvConcatShl rdx rax (bvVar rdx) (bvVar rax) (fromNat 13);
bvAdd r4 (bvVar r4) (bvVar rax);
bvMul rdx (bvVar rdx) (bvConst (fromPosZ 19%Z));
bvAdd r0 (bvVar r0) (bvVar rdx)
] .

Definition fe25519_mul121666_inputs : VS.t :=
let            x0 :=   0 in
let            x1 :=   1 in
let            x2 :=   2 in
let            x3 :=   3 in
let            x4 :=   4 in
VSLemmas.OP.P.of_list [:: x0; x1; x2; x3; x4].

Definition fe25519_mul121666_pre : bexp := bvTrue.

Definition radix51 := @limbs 51.

Definition fe25519_mul121666_post : bexp :=
let            x0 :=   0 in
let            x1 :=   1 in
let            x2 :=   2 in
let            x3 :=   3 in
let            x4 :=   4 in
let            r0 :=  10 in
let            r1 :=  11 in
let            r2 :=  12 in
let            r3 :=  13 in
let            r4 :=  14 in
let        n25519 := 57896044618658097711785492504343953926634992332820282019728792003956564819949%Z in
bvands2
  [::
     bveEqMod (
       (radix51 [::bvevar x0; bvevar x1; bvevar x2; bvevar x3; bvevar x4])
       *e
       (bveconst 121666%Z)
     )
     (radix51 [::bvevar r0; bvevar r1; bvevar r2; bvevar r3; bvevar r4])
     (bvconst n25519)
  ]
  [::
     (bvrvar r0) <=r (bvposz (2^52)%Z);
     (bvrvar r1) <=r (bvposz (2^52)%Z);
     (bvrvar r2) <=r (bvposz (2^52)%Z);
     (bvrvar r3) <=r (bvposz (2^52)%Z);
     (bvrvar r4) <=r (bvposz (2^52)%Z)
  ].

Definition fe25519_mul121666_spec :=
  {| spre := fe25519_mul121666_pre;
     sprog := fe25519_mul121666;
     spost := fe25519_mul121666_post |}.

Lemma valid_fe25519_mul121666 : valid_bvspec (fe25519_mul121666_inputs, fe25519_mul121666_spec).
Proof.
  time "valid_fe25519_mul121666" verify_bvspec.
Qed.

Close Scope bvdsl_scope.
Close Scope N_scope.