From Hammer Require Import Hammer.

Require Import Arith.
From Lambda Require Import Terms.
From Lambda Require Import Reduction.
From Lambda Require Import Redexes.
From Lambda Require Import Test.
From Lambda Require Import Substitution.
From Lambda Require Import Residuals.

Inductive compat : redexes -> redexes -> redexes -> Prop :=
| Compat_Var : forall n : nat, compat (Var n) (Var n) (Var n)
| Compat_Fun :
forall U V W : redexes, compat U V W -> compat (Fun U) (Fun V) (Fun W)
| Compat_Ap1 :
forall U1 V1 W1 : redexes,
compat U1 V1 W1 ->
forall U2 V2 W2 : redexes,
compat U2 V2 W2 ->
forall b : bool, compat (Ap false U1 U2) (Ap false V1 V2) (Ap b W1 W2)
| Compat_Ap2 :
forall U1 V1 W1 : redexes,
compat U1 V1 W1 ->
forall U2 V2 W2 : redexes,
compat U2 V2 W2 ->
forall b b' : bool,
compat (Ap true (Fun U1) U2) (Ap b (Fun V1) V2) (Ap b' (Fun W1) W2).

Lemma compat_intro :
forall U W WU : redexes,
residuals W U WU ->
forall (V WV : redexes) (R2 : residuals W V WV) (S : sub V U), compat U V W.
Proof. hammer_hook "Cube" "Cube.compat_intro".

simple induction 1; intros; generalize S; inversion_clear R2; intros;
inversion_clear S.
apply Compat_Var.
apply Compat_Fun.
inversion_clear S0; apply H1 with W1; auto.
inversion_clear S0; apply Compat_Ap1; auto.
apply H1 with W0; auto.
apply H3 with W3; auto.
inversion_clear S0.
inversion_clear S0; generalize H4; inversion_clear H8.
intro H11; inversion_clear H11; apply Compat_Ap2; auto.
apply H1 with W4; auto.
apply H3 with W3; auto.
generalize H4; inversion_clear S0.
inversion_clear H8.
intro H11; inversion_clear H11; apply Compat_Ap2; auto.
apply H1 with W4; auto.
apply H3 with W3; auto.
inversion_clear S0; apply Compat_Ap2; inversion_clear H8; auto.
apply H1 with W0; auto.
apply H3 with W3; auto.
inversion_clear S0; apply Compat_Ap2; inversion_clear H8; auto.
apply H1 with W0; auto.
apply H3 with W3; auto.
Qed.

Lemma prism0 :
forall U V W : redexes,
compat U V W ->
forall (UV : redexes) (R1 : residuals U V UV) (WU WV : redexes)
(R2 : residuals W U WU) (R3 : residuals W V WV),
residuals WV UV WU.
Proof. hammer_hook "Cube" "Cube.prism0".
simple induction 1.
intros; inversion_clear R1; inversion_clear R2; inversion_clear R3; auto.
intros; inversion_clear R1; inversion_clear R2; inversion_clear R3; auto.
intros; inversion_clear R1; inversion_clear R2; inversion_clear R3; auto.
simple induction b; intros; inversion_clear R1; inversion_clear R2;
inversion_clear R3; auto.
apply commutation; auto.
inversion_clear H4; inversion_clear H8; auto.
Qed.

Lemma prism1 :
forall U V W : redexes,
sub V U ->
forall UV : redexes,
residuals U V UV ->
forall WV : redexes,
residuals W V WV ->
forall WU : redexes, residuals W U WU -> residuals WV UV WU.
Proof. hammer_hook "Cube" "Cube.prism1".
intros; apply prism0 with U V W; auto.
apply compat_intro with WU WV; trivial.
Qed.

Lemma prism2 :
forall U V W : redexes,
sub V U ->
regular U ->
forall UV : redexes,
residuals U V UV ->
forall WV : redexes,
residuals W V WV ->
forall WU : redexes, residuals WV UV WU -> residuals W U WU.
Proof. hammer_hook "Cube" "Cube.prism2".
intros.
elim (residuals_intro W U); trivial.
intros WU' R; elim (residuals_function WV UV WU) with WU'; trivial.
apply prism1 with U V W; trivial.
apply comp_trans with V.
apply residuals_comp with WV; trivial.
apply comp_sym; apply residuals_comp with UV; trivial.
Qed.

Theorem prism :
forall U V W : redexes,
sub V U ->
forall UV : redexes,
residuals U V UV ->
forall WV : redexes,
residuals W V WV ->
forall WU : redexes, residuals W U WU <-> regular U /\ residuals WV UV WU.
Proof. hammer_hook "Cube" "Cube.prism".
intros; unfold iff in |- *; split.
intro; split.
apply residuals_regular with W WU; trivial.
apply prism1 with U V W; trivial.
simple induction 1; intros; apply prism2 with V UV WV; trivial.
Qed.

Lemma cube :
forall U V UV VU : redexes,
residuals U V UV ->
residuals V U VU ->
forall W WU WV WUV : redexes,
residuals W U WU ->
residuals WU VU WUV -> residuals W V WV -> residuals WV UV WUV.
Proof. hammer_hook "Cube" "Cube.cube".
intros.
cut (comp U V).
2: apply residuals_comp with UV; trivial.
intro C; elim (union_defined U V C); intros T UVT.
apply prism1 with T V W; trivial.
apply union_r with U; trivial.
apply preservation with U; trivial.
apply prism2 with U VU WU; trivial.
apply union_l with V; trivial.
apply union_preserve_regular with U V; trivial.
apply residuals_regular with V VU; trivial.
apply residuals_regular with U UV; trivial.
apply preservation with V; trivial.
apply union_sym; trivial.
Qed.

Lemma paving :
forall U V W WU WV : redexes,
residuals W U WU ->
residuals W V WV ->
exists UV : redexes,
(exists VU : redexes,
(exists WUV : redexes, residuals WU VU WUV /\ residuals WV UV WUV)).
Proof. hammer_hook "Cube" "Cube.paving".
intros; elim (residuals_intro U V).
intros UV R1; exists UV.
elim (residuals_intro V U).
intros VU R2; exists VU.
elim (residuals_intro WU VU).
intros WUV R3; exists WUV.
split; trivial.
apply cube with U V VU W WU; trivial.
apply mutual_residuals_comp with U W V; trivial.
apply residuals_preserve_regular with V U; trivial.
apply residuals_regular with U UV; trivial.
apply comp_sym; apply residuals_comp with UV; trivial.
apply residuals_regular with W WU; trivial.
apply comp_trans with W.
apply comp_sym; apply residuals_comp with WU; trivial.
apply residuals_comp with WV; trivial.
apply residuals_regular with W WV; trivial.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export Relations.

Set Implicit Arguments.
Unset Strict Implicit.

(* evite le clash d'univers entre le setoide des foncteur et SET *)

(***  SETOID  ***)

Structure > Setoid'' : Type :=
  {Carrier'' :> Type;
   Equal'' : Relation Carrier'';
   Prf_equiv'' :> Equivalence Equal''}.

Infix "=_S''" := Equal'' (at level 70).

(*** rewrite rules ***)

Lemma Refl'' : forall (S : Setoid'') (x : S), x =_S'' x.
Proof.
intro S; exact (Prf_refl S).
Qed.

Lemma Sym'' : forall (S : Setoid'') (x y : S), x =_S'' y -> y =_S'' x.
Proof.
intro S; exact (Prf_sym S).
Qed.

Lemma Trans'' :
 forall (S : Setoid'') (x y z : S), x =_S'' y -> y =_S'' z -> x =_S'' z.
Proof.
intro S; exact (Prf_trans S).
Qed.

(* *)

(***  MAP  ***)

Section maps''.

Variable A B : Setoid''.

Definition Map_law'' (f : A -> B) :=
  forall x y : A, x =_S'' y -> f x =_S'' f y.

Structure > Map'' : Type :=  {Ap'' :> A -> B; Pres'' :> Map_law'' Ap''}.

(*** rewrite rule ***)

Lemma Pres1'' : forall (m : Map'') (x y : A), x =_S'' y -> m x =_S'' m y.
Proof.
exact Pres''.
Qed.

(* *)

Definition Ext'' (f g : Map'') := forall x : A, f x =_S'' g x.

Lemma Ext_equiv'' : Equivalence Ext''.
Proof.
intros; apply Build_Equivalence.
unfold Reflexive in |- *; unfold Ext'' in |- *; intros f x.
apply Refl''.
apply Build_Partial_equivalence.
unfold Transitive in |- *; unfold Ext'' in |- *; intros f g h e1 e2 x.
(* *) apply Trans'' with (g x).
apply (e1 x).
apply (e2 x).
unfold Symmetric in |- *; unfold Ext'' in |- *; intros f g e x.
apply Sym''; trivial.
Qed.

Canonical Structure Map_setoid'' : Setoid'' := Ext_equiv''.

End maps''.

(*** MAP2 ***)

Section fun2_to_map2''.

Variable A B C : Setoid''.

Definition Map2'' := Map'' A (Map_setoid'' B C).

Variable f : A -> B -> C.

Definition Map2_congl_law'' :=
  forall (b1 b2 : B) (a : A), b1 =_S'' b2 -> f a b1 =_S'' f a b2.

Definition Map2_congr_law'' :=
  forall (a1 a2 : A) (b : B), a1 =_S'' a2 -> f a1 b =_S'' f a2 b.

Definition Map2_cong_law'' :=
  forall (a1 a2 : A) (b1 b2 : B),
  a1 =_S'' a2 -> b1 =_S'' b2 -> f a1 b1 =_S'' f a2 b2.

Hypothesis pgcl : Map2_congl_law''.
Hypothesis pgcr : Map2_congr_law''.

Lemma Map2_map_law1'' : forall a : A, Map_law'' (f a).
Proof.
intro a; unfold Map_law'' in |- *.
intros b1 b2 H; apply (pgcl a H).
Qed.

Canonical Structure Map2_map1'' (a : A) := Build_Map'' (Map2_map_law1'' a).

Lemma Map2_map_law2'' : Map_law'' Map2_map1''.
Proof.
unfold Map_law'', Map2_map1'' in |- *.
intros a1 a2 H; simpl in |- *; unfold Ext'' in |- *; intro b; simpl in |- *.
apply pgcr; trivial.
Qed.

Definition Build_Map2'' : Map2'' := Build_Map'' Map2_map_law2''.

End fun2_to_map2''.

Section prop_map2''.

Variables (A B C : Setoid'') (f : Map2'' A B C).

Definition Ap2'' (a : A) (b : B) := f a b.

Lemma Prf_map2_congl'' : Map2_congl_law'' Ap2''.
Proof.
unfold Map2_congl_law'' in |- *; intros b1 b2 a H.
unfold Ap2'' in |- *; apply (Pres1'' (f a)); trivial.
Qed.

Lemma Prf_map2_congr'' : Map2_congr_law'' Ap2''.
Proof.
unfold Map2_congr_law'' in |- *; intros a1 a2 b H.
apply (Pres1'' f H b).
Qed.

Lemma Prf_map2_cong'' : Map2_cong_law'' Ap2''.
Proof.
unfold Map2_cong_law'' in |- *; intros a1 a2 b1 b2 H1 H2.
(* *) apply Trans'' with (Ap2'' a2 b1).
apply (Prf_map2_congr'' b1 H1).
apply (Prf_map2_congl'' a2 H2).
Qed.

End prop_map2''.

Coercion Ap2'' : Map2'' >-> Funclass.

Identity Coercion Map2''_Map'' : Map2'' >-> Map''.


(** This files gives an implementation of finite sets using finite maps with
elements of the unit type. Since maps enjoy extensional equality, the
constructed finite sets do so as well. *)
From stdpp Require Export countable fin_map_dom.
From stdpp Require Import options.

(* FIXME: This file needs a 'Proof Using' hint, but they need to be set
locally (or things moved out of sections) as no default works well enough. *)
Unset Default Proof Using.

Record mapset (M : Type → Type) : Type :=
  Mapset { mapset_car: M (unit : Type) }.
Arguments Mapset {_} _ : assert.
Arguments mapset_car {_} _ : assert.

Section mapset.
Context `{FinMap K M}.

Global Instance mapset_elem_of: ElemOf K (mapset M) := λ x X,
  mapset_car X !! x = Some ().
Global Instance mapset_empty: Empty (mapset M) := Mapset ∅.
Global Instance mapset_singleton: Singleton K (mapset M) := λ x,
  Mapset {[ x := () ]}.
Global Instance mapset_union: Union (mapset M) := λ X1 X2,
  let (m1) := X1 in let (m2) := X2 in Mapset (m1 ∪ m2).
Global Instance mapset_intersection: Intersection (mapset M) := λ X1 X2,
  let (m1) := X1 in let (m2) := X2 in Mapset (m1 ∩ m2).
Global Instance mapset_difference: Difference (mapset M) := λ X1 X2,
  let (m1) := X1 in let (m2) := X2 in Mapset (m1 ∖ m2).
Global Instance mapset_elements: Elements K (mapset M) := λ X,
  let (m) := X in (map_to_list m).*1.

Lemma mapset_eq (X1 X2 : mapset M) : X1 = X2 ↔ ∀ x, x ∈ X1 ↔ x ∈ X2.
Proof.
  split; [by intros ->|].
  destruct X1 as [m1], X2 as [m2]. simpl. intros E.
  f_equal. apply map_eq. intros i. apply option_eq. intros []. by apply E.
Qed.

Instance mapset_set: Set_ K (mapset M).
Proof.
  split; [split | | ].
  - unfold empty, elem_of, mapset_empty, mapset_elem_of.
    simpl. intros. by simpl_map.
  - unfold singleton, elem_of, mapset_singleton, mapset_elem_of.
    simpl. by split; intros; simplify_map_eq.
  - unfold union, elem_of, mapset_union, mapset_elem_of.
    intros [m1] [m2] x. simpl. rewrite lookup_union_Some_raw.
    destruct (m1 !! x) as [[]|]; tauto.
  - unfold intersection, elem_of, mapset_intersection, mapset_elem_of.
    intros [m1] [m2] x. simpl. rewrite lookup_intersection_Some.
    assert (is_Some (m2 !! x) ↔ m2 !! x = Some ()).
    { split; eauto. by intros [[] ?]. }
    naive_solver.
  - unfold difference, elem_of, mapset_difference, mapset_elem_of.
    intros [m1] [m2] x. simpl. rewrite lookup_difference_Some.
    destruct (m2 !! x) as [[]|]; intuition congruence.
Qed.
Global Instance mapset_leibniz : LeibnizEquiv (mapset M).
Proof. intros ??. apply mapset_eq. Qed.
Global Instance mapset_fin_set : FinSet K (mapset M).
Proof.
  split.
  - apply _.
  - unfold elements, elem_of at 2, mapset_elements, mapset_elem_of.
    intros [m] x. simpl. rewrite elem_of_list_fmap. split.
    + intros ([y []] &?& Hy). subst. by rewrite <-elem_of_map_to_list.
    + intros. exists (x, ()). by rewrite elem_of_map_to_list.
  - unfold elements, mapset_elements. intros [m]. simpl.
    apply NoDup_fst_map_to_list.
Qed.

Section deciders.
  Context `{EqDecision (M unit)}.
  Global Instance mapset_eq_dec : EqDecision (mapset M) | 1.
  Proof.
   refine (λ X1 X2,
    match X1, X2 with Mapset m1, Mapset m2 => cast_if (decide (m1 = m2)) end);
    abstract congruence.
  Defined.
  Global Program Instance mapset_countable `{Countable (M ())} : Countable (mapset M) :=
    inj_countable mapset_car (Some ∘ Mapset) _.
  Next Obligation. by intros ? ? []. Qed.
  Global Instance mapset_equiv_dec : RelDecision (≡@{mapset M}) | 1.
  Proof. refine (λ X1 X2, cast_if (decide (X1 = X2))); abstract (by fold_leibniz). Defined.
  Global Instance mapset_elem_of_dec : RelDecision (∈@{mapset M}) | 1.
  Proof. refine (λ x X, cast_if (decide (mapset_car X !! x = Some ()))); done. Defined.
  Global Instance mapset_disjoint_dec : RelDecision (##@{mapset M}).
  Proof.
   refine (λ X1 X2, cast_if (decide (X1 ∩ X2 = ∅)));
    abstract (by rewrite disjoint_intersection_L).
  Defined.
  Global Instance mapset_subseteq_dec : RelDecision (⊆@{mapset M}).
  Proof.
   refine (λ X1 X2, cast_if (decide (X1 ∪ X2 = X2)));
    abstract (by rewrite subseteq_union_L).
  Defined.
End deciders.

Definition mapset_map_with {A B} (f : bool → A → option B)
    (X : mapset M) : M A → M B :=
  let (mX) := X in merge (λ x y,
    match x, y with
    | Some _, Some a => f true a | None, Some a => f false a | _, None => None
    end) mX.
Definition mapset_dom_with {A} (f : A → bool) (m : M A) : mapset M :=
  Mapset $ merge (λ x _,
    match x with
    | Some a => if f a then Some () else None | None => None
    end) m (@empty (M A) _).

Lemma lookup_mapset_map_with {A B} (f : bool → A → option B) X m i :
  mapset_map_with f X m !! i = m !! i ≫= f (bool_decide (i ∈ X)).
Proof.
  destruct X as [mX]. unfold mapset_map_with, elem_of, mapset_elem_of.
  rewrite lookup_merge by done. simpl.
  by case_bool_decide; destruct (mX !! i) as [[]|], (m !! i).
Qed.
Lemma elem_of_mapset_dom_with {A} (f : A → bool) m i :
  i ∈ mapset_dom_with f m ↔ ∃ x, m !! i = Some x ∧ f x.
Proof.
  unfold mapset_dom_with, elem_of, mapset_elem_of.
  simpl. rewrite lookup_merge by done. destruct (m !! i) as [a|].
  - destruct (Is_true_reflect (f a)); naive_solver.
  - naive_solver.
Qed.
Instance mapset_dom {A} : Dom (M A) (mapset M) := mapset_dom_with (λ _, true).
Instance mapset_dom_spec: FinMapDom K M (mapset M).
Proof.
  split; try apply _. intros. unfold dom, mapset_dom, is_Some.
  rewrite elem_of_mapset_dom_with; naive_solver.
Qed.
End mapset.

(** [mapset_elem_of] internally contains an equality; make sure that tactics do
not unfold it and try to unify [∈] against goals with [=]. *)
Opaque mapset_elem_of.

Arguments mapset_eq_dec : simpl never.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal23.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons (Succ (Succ Zero)) (Cons Zero Nil)).
Definition lfind_example_2  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_3  := ( Cons Zero         (Cons (Succ (Succ Zero))            (Cons (Succ Zero) (Cons Zero (Cons Zero Nil))))).
Definition lfind_example_4  := ( Cons Zero (Cons Zero (Cons Zero (Cons (Succ Zero) (Cons Zero Nil))))).
Definition lfind_example_5  := ( Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero Nil))).
Definition lfind_example_6  := ( Cons (Succ (Succ (Succ (Succ Zero)))) Nil).
Definition lfind_example_7  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_8  := ( Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) Nil))).
Definition lfind_example_9  := ( Cons (Succ (Succ (Succ Zero))) Nil).
Definition lfind_example_10  := ( Cons Zero         (Cons Zero            (Cons (Succ (Succ Zero))               (Cons (Succ Zero) (Cons (Succ Zero) Nil))))).
Definition lfind_example_11  := ( Cons (Succ Zero) Nil).
Definition lfind_example_12  := ( Cons Zero (Cons Zero (Cons (Succ Zero) Nil))).
Definition lfind_example_13  := ( Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero (Cons Zero Nil)))).
Definition lfind_example_14  := ( Cons Zero         (Cons Zero            (Cons (Succ Zero) (Cons (Succ (Succ Zero)) (Cons Zero Nil))))).
Definition lfind_example_15  := ( Cons Zero Nil).
Definition lfind_example_16  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_17  := ( Cons Zero (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil)))).
Definition lfind_example_18  := ( Cons (Succ (Succ (Succ Zero)))         (Cons (Succ (Succ (Succ (Succ Zero)))) Nil)).
Definition lfind_example_19  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_20  := ( Cons Zero Nil).
Definition lfind_example_21  := ( Cons (Succ Zero) Nil).
Definition lfind_example_22  := ( Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil)).
Definition lfind_example_23  := ( Cons (Succ Zero) Nil).
Definition lfind_example_24  := ( Cons Zero (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_25  := ( Cons (Succ Zero) Nil).
Definition lfind_example_26  := ( Cons (Succ Zero)         (Cons (Succ (Succ (Succ (Succ (Succ (Succ Zero)))))) Nil)).
Definition lfind_example_27  := ( Cons Zero Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal23_lem_46_lem2/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 lfind_example_17 lfind_example_18 lfind_example_19 lfind_example_20 lfind_example_21 lfind_example_22 lfind_example_23 lfind_example_24 lfind_example_25 lfind_example_26 lfind_example_27 .


Require Import Omega.
Require Import RelationClasses.
Require Import Coq.Logic.Classical.

From Paco Require Import paco.
From sflib Require Import sflib.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.

Require Import Time.
Require Import Event.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import Progress.
Require Import Behavior.
Require Import Trace.

Set Implicit Arguments.

Section Pred.

  Definition te_pred := ThreadEvent.t -> Prop.

  Definition promise_free (e: ThreadEvent.t): Prop :=
    match e with
    | ThreadEvent.promise loc from to msg kind =>
      (Memory.op_kind_is_lower_concrete kind && Message.is_released_none msg
       || Memory.op_kind_is_cancel kind)%bool
    | _ => True
    end.

  Definition no_acq_update_on (MSGS : Loc.t -> Time.t -> Prop)
             (e : ThreadEvent.t) : Prop :=
    match e with
    | ThreadEvent.update loc from _ _ _ _ _ ordr _ =>
      forall (SAT: MSGS loc from), ~ Ordering.le Ordering.acqrel ordr
    | _ => True
    end
  .

  Definition promise_not_in (MSGS : Loc.t -> Time.t -> Prop)
             (e : ThreadEvent.t) : Prop :=
    match e with
    | ThreadEvent.promise loc from to _ _ =>
      forall t (IN: Interval.mem (from, to) t), ~ (MSGS loc t)
    | _ => True
    end.

  Definition write_not_to (MSGS : Loc.t -> Time.t -> Prop)
             (e : ThreadEvent.t) : Prop :=
    match e with
    | ThreadEvent.write loc from to _ _ _ =>
      ~ MSGS loc to
    | ThreadEvent.update loc from to _ _ _ _ _ _ =>
      ~ MSGS loc to
    | ThreadEvent.promise loc from to _ kind =>
      if Memory.op_kind_is_cancel kind then True
      else ~ MSGS loc to
    | _ => True
    end.

  Definition wf_event (e: ThreadEvent.t): Prop :=
    match e with
    | ThreadEvent.write loc from to _ _ _ => Time.lt from to
    | ThreadEvent.update loc from to _ _ _ _ _ _ => Time.lt from to
    | ThreadEvent.promise loc from to _ _ => Time.lt from to
    | _ => True
    end.

  Definition wf_time_evt (P: Loc.t -> Time.t -> Prop) (e: ThreadEvent.t) : Prop :=
    match e with
    | ThreadEvent.promise loc from to msg kind =>
      (<<FROM: P loc from>>) /\ (<<TO: P loc to>>)
    | ThreadEvent.write loc from to val released ordw =>
      (<<FROM: P loc from>>) /\ (<<TO: P loc to>>)
    | ThreadEvent.update loc from to valr valw releasedr releasedw ordr ordw =>
      (<<FROM: P loc from>>) /\ (<<TO: P loc to>>)
    | _ => True
    end.

  Lemma wf_time_evt_mon P0 P1
        (LE: P0 <2= P1)
    :
      wf_time_evt P0 <1= wf_time_evt P1.
  Proof.
    ii. unfold wf_time_evt in *. des_ifs; des; splits; eauto.
  Qed.

  Definition no_promise (e : ThreadEvent.t) : Prop :=
    match e with
    | ThreadEvent.promise _ _ _ _ _ => False
    | _ => True
    end.

  Definition no_read_msgs (MSGS : Loc.t -> Time.t -> Prop)
             (e : ThreadEvent.t) : Prop :=
    match e with
    | ThreadEvent.read loc to _ _ _ => ~ (MSGS loc to)
    | ThreadEvent.update loc from _ _ _ _ _ _ _ => ~ (MSGS loc from)
    | _ => True
    end.

  Lemma bot_no_read (msgs: Loc.t -> Time.t -> Prop) e
        (MSGS: forall loc ts (MSGS: msgs loc ts), False)
    :
      no_read_msgs msgs e.
  Proof.
    unfold no_read_msgs. des_ifs.
    { ii. eapply MSGS; eauto. }
    { ii. eapply MSGS; eauto. }
  Qed.

  Definition write_not_in (MSGS : Loc.t -> Time.t -> Prop)
             (e : ThreadEvent.t) : Prop :=
    match e with
    | ThreadEvent.write loc from to _ _ _ =>
      forall t (IN: Interval.mem (from, to) t), ~ (MSGS loc t)
    | ThreadEvent.update loc from to _ _ _ _ _ _ =>
      forall t (IN: Interval.mem (from, to) t), ~ (MSGS loc t)
    | ThreadEvent.promise loc from to _ kind =>
      if Memory.op_kind_is_cancel kind then True
      else (forall t (IN: Interval.mem (from, to) t), ~ (MSGS loc t))
    | _ => True
    end.

  Definition no_update_on (MSGS : Loc.t -> Time.t -> Prop)
             (e : ThreadEvent.t) : Prop :=
    match e with
    | ThreadEvent.update loc from to _ _ _ _ _ _ =>
      ~ MSGS loc from
    | _ => True
    end.

  Definition no_sc (e : ThreadEvent.t) : Prop :=
    match e with
    | ThreadEvent.fence _ ordw => ~ Ordering.le Ordering.seqcst ordw
    | ThreadEvent.syscall _ => False
    | _ => True
    end
  .

  Definition write_in (MSGS : Loc.t -> Time.t -> Prop)
             (e : ThreadEvent.t) : Prop :=
    match e with
    | ThreadEvent.write loc from to _ _ _ =>
      forall t (IN: Interval.mem (from, to) t), (MSGS loc t)
    | ThreadEvent.update loc from to _ _ _ _ _ _ =>
      forall t (IN: Interval.mem (from, to) t), (MSGS loc t)
    | _ => True
    end.

  Lemma write_not_in_mon L0 L1
        e
        (NOTIN: write_not_in L1 e)
        (LE: L0 <2= L1)
    :
      write_not_in L0 e.
  Proof.
    i. unfold write_not_in in *. des_ifs.
    - ii. eapply NOTIN; eauto.
    - ii. eapply NOTIN; eauto.
    - ii. eapply NOTIN; eauto.
  Qed.

  Lemma write_not_in_mon_bot (L0 L1: Loc.t -> Time.t -> Prop)
        e
        (NOTIN: write_not_in L1 e)
        (LE: forall loc ts (SAT: L0 loc ts) (NBOT: Time.lt Time.bot ts), L1 loc ts)
    :
      write_not_in L0 e.
  Proof.
    i. unfold write_not_in in *. des_ifs.
    - ii. eapply NOTIN; eauto.
      eapply LE in H; eauto. inv IN.
      eapply TimeFacts.le_lt_lt; eauto. eapply Time.bot_spec.
    - ii. eapply NOTIN; eauto.
      eapply LE in H; eauto. inv IN.
      eapply TimeFacts.le_lt_lt; eauto. eapply Time.bot_spec.
    - ii. eapply NOTIN; eauto.
      eapply LE in H; eauto. inv IN.
      eapply TimeFacts.le_lt_lt; eauto. eapply Time.bot_spec.
  Qed.

  Lemma no_read_msgs_mon L0 L1
        e
        (NOTIN: no_read_msgs L1 e)
        (LE: L0 <2= L1)
    :
      no_read_msgs L0 e.
  Proof.
    i. unfold no_read_msgs in *. des_ifs.
    - ii. eapply NOTIN; eauto.
    - ii. eapply NOTIN; eauto.
  Qed.

  Lemma no_read_msgs_sum L0 L1 L2
        e
        (NOTIN0: no_read_msgs L0 e)
        (NOTIN1: no_read_msgs L1 e)
        (LE: L2 <2= (L0 \2/ L1))
    :
      no_read_msgs L2 e.
  Proof.
    unfold no_read_msgs in *. des_ifs.
    - ii. eapply LE in H. des; auto.
    - ii. eapply LE in H. des; auto.
  Qed.

  Lemma no_update_on_mon L0 L1
        e
        (NOTIN: no_update_on L1 e)
        (LE: L0 <2= L1)
    :
      no_update_on L0 e.
  Proof.
    i. unfold no_update_on in *. des_ifs.
    ii. eapply NOTIN; eauto.
  Qed.

  Definition no_acq_read_msgs (MSGS : Loc.t -> Time.t -> Prop)
             (e : ThreadEvent.t) : Prop :=
    match e with
    | ThreadEvent.read loc to _ _ ord =>
      forall (SAT: MSGS loc to), ~ Ordering.le Ordering.acqrel ord
    | ThreadEvent.update loc from _ _ _ _ _ ordr _ =>
      forall (SAT: MSGS loc from), ~ Ordering.le Ordering.acqrel ordr
    | _ => True
    end
  .

End Pred.

Section PredStep.

  Inductive pred_step (P : te_pred) lang (e:ThreadEvent.t)
             (e1 e2:Thread.t lang) : Prop :=
  | pred_step_intro (STEP : Thread.step_allpf e e1 e2) (SAT : P e)
  .

  Lemma pred_step_program_step P:
        @pred_step P <4= @Thread.step_allpf.
  Proof.
    i. inv PR. eauto.
  Qed.

  Lemma program_step_true_step:
        @Thread.step_allpf <4= @pred_step (fun _ => True).
  Proof.
    econs; eauto.
  Qed.

  Lemma pred_step_mon P Q (LE : P <1= Q) :
    @pred_step P <4= @pred_step Q.
  Proof.
    i. inv PR. econs; eauto.
  Qed.

  Lemma pred_step_rtc_mon P Q lang (LE : P <1= Q) :
    rtc (tau (@pred_step P lang)) <2= rtc (tau (@pred_step Q lang)).
  Proof.
    i. induction PR; eauto.
    eapply Relation_Operators.rt1n_trans; eauto.
    inv H. econs; eauto. eapply pred_step_mon; eauto.
  Qed.

  Lemma thread_steps_pred_steps P lang:
    rtc (tau (@pred_step P lang)) <2= rtc (@Thread.tau_step lang).
  Proof.
    i. induction PR; eauto.
    eapply Relation_Operators.rt1n_trans; eauto.
    inv H. inv TSTEP. econs; eauto.
  Qed.

  Lemma pred_steps_thread_steps lang:
    rtc (@Thread.tau_step lang) <2= rtc (tau (@pred_step (fun _ => True) lang)).
  Proof.
    i. induction PR; eauto.
    eapply Relation_Operators.rt1n_trans; eauto.
    inv H. econs; eauto. eapply program_step_true_step; eauto.
  Qed.

  Lemma hold_or_not (P Q : te_pred) lang e1 e2
        (STEP : rtc (tau (@pred_step P lang)) e1 e2) :
    (<<HOLD : rtc (tau (@pred_step (P /1\ Q) lang)) e1 e2>>) \/
    (<<NOT : exists e e2' e3, (<<STEPS0 : rtc (tau (@pred_step (P /1\ Q) lang)) e1 e2'>>) /\
                              (<<STEP : Thread.step_allpf e e2' e3>>) /\
                              (<<BREAKP : P e>>) /\ (<<BREAKQ : ~ Q e>>) /\
                              (<<STEPS1 : rtc (tau (@pred_step P lang)) e3 e2>>)>>).
  Proof.
    induction STEP as [th | th1 th2 th3 HD TL IH]; auto.
    inv HD. inv TSTEP. destruct (classic (Q e)) as [QT | QF]. des.
    - left. repeat (econs; eauto).
    - right. do 4 (eauto; econs).
      * apply Operators_Properties.clos_rt_rt1n.
        eapply Relation_Operators.rt_trans. repeat (econs; eauto).
        eapply Operators_Properties.clos_rt1n_rt. eauto.
      * eauto.
    - right. repeat (econs; eauto).
  Qed.

  Lemma no_promise_program_step lang :
    (@pred_step no_promise lang) <3= (@Thread.program_step lang).
  Proof.
    i. inv PR. inv STEP. inv STEP0; clarify.
    inv STEP. ss.
  Qed.

  Lemma no_promise_program_step_rtc lang :
    rtc (tau (@pred_step no_promise lang)) <2= rtc (tau (@Thread.program_step _)).
  Proof.
    i. induction PR.
    - refl.
    - econs; eauto. inv H. econs; eauto.
      eapply no_promise_program_step; eauto.
  Qed.

  Lemma pred_steps_trace_steps P lang
        th0 th1
    :
      rtc (tau (@pred_step P lang)) th0 th1 <->
      exists tr,
        (<<STEPS: Trace.steps tr th0 th1>>) /\
        (<<EVENTS: List.Forall (fun em => <<SAT: P (snd em)>> /\ <<TAU: ThreadEvent.get_machine_event (snd em) = MachineEvent.silent>>) tr >>)
  .
  Proof.
    split; i.
    - ginduction H; i.
      + exists []. splits; eauto.
      + des. inv H. inv TSTEP. exists (((Thread.local x), e)::tr). splits.
        * inv STEP. econs; eauto.
        * i. ss. des; clarify. eauto.
    - des. ginduction STEPS; i.
      + refl.
      + inv EVENTS; ss. clarify. des. econs.
        * econs; eauto. econs; eauto. econs; eauto.
        * eauto.
  Qed.

  Lemma pred_steps_trace_steps2 P lang
        th0 th1 tr
        (STEPS: Trace.steps tr th0 th1)
        (EVENTS: List.Forall (fun em => <<SAT: P (snd em)>> /\ <<TAU: ThreadEvent.get_machine_event (snd em) = MachineEvent.silent>>) tr)
  :
    rtc (tau (@pred_step P lang)) th0 th1.
  Proof.
    eapply pred_steps_trace_steps; eauto.
  Qed.

  Lemma pf_step_promise_free_step lang:
    @Thread.step lang true <3= @pred_step promise_free lang.
  Proof.
    i. inv PR.
    - econs; eauto.
      + econs; eauto. econs 1; eauto.
      + inv STEP. ss.
    - econs; eauto.
      + econs; eauto. econs 2; eauto.
      + inv STEP. inv LOCAL; ss.
  Qed.

  Lemma pf_step_promise_free_step_rtc lang :
    rtc (tau (@Thread.step _ true)) <2= rtc (tau (@pred_step promise_free lang)).
  Proof.
    i. induction PR.
    - refl.
    - econs; eauto. inv H. econs; eauto.
      eapply pf_step_promise_free_step; eauto.
  Qed.

  Definition te_rel := ThreadEvent.t -> ThreadEvent.t -> Prop.

  Definition te_pred_shift (P_src P_tgt: te_pred) (R: te_rel) :=
    forall e_src e_tgt (SAT: P_tgt e_tgt) (REL: R e_src e_tgt), P_src e_src.

  Lemma pred_step_shift (P_src P_tgt: te_pred) (R: te_rel)
        (SHIFT: te_pred_shift P_src P_tgt R)
        e_src e_tgt lang (th0 th1: Thread.t lang)
        (SAT: P_tgt e_tgt)
        (REL: R e_src e_tgt)
        (STEP: Thread.step_allpf e_src th0 th1)
    :
      pred_step P_src e_src th0 th1.
  Proof.
    econs; eauto.
  Qed.

  Definition same_machine_event e_src e_tgt :=
    ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt.

  Lemma event_times_list_exists
        e
    :
      exists (times: Loc.t -> list Time.t),
        (<<EVT: wf_time_evt (fun loc ts => List.In ts (times loc)) e >>).
  Proof.
    destruct e; ss; try by (exists (fun _ => []); splits; auto).
    { exists (fun loc' => if Loc.eq_dec loc' loc then [from; to] else []).
      des_ifs; ss; auto. }
    { exists (fun loc' => if Loc.eq_dec loc' loc then [from; to] else []).
      des_ifs; ss; auto. }
    { exists (fun loc' => if Loc.eq_dec loc' loc then [tsr; tsw] else []).
      des_ifs; ss; auto. }
  Qed.

  Lemma step_times_list_exists lang (th0 th1: Thread.t lang) e pf
        (STEP: Thread.step pf e th0 th1)
    :
      exists (times: Loc.t -> list Time.t),
        (<<WFTIME: wf_time_evt (fun loc to => List.In to (times loc)) e>>).
  Proof.
    exploit event_times_list_exists; eauto.
  Qed.

  Lemma trace_times_list_exists (tr: Trace.t)
    :
      exists (times: Loc.t -> list Time.t),
        (<<WFTIME: List.Forall (fun em => wf_time_evt (fun loc to => List.In to (times loc)) (snd em)) tr>>).
  Proof.
    induction tr.
    { exists (fun _ => []). ss. }
    { des. hexploit (event_times_list_exists (snd a)). i. des.
      exists (fun loc => times loc ++ times0 loc). econs.
      { eapply wf_time_evt_mon; eauto. i. ss.
        eapply List.in_or_app; auto. }
      { eapply List.Forall_impl; eauto. i. ss.
        eapply wf_time_evt_mon; eauto. i. ss.
        eapply List.in_or_app; auto. }
    }
  Qed.

  Inductive opt_pred_step P lang
    : ThreadEvent.t -> Thread.t lang -> Thread.t lang -> Prop :=
  | step_none t: opt_pred_step P ThreadEvent.silent t t
  | step_some
      e t0 t1
      (STEP: pred_step P e t0 t1)
    :
      opt_pred_step P e t0 t1.
  Hint Constructors opt_pred_step.

End PredStep.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery32_2e150m3_5limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery32_2e285m9_9limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


From iris Require Import invariants.
From iris.algebra Require Import gmap frac agree frac_auth.
From iris.base_logic Require Export gen_heap.
From iris.base_logic.lib Require Export own saved_prop.
From iris.program_logic Require Export weakestpre.
From iris.proofmode Require Import tactics.
From stdpp Require Import base.
From distris Require Import tactics proofmode notation adequacy.
From distris.examples.lock_server Require Import lock_proof.
From distris.examples.monotone_cell Require Import monotone_cell.

From iris.base_logic.lib Require Import fractional.

Set Default Proof Using "Type".

Import Network.
Import String.
Import uPred.

Lemma ms_sender_message m a :
  ms_sender (message_stable_from_message m) = a -> m_sender m = a.
Proof. eauto. Qed.

Lemma ms_body_message m s :
  ms_body (message_stable_from_message m) = s -> m_body m = s.
Proof. eauto. Qed.

Inductive client_state : Type :=
| ST_LOCKING
| ST_WRITING
| ST_RELEASING.

Definition monoCmra : cmraT := prodR fracR (agreeR (leibnizC nat)).
Definition stateC := prodR fracR (agreeR (leibnizC client_state)).

Class monoG Σ := MonoG { monoG_inG :> inG Σ monoCmra;
                         stateG_inG :> inG Σ stateC;
                         mono_name : gname;
                         statec_name : gname;
                       }.
Definition monoΣ : gFunctors := #[GFunctor monoCmra; GFunctor stateC].

Instance subG_monoΣ {Σ} : subG monoΣ Σ → inG Σ monoCmra.
Proof. solve_inG. Qed.

Definition mono_server_address := SocketAddressInet "localhost" 1338.
Definition mono_si_fix : gset socket_address := {[ mono_server_address ]}.

Section mono.
  Context `{lG : lockG Σ}
          `{mG : monoG Σ}
          `{dG : distG Σ}.

  Definition makeElem (q : Qp) (m : nat) : monoCmra := (q, to_agree m).
  Definition ownMono (q : Qp) (m : nat) :=
    own (A:= monoCmra) mono_name (makeElem q m).

  Definition ownS (s : client_state) :=
    own (A:= stateC) statec_name (½, to_agree s).

  Global Instance makeElem_Exclusive m : Exclusive (makeElem 1 m).
  Proof.
    intros [y ?] [H' _]. apply (exclusive_l _ _ H').
  Qed.

  Lemma makeElem_op p q n:
    makeElem p n ⋅ makeElem q n ≡ makeElem (p + q) n.
  Proof.
    rewrite /makeElem; split; first done.
      by rewrite /= agree_idemp.
  Qed.

  Global Instance monoAsFractional q n : AsFractional (ownMono q n)
                                                      (λ q, (ownMono q n)) q.
  Proof.
    constructor; first trivial.
    intros p p'. by rewrite /ownMono -makeElem_op own_op.
  Qed.

  Lemma makeElem_eq p q n m:
    ownMono p m -∗ ownMono q n -∗ ⌜m = n⌝.
  Proof.
    iIntros "H1 H2".
    iDestruct (own_valid_2 with "H1 H2") as %HValid.
    destruct HValid as [_ H2].
    iIntros "!%". by apply agree_op_invL'.
  Qed.

  Lemma makeElem_entail p q m n:
    ownMono p m -∗ ownMono q n -∗ ownMono (p + q) m.
  Proof.
    iIntros "H1 H2".
    iDestruct (makeElem_eq with "H1 H2") as %->.
    iCombine "H1" "H2" as "H".
      by rewrite makeElem_op.
  Qed.

  Lemma makeElem_update n m k:
    ownMono ½ n -∗ ownMono ½ m ==∗ ownMono 1 k.
  Proof.
    iIntros "H1 H2".
    iDestruct (makeElem_entail with "H1 H2") as "H".
    rewrite Qp_div_2.
    iApply (own_update with "H"); by apply cmra_update_exclusive.
  Qed.

  Lemma state_eq s1 s2:
    ownS s1 -∗ ownS s2 -∗ ⌜s1 = s2⌝.
  Proof.
    iIntros "H1 H2". rewrite /ownS.
    iCombine "H1" "H2" as "H".
    iDestruct (own_valid with "H") as %HValid.
    destruct HValid as [_ H2]; simpl in H2;
    iIntros "!%". by apply (agree_op_invL' (A:=leibnizC client_state)).
  Qed.

  Lemma state_update s1 s2 s3:
    ownS s1 -∗ ownS s2 ==∗ ownS s3 ∗ ownS s3.
  Proof.
    iIntros "H1 H2". rewrite /ownS.
    iDestruct (state_eq with "H1 H2") as %->.
    iCombine "H1" "H2" as "H".
    rewrite -own_op pair_op frac_op' Qp_div_2.
    iApply (own_update with "H"); apply cmra_update_exclusive.
    by rewrite agree_idemp.
  Qed.

  Definition mono_si S : socket_interp Σ :=
    (λ msg, ∃ φ, ms_sender msg ⤇ φ ∗ S ∗
    ((∃ π n, ⌜ms_body msg = "READ"⌝ ∗ ownMono π n ∗
    (∀ m, ⌜ms_body m = StringOfZ (Z.of_nat n)⌝ ∗ ownMono π n ∗ S -∗ φ m)) ∨
     ∃ n n', ⌜ms_body msg = "WRITE" +:+ "_" +:+ StringOfZ (Z.of_nat n')⌝ ∗
             ⌜n < n'⌝ ∗ ownMono ½ n ∗
           (∀ m, ⌜ms_body m = StringOfZ (Z.of_nat n')⌝ ∗ ownMono ½ n' ∗ S -∗ φ m)))%I.

  Arguments mono_si : simpl never.

  Definition handlerR n l :=
    (∃ (m : nat), l ↦[n] #m ∗ ownMono ½ m)%I.

  Lemma mono_server_s n γs A S :
    SocketAddressInet "localhost" 1338 ∈ A ->
    {{{ f↦ A ∗ mono_server_address ⤇ mono_si S ∗
        n n↦ γs ∗ FreePorts "localhost" {[1338%positive]} ∗ ownMono 1 0 }}}
      ⟨n; mono_server #()⟩
    {{{ v, RET v; ∃ v', ⌜v = 〈n;v'〉⌝ }}}.
  Proof.
    iIntros (Hin Φ) "(#Hfixed & #Hsi & Hn & Hfp & Hown) HΦ". wp_lam.
    wp_alloc l as "Hl". wp_let.
    wp_socket h as "Hs"; do 3 wp_let.
    wp_apply (wp_bind_socket_fix_suc _ _ _ _ _ {|
                            sfamily := PF_INET;
                            stype := SOCK_DGRAM;
                            sprotocol := IPPROTO_UDP;
                            saddress := None |} _ _
                with "[Hfp Hs]"); try iFrame; simpl; try done.
    iDestruct 1 as (g) "(Hsocket & Hbind & Hrecs & #Hsi')".
    wp_seq.
    wp_apply (listen_spec (handlerR n l) (λ v, ⌜True⌝)%I
                with "[] [-HΦ]"); last first; eauto.
    - iIntros (v) "_". iApply "HΦ"; eauto.
    - iFrame. iExists 0. iFrame. by iDestruct "Hown" as "[Ho1 Ho2]".
    - iLöb as "IH" forall (g).
      iIntros (mId m φ ϕ) "!# (_ & HP & Hs & Hrecs & Hm & #Hsi'' & Hsipred) HΦ'".
      iDestruct "HP" as (v) "(Hl & HownM)". rewrite /mono_server_address.
      iDestruct (si_pred_agree _ _ _ (message_stable_from_message m) with "Hsi Hsi''")
        as "#HX".
      wp_rec. simpl. iRewrite -"HX" in "Hsipred". wp_let.
      iDestruct "Hsipred" as (si) "(#Hsia & HS & [Hread | Hwrite])".
      + iDestruct "Hread" as (Hsp n0 Hmsg) "(HownM' & Hwand)"; subst.
        wp_load. wp_let. rewrite (ms_body_message _ "READ"); last auto.
        wp_op. case_bool_decide; last done. wp_if. wp_op.
        iDestruct (makeElem_eq with "HownM HownM'") as %Heq; subst.
        wp_apply (wp_send_to_bound True%I True%I
                                   _
                                   (StringOfZ (Z.of_nat n0))
                                 with "[$Hs Hwand HownM' HS]"); eauto; iFrame "#".
        { iSplitR; eauto.
          iIntros (M sent mId') "(Hms & HmId')". simpl. iFrame.
          iModIntro. iSplitL; last auto. iNext.
          iApply "Hwand". iFrame. eauto. }
        iIntros "(Hsocket & _)". wp_seq.
        wp_apply (listen_spec (handlerR n l) (λ v, ⌜True⌝)%I
                    with "[] [-HΦ']"); last first; eauto. iFrame.
        iExists n0. iFrame.
        iApply "IH". eauto.
      + iDestruct "Hwrite" as (n0 n' Hmsg Hlt) "(HownM' & Hwand)"; subst.
        wp_load. wp_let. apply ms_body_message in Hmsg. rewrite Hmsg.
        wp_op. case_bool_decide; first done. wp_if.
        wp_apply (value_of_message_spec _ #("WRITE" +:+ "_" +:+ StringOfZ n')
                                        ("WRITE" +:+ "_" +:+ StringOfZ n')
                                        "WRITE" (StringOfZ n')); try done.
        iIntros (s) "#Hstr". iSimplifyEq. wp_op. simpl. by rewrite ZOfString_inv.
        wp_apply unSOME_spec; first done. iIntros (_). wp_let.
        iDestruct (makeElem_eq with "HownM HownM'") as %Heq.
        iSimplifyEq.
        wp_lam. wp_seq. wp_op. case_bool_decide; last first.
        { destruct H0. omega. }
        wp_if. wp_seq. wp_store.
        iMod (makeElem_update _ _ n' with "HownM HownM'") as "[HownM HownM']". wp_op.
        wp_apply (wp_send_to_bound ⌜True⌝%I ⌜True⌝%I
                                   _ (StringOfZ n')
                                 with "[$Hs Hwand HownM' HS]"); eauto.
        { iFrame. iFrame "#". iSplit; first done. simpl.
          iIntros (M sent mId') "(HM & HmId' & _)". simpl. iFrame.
          iModIntro. iSplitL; last done. iNext. iApply "Hwand". iFrame. eauto. }
        iIntros "(Hsocket & _)". simpl. wp_seq.
        wp_apply (listen_spec (handlerR n l) (λ v, ⌜True⌝)%I
                    with "[] [-HΦ']"); last first; auto. iFrame.
        iExists n'. iFrame; iFrame "#".
        iApply "IH". eauto.
    - eauto.
Qed.

  Definition client_si client : socket_interp Σ :=
    (λ msg,
    (∃ n, ⌜ms_body msg = StringOfZ (Z.of_nat n)⌝ ∗ ownMono ½ n ∗ ownS ST_WRITING) ∨
    (∃ n, ⌜ms_body msg = "YES"⌝ ∗ ownS ST_LOCKING ∗ ownMono ½ n ∗
            ownLk (makeLkElem ¾ client)) ∨
    ⌜ms_body msg = "NO"⌝ ∗ ownS ST_LOCKING ∨
    ⌜ms_body msg = "RELEASED"⌝ ∗ ownS ST_LOCKING)%I.

  Lemma client_s (n : node) (ip : ip_address) port address
        (lsaddr msaddr : socket_address) A e1 e2 e3 e4 :
    SocketAddressInet ip port = address ->
    IntoVal ⟨n;e1⟩ 〈n;#ip〉 →
    IntoVal ⟨n;e2⟩ 〈n;#(Z.pos port)〉 →
    IntoVal ⟨n;e3⟩ 〈n;#lsaddr〉 →
    IntoVal ⟨n;e4⟩ 〈n;#msaddr〉 →
    address ∉ A →
    {{{ ∃ γs , f↦ A ∗ FreePorts ip {[port]} ∗ n n↦ γs ∗
        lsaddr ⤇ lock_si (∃ m, ownMono ½ m) (ownS ST_LOCKING) ∗
        msaddr ⤇ mono_si (ownS ST_WRITING) ∗ ownS ST_LOCKING ∗ ownS ST_LOCKING
    }}}
      ⟨n;client e1 e2 e3 e4⟩
      {{{ r, RET r; ⌜True⌝ }}}.
  Proof.
    iIntros (Haddress <-%to_base_val'%ground_lang.of_to_val
                     <-%to_base_val'%ground_lang.of_to_val
                     <-%to_base_val'%ground_lang.of_to_val
                     <-%to_base_val'%ground_lang.of_to_val Hnotin Φ) "H HΦ".
    iDestruct "H" as (γs) "(#Hfixed & Hip & Hn & #Hlock & #Hmono & Hst & Hst')".
    wp_lam. do 3 wp_let.
    wp_socket h as "Hsocket". wp_let.
    wp_pure (MakeAddress _ _).
    wp_apply (wp_bind_socket_dyn_suc _ _ _ _ _ {|
                            sfamily := PF_INET;
                            stype := SOCK_DGRAM;
                            sprotocol := IPPROTO_UDP;
                            saddress := None |} _ _ (client_si address)
                with "[$Hfixed Hip $Hsocket]"); simpl; eauto; try done.
    { by rewrite Haddress. }
    iIntros "H". iDestruct "H" as (g) "(Hsocket & Hbind & Hrecs & #Hsi)".
    wp_seq.
    wp_apply (wp_send_to_bound True%I True%I
              (lock_si (∃ m, ownMono ½ m) (ownS ST_LOCKING)) _ h
                with "[$Hsocket $Hlock Hst']"); eauto.
    { iSplitR; first done.
      iIntros (M sent mId) "(Hsent & HmId & _)". iFrame.
      iModIntro. simpl. iNext. iExists _. repeat (iSplitR; first done).
      iLeft. iSplitR; eauto. iNext.
      iIntros (ms) "[[% Hst'] | [% (Hres & Hl & Hst')]]";
        rewrite /client_si; iFrame; eauto. rewrite H Haddress. iRight. iLeft.
      iDestruct "Hres" as (m) "Hres".
      iExists _. by iFrame. }
    iIntros "(Hs & _)". wp_seq.
    wp_apply (listen_spec
                (ownS ST_LOCKING)%I
                (λ v, ⌜True⌝)%I
                with "[][-HΦ][HΦ]"); last first; auto.
    - iIntros (v) "_". by iApply "HΦ".
    - by iFrame.
    - iLöb as "IH" forall (g).
      iIntros (mId lockA φ ϕ)
              "!# (_ & Hst & Hs & Hrecs & Hm & #Hsi'' & Hsipred) HΦ'".
      iDestruct (si_pred_agree _ _ _ (message_stable_from_message lockA)
                   with "Hsi Hsi''") as "#Heq".
      wp_rec. wp_let. iRewrite -"Heq" in "Hsipred".
      wp_op. case_bool_decide as Hop. inversion Hop as [Hop'].
      wp_op. wp_if. rewrite /client_si.
      iDestruct "Hsipred" as "[Hres | [Hyes | [[Hmsg Hno] | [Hmsg _]]]]"; eauto.
      + iDestruct "Hres" as (n0) "[-> (Hown & Hst')]".
        iDestruct (state_eq with "Hst Hst'") as %Heq. inversion Heq.
      + iDestruct "Hyes" as (n0 Hmsg) "(Hst' & HownM & HownL)".
        iDestruct (state_update _ _ ST_WRITING with "Hst Hst'") as ">(Hst & Hst')".
        wp_apply (wp_send_to_bound ⌜True⌝%I ⌜True⌝%I
                                 (mono_si (ownS ST_WRITING)) _ h
                    with "[$Hs Hst' HownM]"); eauto.
        { iFrame. iFrame "#". iSplitR; first done.
          iIntros (M sent mId') "(Hsent & HmId & _)". iFrame. iModIntro. simpl. iNext.
          iExists (client_si address). iFrame "#".
          iLeft. iExists _,_. iFrame. iSplitR. done. iIntros (m0) "[% H]".
          iLeft. iExists n0. eauto. }
        iIntros "[Hs _]". wp_seq.
        wp_apply (listen_wait_spec with "[$Hs Hrecs Hsi]"); eauto.
        iIntros (m mId') "(_ & Hs & Hrecs & HmId' & Hφ)".
        iDestruct (si_pred_agree _ _ _ (message_stable_from_message m)
                     with "Hsi Hsi''") as "#Heq'".
        wp_let. wp_proj. iRewrite -"Heq'" in "Hφ".
        iAssert (∃ n1 : nat,
          ⌜ms_body (message_stable_from_message m) = StringOfZ n1⌝
          ∗ ownMono ½ n1 ∗ ownS ST_WRITING ∗ ownS ST_WRITING)%I
          with "[Hst Hφ]" as "Hφ".
        { iDestruct "Hφ" as "[Hok | [Hfalse | [[_ Hst'] | [_ Hst']]]]".
          - iFrame; eauto.
          - iDestruct "Hfalse" as (n1) "(_ & Hst' & _)".
            iDestruct (state_eq with "Hst Hst'") as %Heq. inversion Heq.
          - iDestruct (state_eq with "Hst Hst'") as %Heq. inversion Heq.
          - iDestruct (state_eq with "Hst Hst'") as %Heq. inversion Heq. }
        iDestruct "Hφ" as (n1) "(Hmsg & HownM & Hst & Hst')".
        iDestruct "Hmsg" as %Hmsg'%ms_body_message. rewrite Hmsg'.
        wp_op. simpl. by rewrite ZOfString_inv.
        wp_apply unSOME_spec; eauto. iIntros (_). wp_let.
        do 4 wp_op.
        wp_apply (wp_send_to_bound True%I True%I
                                 (mono_si (ownS ST_WRITING))
                                 _ h
                    with "[$Hs Hst' HownM]"); eauto; iFrame "#".
        { iSplitR. done. simpl.
          iIntros (M ms x1) "(Hms & HmId)". iFrame.
          iModIntro. iNext. iExists (client_si address).
          iFrame; iFrame "#".
          iRight. iExists n1,(n1 + 1). iFrame; eauto. iSplitR. rewrite -append_assoc.
            by rewrite Nat.add_1_r Z.add_1_r Nat2Z.inj_succ.
            iSplitR. iPureIntro. lia.
            iIntros (m') "H". iLeft. iExists (n1 + 1). eauto. }
        iIntros "[Hs _]". wp_seq.
        wp_apply (listen_wait_spec with "[$Hs Hrecs Hsi]"); eauto.
        iIntros (m' mId'') "(_ & Hs & Hrecs & HmId'' & Hφ)".
        iDestruct "Heq" as "_". iDestruct "Heq'" as "_".
        iDestruct (si_pred_agree _ _ _ (message_stable_from_message m')
                     with "Hsi Hsi''") as "#Heq".
        wp_let. iRewrite -"Heq" in "Hφ".
        iAssert (∃ n1 : nat,
          ⌜ms_body (message_stable_from_message m') = StringOfZ n1⌝
          ∗ ownMono ½ n1 ∗ ownS ST_WRITING ∗ ownS ST_WRITING)%I
          with "[Hst Hφ]" as "Hφ".
        { iDestruct "Hφ" as "[Hok | [Hfalse | [[_ Hst'] | [_ Hst']]]]".
          - iFrame; eauto.
          - iDestruct "Hfalse" as (n2) "(_ & Hst' & _)".
            iDestruct (state_eq with "Hst Hst'") as %Heq. inversion Heq.
          - iDestruct (state_eq with "Hst Hst'") as %Heq. inversion Heq.
          - iDestruct (state_eq with "Hst Hst'") as %Heq. inversion Heq. }
        iDestruct "Hφ" as (n2) "(Hmsg & HownM & Hst & Hst')".
        iDestruct (state_update _ _ ST_LOCKING with "Hst Hst'") as ">(Hst & Hst')".
        wp_apply (wp_send_to_bound ⌜True⌝%I ⌜True⌝%I
                                   (lock_si (∃ m, ownMono ½ m) (ownS ST_LOCKING))
                                   _ h
                    with "[$Hlock Hst' HownM HownL $Hs]"); eauto.
        { iSplitR. done.
          iIntros (M ms x1) "(Hms & HmId)". iFrame. simpl.
          iExists (client_si address). iFrame "#". iModIntro.
          iRight. iSplitR. done. iSplitL "HownM". eauto.
          rewrite Haddress. iFrame. iNext. iNext.
          iIntros (m0) "(Hmsg & HownL)". rewrite /client_si. eauto.  }
        iIntros "(Hs & _)". by iApply "HΦ'".
      + iDestruct "Hmsg" as %Hmsg. inversion Hmsg as [Hfalse].
          by rewrite Hop' in Hfalse.
      + iDestruct "Hmsg" as %Hmsg. inversion Hmsg as [Hfalse].
          by rewrite Hop' in Hfalse.
      + wp_op. wp_if.
        iAssert (ownS ST_LOCKING ∗ ownS ST_LOCKING)%I with "[Hsipred Hst]"
          as "(Hst & Hst')".
        { iDestruct "Hsipred" as "[Hfalse | [Hfalse | [[% Hok] | [_ Hst']]]]".
          - iDestruct "Hfalse" as (?) "(_ & _ & Hst')".
            iDestruct (state_eq with "Hst Hst'") as %Heq. inversion Heq.
          - iDestruct "Hfalse" as (n1) "(Hfalse & Hst' & _)".
            iDestruct "Hfalse" as %Hfalse. inversion Hfalse as [Hfalse'].
            destruct Hop. rewrite Hfalse'. eauto.
          - iFrame.
          - iFrame. }
        wp_apply (wp_send_to_bound True%I True%I
                                   (lock_si (∃ m, ownMono ½ m) (ownS ST_LOCKING))
                                   _ h
                with "[$Hs $Hlock Hst']"); eauto.
        { iSplitR; first done.
          iIntros (M sent mId') "(Hsent & HmId & _)". iFrame.
          iModIntro. simpl. iNext. iExists(client_si address).
          repeat (iSplitR; first done).
          iLeft. iSplitR; eauto. iNext.
          iIntros (ms) "[[% Hst'] | [% (Hres & Hl & Hst')]]";
            rewrite /client_si; iFrame; eauto. rewrite H Haddress. iRight. iLeft.
          iDestruct "Hres" as (m) "Hres".
          iExists _. by iFrame. }
        iIntros "[Hs _]". wp_seq.
        wp_apply (listen_spec
                    (ownS ST_LOCKING)%I
                    (λ v, ⌜True⌝)%I
                    with "[][-HΦ']"); eauto; last iFrame; last first.
        iApply "IH". eauto.
    - eauto.
  Qed.

End mono.


Load loadpath.
Require Import ZArith List Bool Recdef.
Require Import Coqlib.
Require Import veristar.variables veristar.datatypes veristar.clauses
               veristar.cclosure veristar.basic veristar.compare.

(** * Superposition:
a superposition-based theorem prover for ground clauses, with a new,
counterexample-guided saturation strategy
*)

Module Type SUPERPOSITION.

Definition model := list (var * expr).

Inductive superposition_result : Type :=
| Valid : superposition_result
| C_example : model -> M.t -> superposition_result
| Aborted : list clause -> superposition_result.

(** check:
-Check a pure entailment of the form [Pi ==> Pi']
-Returns, when a [C_example] is found, the model exhibiting the [C_example] and
 the final clause set (i.e., the set of clauses derived during proof search)
*)

Parameter check : entailment -> superposition_result * list clause * M.t*M.t.

(** check_clauseset:
Just like check, except we operate instead on an initial _set_ of clauses.
This function is the one called by the main theorem prover, veristar.v. *)

Parameter check_clauseset : M.t -> superposition_result * list clause * M.t*M.t.

(** is_model_of_PI:
Check whether R is a model of Pi+ /\ Pi-; used in the Veristar main loop *)

Parameter is_model_of_PI : model -> clause -> bool.

Parameter rewrite_by : expr -> expr -> pure_atom -> pure_atom.

Parameter demodulate : clause -> clause -> clause.

Parameter simplify : list clause -> clause -> clause.

Parameter simplify_atoms : list clause -> list space_atom -> list space_atom.

End SUPERPOSITION.

(** Module Superposition:
 *)

Module Superposition <: SUPERPOSITION.

Definition model := list (var * expr).

Inductive superposition_result : Type :=
| Valid : superposition_result
| C_example : model -> M.t -> superposition_result
| Aborted : list clause -> superposition_result.

(* side condition used in superposition rules below *)
(* begin hide *)
Definition pure_atom_gt1 a (l: list pure_atom) :=
  match l with b :: _ => pure_atom_gt a b | _ => true end.
(* end hide *)

(** ef:
Equality factoring *)

Fixpoint ef_aux neg u0 u v pos0 pos l0 : list clause :=
  match pos with
  | (Eqv s t as a2) :: pos' =>
    if expr_eq s u && greater_than_all u0 neg
    then mkPureClause
           (insu_atm (norm_pure_atom (Eqv v t)) neg)
           (insu_atm (norm_pure_atom (Eqv u t))
                 (merge pure_atom_cmp (List.rev pos0) pos)) ::
             ef_aux neg u0 u v (insu_atm a2 pos0) pos' l0
    else l0
  | nil => l0
  end.

Definition ef (cty : ce_type) (c : clause) l0 : list clause :=
  match cty, c with
  | CexpEf, PureClause neg (Eqv (Var u0 as u) v :: pos) _ _ =>
    if greater_than_all u0 neg then ef_aux neg u0 u v nil pos l0
    else l0
  | _, _ => l0
  end.

(** sp:
left and right superposition *)

Definition sp (cty : ce_type) (c d : clause) l0 : list clause :=
  match cty, c, d with
  (* negative (left) superposition *)
  | CexpL, PureClause (Eqv s' v :: neg') pos' _ _,
           PureClause neg (Eqv (Var s0 as s) t :: pos) _ _ =>
    if expr_eq s s' && expr_lt t s && expr_lt v s' &&
       pure_atom_gt1 (Eqv s t) pos && greater_than_all s0 neg
    then mkPureClause
      (insu_atm (norm_pure_atom (Eqv t v)) (merge pure_atom_cmp neg neg'))
      (merge pure_atom_cmp pos pos') :: l0
    else l0
  (* positive (right) superposition *)
  | CexpR, PureClause neg (Eqv (Var s0 as s) t :: pos) _ _,
           PureClause neg' (Eqv (Var s'0 as s') v :: pos') _ _ =>
    if expr_eq s s' && expr_lt t s && expr_lt v s' &&
       pure_atom_gt1 (Eqv s t) pos && pure_atom_gt1 (Eqv s' v) pos' &&
       pure_atom_gt (Eqv s t) (Eqv s' v) &&
       greater_than_all s0 neg && greater_than_all s'0 neg'
    then mkPureClause
      (merge pure_atom_cmp neg neg')
      (insu_atm (norm_pure_atom (Eqv t v)) (merge pure_atom_cmp pos pos')) :: l0
    else l0
  | _, _, _ => l0
  end.

(** Retractive rules:
    -demodulation (simplification by positive unit clauses),
    -equality resolution *)

(* u[s->t] *)
Definition rewrite_expr s t u := if expr_eq s u then t else u.

Definition rewrite_by s t atm :=
  match atm with Eqv u v =>
    if expr_eq s u then if expr_eq s v then norm_pure_atom (Eqv t t)
                        else norm_pure_atom (Eqv t v)
    else if expr_eq s v then norm_pure_atom (Eqv u t)
         else atm
  end.

Definition rewrite_in_space s t atm :=
  match atm with
  | Next u v => Next (rewrite_expr s t u) (rewrite_expr s t v)
  | Lseg u v => Lseg (rewrite_expr s t u) (rewrite_expr s t v)
  end.

Definition rewrite_clause_in_space c atm :=
  match c with
  | PureClause nil [Eqv s t] _ _ => rewrite_in_space s t atm
  | _ => atm
  end.

(** Rewrite by a positive unit clause *)

Definition demodulate (c d : clause) : clause :=
  match c, d with
  | PureClause nil [Eqv s t] _ _, PureClause neg pos _ _ =>
      mkPureClause (map (rewrite_by s t) neg) (map (rewrite_by s t) pos)
  | PureClause nil [Eqv s t] _ _, PosSpaceClause neg pos space =>
      PosSpaceClause (map (rewrite_by s t) neg) (map (rewrite_by s t) pos)
          (map (rewrite_in_space s t) space)
  | PureClause nil [Eqv s t] _ _, NegSpaceClause neg space pos =>
      NegSpaceClause (map (rewrite_by s t) neg) (map (rewrite_in_space s t) space)
          (map (rewrite_by s t) pos)
  | _, _ => d
  end.

(** Delete resolved negative atoms, i.e., atoms of the form [Eqv x x]
    lying in negative positions.  This is called equality resolution by some. *)

Definition delete_resolved (c : clause) : clause :=
  match c with
  | PureClause neg pos _ _ =>
     mkPureClause (sortu_atms (remove_trivial_atoms neg)) (sortu_atms pos)
  | _ => c
(*  | _ => mkPureClause nil [Eqv Nil Nil] (* impossible *)*)
  end.

(** Filter tautological clauses *)

Definition not_taut (c: clause) :=
  negb (match c with
        | PureClause neg pos _ _ =>
          existsb (fun a => existsb (fun b =>
                     pure_atom_eq a b) pos) neg ||
          existsb (fun a =>
            match a with Eqv e1 e2 => expr_eq e1 e2 end) pos
        | _ => false end).

(** Rewrite [c] by positive unit clauses in [l]. Delete resolved atoms
    from the resulting clause. Argument [l] is already sorted so no need to
    re-sort. *)

Definition simplify (l : list clause) (c : clause) : clause :=
  delete_resolved (fold_left (fun d c => demodulate c d) l c).

Definition simplify_atoms (l : list clause) (atms : list space_atom)
  : list space_atom :=
  fold_left (fun atms d => map (rewrite_clause_in_space d) atms) l atms.

(** Derive clauses from clause [c] and clauses [l] using [cty] inferences alone.
    Forward-simplify any resulting clauses using facts in [l] (note: we do no
    backward simplification here since this would greatly complicate the termination
    proof). *)

Definition infer (cty : ce_type) (c : clause) (l : list clause) : list clause :=
  print_inferred_list (rsort_uniq compare_clause
    (filter not_taut (map (simplify nil)
      (ef cty c (fold_left (fun l0 d => sp cty c d l0) l nil))))).

(** Model generation: build a candidate model for clauses [l] *)

Definition apply_model (R : model) (cl : clause) : clause :=
  fold_right (fun ve => subst_clause (fst ve) (snd ve)) cl R.

Definition is_model_of (R : model) (gamma delta : list pure_atom) : bool :=
  match fold_right (fun ve => subst_pures_delete (fst ve) (snd ve))
               (remove_trivial_atoms gamma) R,
          fold_right (fun ve => subst_pures (fst ve) (snd ve)) delta R with
  | _::_, _ => true
  | nil , delta' => negb (forallb nonreflex_atom delta')
  end.

(** Check whether R is a model of [Pi+ /\ Pi-]; used in the Veristar main loop *)

Definition is_model_of_PI (R: model) (nc : (*negative spatial*) clause) : bool :=
 match nc with NegSpaceClause pi_plus _ pi_minus =>
  match fold_right (fun ve =>
          subst_pures_delete (fst ve) (snd ve)) (remove_trivial_atoms pi_plus) R,
        fold_right (fun ve =>
          subst_pures (fst ve) (snd ve)) pi_minus R with
  | nil , pi_minus' => forallb nonreflex_atom pi_minus'
  | _ :: _ , _ => false
  end
 | _ => false
 end.

(** Is there a rewrite rule [v'->r] in [R] s.t. [v==v']? *)

Definition reduces (R: model) (v : var) :=
  existsb (fun ve' => if Ident.eq_dec v (fst ve') then true else false) R.

(** Does clause [cl] generate a new rewrite rule that must be added to the
    candidate model [R]? If so, return the rewrite rule paired with [cl]. Otherwise
    [cl] is a c-example for the current candidate model (invariant: [clause_generate
    R cl] is only called when [R] is [not] already a model for [cl]) so determine which
    type of c-example [cl] is, and return that as a value of [ce_type]. *)

Definition clause_generate (R : model) (cl : clause)
  : (var * expr * clause) + ce_type :=
  match cl with
  | PureClause gamma (Eqv (Var l' as l) r :: delta) _ _ as c' =>
      if greater_than_expr l' r && greater_than_all l' gamma &&
         greater_than_atoms (Eqv l r) delta
      then if reduces R l' then inr _ CexpR
           else if is_model_of (List.rev R) nil (map (rewrite_by l r) delta)
                then inr _ CexpEf else inl _ (l', r, cl)
      else inr _ CexpL
  | _ => inr _ CexpL
  end.

(** Construct a candidate model for [l] or fail with (1) the partial model built
    so far (for debugging); (2) the clause that failed; and (3) its [ce_type]. *)

Fixpoint partial_mod (R : model) (acc l : list clause)
  : (model * list clause) + (model * clause * ce_type) :=
  match l with
  | nil => inl _ (R, acc)
  | (PureClause gamma delta _ _) as cl :: l' =>
      if is_model_of (List.rev R) gamma delta then partial_mod R acc l'
      else match clause_generate R cl with
           | (inl (v, exp, cl')) => partial_mod ((v, exp) :: R) (cl' :: acc) l'
           | (inr cty) => inr _ (print_ce_clause R cl cty)
           end
  | _ => inl _ (R, acc)
  end.

Definition is_empty_clause (cl : clause) :=
  match cl with PureClause nil nil _ _ => true | _ => false end.

Definition is_unit_clause (cl : clause) :=
  match cl with PureClause nil (a :: nil) _ _ => true | _ => false end.

Lemma Ppred_decrease n : (n<>1)%positive -> (nat_of_P (Ppred n)<nat_of_P n)%nat.
Proof.
intros; destruct (Psucc_pred n) as [Hpred | Hpred]; try contradiction;
pattern n at 2; rewrite <- Hpred; rewrite nat_of_P_succ_morphism; omega.
Defined.

Require Import Recdef.

(* begin show *)

(** The Superpose main loop *)

Function main (n : positive) (units l : list clause) {measure nat_of_P n}
  : superposition_result * list clause * M.t*M.t :=
  if Coqlib.peq n 1 then (Aborted l, units, M.empty, M.empty)
  else if existsb is_empty_clause (map delete_resolved l)
       then (Valid, units, M.empty, M.empty)
       else match partition is_unit_clause l with (us, rs) =>
              let us' := cclose us in
              let l' := filter not_taut (map (simplify
                                (print_eqs_list us')) rs) in
                match partial_mod nil nil l' with
                | inl (R, selected) =>
                  (C_example R (clause_list2set selected), cclose (us'++units),
                      clause_list2set l', M.empty)
                | inr (R, cl, cty) =>
                  let r := infer cty cl l' in
                    main (Ppred n) (cclose (us'++units))
                         (print_pures_list
                           (rsort (rev_cmp compare_clause2) (r ++ l')))
                end
            end.
Proof. intros; apply Ppred_decrease; auto. Defined.

(* end show *)

(** Convert a pure entailment to clausal-nf *)

Definition purecnf (en: entailment) : M.t :=
  match en with
    Entailment (Assertion pureL spaceL) (Assertion pureR spaceR) =>
    match mk_pureR pureL, mk_pureR pureR with (p, n), (p', n') =>
      let pureplus :=
        map (fun a => mkPureClause nil (norm_pure_atom a::nil)) p in
      let pureminus :=
        map (fun a => mkPureClause (norm_pure_atom a::nil) nil) n in
      let pureplus' := rsort_uniq pure_atom_cmp (map norm_pure_atom p') in
      let pureminus' := rsort_uniq pure_atom_cmp (map norm_pure_atom n') in
      let cl := mkPureClause pureplus' pureminus' in
        clause_list2set (cl :: pureplus ++ pureminus)
    end
  end.

Definition check (ent : entailment)
  : superposition_result * list clause * M.t*M.t :=
  main 1000000 nil (print_pures_list
    (rsort (rev_cmp compare_clause2) (M.elements (purecnf ent)))).

Definition check_clauseset (s : M.t)
  : superposition_result * list clause * M.t*M.t :=
  main 1000000 nil (print_pures_list
    (rsort (rev_cmp compare_clause2) (M.elements (M.filter not_taut s)))).

End Superposition.


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 G Aprime Aprimeprime Bprime Cprime Bprimeprime Bprimeprimeprime : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Bprime A /\ (wd_ Bprime C /\ (wd_ Aprime B /\ (wd_ Aprime C /\ (wd_ Cprime A /\ (wd_ Cprime B /\ (wd_ Aprimeprime Bprimeprime /\ (wd_ Aprime Bprimeprimeprime /\ (wd_ Aprime Bprime /\ (wd_ Bprime Bprimeprimeprime /\ (wd_ G Aprime /\ (wd_ G Aprimeprime /\ (wd_ G Bprimeprime /\ (wd_ Aprime Bprimeprime /\ (wd_ Bprimeprime Bprimeprimeprime /\ (wd_ G Bprimeprimeprime /\ (wd_ Aprime Aprimeprime /\ (wd_ B G /\ (wd_ Bprimeprime B /\ (wd_ A G /\ (wd_ Aprimeprime A /\ (col_ Aprime Bprime Bprimeprimeprime /\ (col_ G Bprimeprime Bprimeprimeprime /\ (col_ Bprimeprime B G /\ (col_ Cprime A B /\ (col_ Bprime A C /\ (col_ G Aprime Aprimeprime /\ (col_ Aprimeprime A G /\ (col_ Aprime B C /\ col_ Aprime Bprimeprime Aprime)))))))))))))))))))))))))))))))) -> col_ A Aprimeprime Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.