Require Import VST.floyd.proofauto.
Require Import sha.SHA256.
Require Import sha.spec_sha.
Require Import sha.sha.
Require Export sha.pure_lemmas.
Require Export sha.general_lemmas.
Require Export sha.vst_lemmas.
Export ListNotations.

Local Open Scope logic.

Global Opaque K256.

Transparent peq.

Lemma mapsto_tc_val:
  forall sh t p v,
  readable_share sh ->
  v <> Vundef ->
  mapsto sh t p v = !! tc_val t v && mapsto sh t p v .
Proof.
intros.
apply pred_ext; [ | normalize].
apply andp_right; auto.
unfold mapsto; simpl.
destruct (access_mode t); try apply FF_left.
destruct (attr_volatile (attr_of_type t)); try apply FF_left.
destruct p; try apply FF_left.
if_tac; try contradiction. apply orp_left.
normalize.
normalize.
Qed.

Fixpoint loops (s: statement) : list statement :=
 match s with
  | Ssequence a b => loops a ++ loops b
  | Sloop _ _ => [s]
  | Sifthenelse _ a b => loops a ++ loops b
  | _ => nil
  end.

Lemma big_endian_integer_bytelist:
   forall bl, Zlength bl = 4->
  bytelist_to_intlist bl = big_endian_integer bl :: nil.
Proof.
intros.
destruct bl as [| a [|b [|c [|d [|]]]]]; inv H.
2: rewrite ?Zlength_cons in H1; list_solve.
unfold big_endian_integer, bytes_to_Int.
simpl.
f_equal.
f_equal.
rewrite <- ?Int.or_shl.
f_equal.
rewrite ?Int.shl_shl by reflexivity.
autorewrite with norm.
simpl.
change (Int.shl (Int.shl Int.zero (Int.repr 8))
        (Int.repr 24)) with Int.zero.
rewrite Int.or_zero_l.
rewrite ?Int.shl_shl by reflexivity.
reflexivity.
Qed.

Lemma nth_big_endian_integer:
  forall i bl w,
   nth_error bl i = Some w ->
    w = big_endian_integer
                   (sublist (Z.of_nat i * WORD)
                        (Z.succ (Z.of_nat i) * WORD)
                   (intlist_to_bytelist bl)).
Proof.
intros.
change WORD with 4.
assert (nth_error bl i <> None) by congruence.
rewrite nth_error_Some in H0.
match goal with |- ?A = ?B => assert (A::nil = B::nil) end;
 [ | congruence].
rewrite <- big_endian_integer_bytelist.
2:{
rewrite Zlength_sublist; try omega.
rewrite (Zlength_intlist_to_bytelist bl).
rewrite Zlength_correct.
omega.
}
unfold sublist.
replace (Z.to_nat (Z.of_nat i * 4)) with (4 * i)%nat.
2:{ rewrite Z2Nat.inj_mul by omega.
     rewrite Nat2Z.id. simpl. omega.
}
rewrite skipn_intlist_to_bytelist.
replace (Z.to_nat
        (Z.succ (Z.of_nat i) * 4 -
         Z.of_nat i * 4)) with (4*1)%nat.
2:{ unfold Z.succ. replace ((Z.of_nat i + 1) * 4 - Z.of_nat i * 4) with 4 by omega. reflexivity.
}
rewrite firstn_intlist_to_bytelist.
rewrite intlist_to_bytelist_to_intlist.
clear H0.
revert bl H; induction i; destruct bl; simpl; intros; inv H; auto.
rewrite (IHi _ H1). reflexivity.
Qed.

Lemma Znth_big_endian_integer:
  forall i bl,
   0 <= i < Zlength bl ->
   Znth i bl =
     big_endian_integer
                   (sublist (i * WORD) (Z.succ i * WORD)
                   (intlist_to_bytelist bl)).
Proof.
intros.
unfold Znth.
 rewrite if_false by omega.
pose proof (nth_error_nth _ Int.zero (Z.to_nat i) bl).
rewrite <- (Z2Nat.id i) at 2 3 by omega.
apply nth_big_endian_integer.
apply H0.
apply Nat2Z.inj_lt.
rewrite Z2Nat.id by omega.
rewrite <- Zlength_correct; omega.
Qed.

Fixpoint sequence (cs: list statement) s :=
 match cs with
 | nil => s
 | c::cs' => Ssequence c (sequence cs' s)
 end.

Fixpoint rsequence (cs: list statement) s :=
 match cs with
 | nil => s
 | c::cs' => Ssequence (rsequence cs' s) c
 end.

Lemma sequence_rsequence:
 forall Espec CS Delta P cs s0 s R,
    @semax CS Espec Delta P (Ssequence s0 (sequence cs s)) R  <->
  @semax CS Espec Delta P (Ssequence (rsequence (rev cs) s0) s) R.
Proof.
intros.
revert Delta P R s0 s; induction cs; intros.
simpl. apply iff_refl.
simpl.
rewrite seq_assoc.
rewrite IHcs; clear IHcs.
replace (rsequence (rev cs ++ [a]) s0) with
    (rsequence (rev cs) (Ssequence s0 a)); [apply iff_refl | ].
revert s0 a; induction (rev cs); simpl; intros; auto.
rewrite IHl. auto.
Qed.

Lemma seq_assocN:
  forall {Espec: OracleKind} CS,
   forall Q Delta P cs s R,
        @semax CS Espec Delta P (sequence cs Sskip) (normal_ret_assert Q) ->
         @semax CS Espec
       Delta  Q s R ->
        @semax CS Espec Delta P (sequence cs s) R.
Proof.
intros.
rewrite semax_skip_seq.
rewrite sequence_rsequence.
rewrite semax_skip_seq in H.
rewrite sequence_rsequence in H.
rewrite <- semax_seq_skip in H.
eapply semax_seq'; [apply H | ].
eapply semax_extensionality_Delta; try apply H0.
clear.
apply tycontext_sub_refl.
Qed.

Fixpoint sequenceN (n: nat) (s: statement) : list statement :=
 match n, s with
 | S n', Ssequence a s' => a::sequenceN n' s'
 | _, _ => nil
 end.

Require Import JMeq.

Lemma reptype_tarray {cs: compspecs}:
   forall t len, reptype (tarray t len) = list (reptype t).
Proof.
intros.
rewrite reptype_eq. simpl. reflexivity.
Qed.

Local Open Scope nat.

(*** Application of Omega stuff ***)

Lemma CBLOCKz_eq : CBLOCKz = 64%Z.
Proof. reflexivity. Qed.
Lemma LBLOCKz_eq : LBLOCKz = 16%Z.
Proof. reflexivity. Qed.
Lemma WORD_eq: WORD = 4%Z.
Proof. reflexivity. Qed.

Hint Rewrite CBLOCKz_eq LBLOCKz_eq WORD_eq : rep_omega.

(*
Ltac helper2 :=
 match goal with
   | |- context [CBLOCK] => add_nonredundant (CBLOCK_eq)
   | |- context [LBLOCK] => add_nonredundant (LBLOCK_eq)
   | |- context [CBLOCKz] => add_nonredundant (CBLOCKz_eq)
   | |- context [LBLOCKz] => add_nonredundant (LBLOCKz_eq)
   | H: context [CBLOCK] |- _ => add_nonredundant (CBLOCK_eq)
   | H: context [LBLOCK] |- _ => add_nonredundant (LBLOCK_eq)
   | H: context [CBLOCKz] |- _ => add_nonredundant (CBLOCKz_eq)
   | H: context [LBLOCKz] |- _ => add_nonredundant (LBLOCKz_eq)
  end.

Ltac Omega1 := Omega (helper1 || helper2).
*)
Ltac Omega1 := rep_omega.

Ltac MyOmega :=
  rewrite ?length_list_repeat, ?skipn_length, ?map_length,
   ?Zlength_map, ?Zlength_nil;
  pose proof CBLOCK_eq;
(*  pose proof CBLOCKz_eq;*)
  pose proof LBLOCK_eq;
(*  pose proof LBLOCKz_eq; *)
  Omega1.
(*** End Omega stuff ***)

Local Open Scope Z.

Local Open Scope logic.

Lemma sizeof_tarray_tuchar:
 forall (n:Z), (n>=0)%Z -> (sizeof (tarray tuchar n) =  n)%Z.
Proof. intros.
 unfold sizeof,tarray; cbv beta iota.
  rewrite Z.max_r by omega.
  unfold alignof, tuchar; cbv beta iota.
  rewrite Z.mul_1_l. auto.
Qed.

Lemma Zlength_bytelist_to_intlist:
  forall (n:Z) (l: list byte),
   (Zlength l = WORD*n)%Z -> Zlength (bytelist_to_intlist l) = n.
Proof.
intros.
rewrite Zlength_correct in *.
rewrite (length_bytelist_to_intlist (Z.to_nat n)); rep_omega.
Qed.

Lemma nth_intlist_to_bytelist_eq:
 forall d (n i j k: nat) al, (i < n)%nat -> (i < j*4)%nat -> (i < k*4)%nat ->
    nth i (intlist_to_bytelist (firstn j al)) d = nth i (intlist_to_bytelist (firstn k al)) d.
Proof.
 induction n; destruct i,al,j,k; simpl; intros; auto; try omega.
 destruct i; auto. destruct i; auto. destruct i; auto.
 apply IHn; omega.
Qed.

Global Opaque WORD.

Lemma S256abs_data:
  forall hashed data,
   (LBLOCKz | Zlength hashed) ->
   Zlength data < CBLOCKz ->
   s256a_data (S256abs hashed data) = data.
Proof.
intros. unfold S256abs, s256a_data.
rewrite Zlength_app.
rewrite Zlength_intlist_to_bytelist.
destruct H as [n ?].
rewrite H.
assert (CBLOCKz > 0) by rep_omega.
pose proof (Zmod_eq (n * CBLOCKz + Zlength data) CBLOCKz H1).
pose proof (Zmod_eq (Zlength data) CBLOCKz H1).
rewrite sublist_app2; rewrite Zlength_intlist_to_bytelist; rewrite H;
 rewrite <- Z.mul_assoc; change (LBLOCKz * 4)%Z with CBLOCKz.
apply sublist_same.
rewrite Z.div_add_l by omega.
rewrite Z.mul_add_distr_r.
rewrite Z.div_small by rep_omega. omega.
omega.
rewrite Z.div_add_l by  omega.
rewrite Z.mul_add_distr_r.
rewrite Z.div_small by rep_omega.
split; [ | omega].
apply Z.mul_nonneg_nonneg.
clear - H.
assert (n < 0 \/ 0 <= n) by omega.
destruct H0; auto.
assert (n * LBLOCKz < 0).
apply Z.mul_neg_pos; auto.
rep_omega.
omega.
Qed.

Lemma S256abs_hashed:
  forall hashed data,
   (LBLOCKz | Zlength hashed) ->
   Zlength data < CBLOCKz ->
   s256a_hashed (S256abs hashed data) = hashed.
Proof.
intros;  unfold S256abs, s256a_hashed.
rewrite Zlength_app.
rewrite Zlength_intlist_to_bytelist.
destruct H as [n ?].
assert (CBLOCKz > 0) by (rewrite CBLOCKz_eq; omega).
pose proof (Zmod_eq (n * CBLOCKz + Zlength data) CBLOCKz H1).
pose proof (Zmod_eq (Zlength data) CBLOCKz H1).
pose proof (Zlength_nonneg data).
rewrite sublist_app1; rewrite ?Zlength_intlist_to_bytelist;
  rewrite H.
rewrite sublist_same; try omega.
apply intlist_to_bytelist_to_intlist.
rewrite Zlength_intlist_to_bytelist.
  rewrite H.
rewrite <- Z.mul_assoc; change (LBLOCKz*4)%Z with CBLOCKz.
rewrite Z.div_add_l by omega.
rewrite Z.mul_add_distr_r.
rewrite Z.div_small by omega.  omega.
split; [omega | ].
rewrite <- Z.mul_assoc; change (LBLOCKz*4)%Z with CBLOCKz.
rewrite Z.div_add_l by omega.
rewrite Z.mul_add_distr_r.
rewrite Z.div_small by omega.
clear - H.
assert (n < 0 \/ 0 <= n) by omega.
simpl.
destruct H0.
pose proof (Zlength_nonneg hashed).
assert (n * LBLOCKz < 0).
apply Z.mul_neg_pos; auto.
omega.
rewrite Z.add_0_r.
apply Z.mul_nonneg_nonneg; auto.
rewrite <- Z.mul_assoc; change (LBLOCKz*4)%Z with CBLOCKz.
rewrite Z.div_add_l by omega.
rewrite Z.mul_add_distr_r.
rewrite Z.div_small by omega.  omega.
Qed.

Lemma s256a_hashed_divides:
  forall a, (LBLOCKz | Zlength (s256a_hashed a)).
Proof.
intros. unfold s256a_hashed.
exists (Zlength a / CBLOCKz)%Z.
erewrite Zlength_bytelist_to_intlist; [reflexivity |].
rewrite Zlength_sublist.
rewrite (Z.mul_comm WORD).
rewrite <- Z.mul_assoc.
change (LBLOCKz * WORD)%Z with CBLOCKz.
omega.
split; [ omega  |] .
apply Z.mul_nonneg_nonneg; auto.
apply Z.div_pos.
apply Zlength_nonneg.
rewrite CBLOCKz_eq; omega.
assert (CBLOCKz > 0) by (rewrite CBLOCKz_eq; omega).
pose proof (Zmod_eq (Zlength a) CBLOCKz H).
pose proof (Z_mod_lt (Zlength a) CBLOCKz H).
omega.
Qed.

Lemma s256a_data_len:
  forall a: s256abs,
  Zlength (s256a_data a) = Zlength a mod CBLOCKz.
Proof.
intros.
unfold s256a_data.
assert (CBLOCKz > 0) by (rewrite CBLOCKz_eq; omega).
pose proof (Zmod_eq (Zlength a) CBLOCKz H).
pose proof (Z_mod_lt (Zlength a) CBLOCKz H).
rewrite H0.
rewrite Zlength_sublist; try omega.
split; try omega.
apply Z.mul_nonneg_nonneg.
apply Z.div_pos.
apply Zlength_nonneg.
omega. omega.
Qed.

Lemma s256a_data_Zlength_less:
  forall a, Zlength (s256a_data a) < CBLOCKz.
Proof.
intros.
rewrite s256a_data_len.
apply Z_mod_lt.
rewrite CBLOCKz_eq; omega.
Qed.

Lemma hashed_data_recombine:
  forall a,
    intlist_to_bytelist (s256a_hashed a) ++ s256a_data a = a.
Proof.
intros.
unfold s256a_hashed, s256a_data.
assert (CBLOCKz > 0) by (rewrite CBLOCKz_eq; omega).
rewrite bytelist_to_intlist_to_bytelist.
rewrite sublist_rejoin.
autorewrite with sublist. auto.
split; [ omega  |] .
apply Z.mul_nonneg_nonneg; auto.
apply Z.div_pos.
apply Zlength_nonneg.
rewrite CBLOCKz_eq; omega.
assert (CBLOCKz > 0) by (rewrite CBLOCKz_eq; omega).
pose proof (Zmod_eq (Zlength a) CBLOCKz H).
pose proof (Z_mod_lt (Zlength a) CBLOCKz H).
omega.
rewrite Zlength_sublist.
rewrite Z.sub_0_r.
apply Z.divide_mul_r.
exists LBLOCKz. reflexivity.
split; [ omega  |] .
apply Z.mul_nonneg_nonneg; auto.
apply Z.div_pos.
apply Zlength_nonneg.
omega.
pose proof (Zmod_eq (Zlength a) CBLOCKz H).
pose proof (Z_mod_lt (Zlength a) CBLOCKz H).
omega.
Qed.

Definition bitlength (hashed: list int) (data: list byte) : Z :=
   ((Zlength hashed * WORD + Zlength data) * 8)%Z.

Lemma bitlength_eq:
  forall hashed data,
  bitlength hashed data = s256a_len (S256abs hashed data).
Proof.
intros.
unfold bitlength, s256a_len, S256abs.
rewrite Zlength_app.
rewrite Zlength_intlist_to_bytelist.
reflexivity.
Qed.

Lemma S256abs_recombine:
 forall a,
    S256abs (s256a_hashed a) (s256a_data a) = a.
Proof.
intros.
apply hashed_data_recombine; auto.
Qed.

Lemma bytelist_to_intlist_app:
  forall a b,
  (WORD | Zlength a) ->
   bytelist_to_intlist (a++b) = bytelist_to_intlist a ++ bytelist_to_intlist b.
Proof.
intros.
destruct H as [na H].
rewrite <- (Z2Nat.id na) in H.
2:{
destruct (zlt na 0); try omega.
assert (na * WORD < 0); [apply Z.mul_neg_pos; auto | ].
pose proof (Zlength_nonneg a); omega.
}
revert a H; induction (Z.to_nat na); intros.
simpl in H. destruct a. simpl. auto. rewrite Zlength_cons in H.
pose proof (Zlength_nonneg a); omega.
rewrite inj_S in H.
unfold Z.succ in H. rewrite Z.mul_add_distr_r in H.
change (1*WORD)%Z with 4 in H.
assert (Zlength a >= 4).
assert (0 <= Z.of_nat n * WORD); [ | omega].
apply Z.mul_nonneg_nonneg; try omega.
change WORD with 4%Z; omega.
do 4 (destruct a; [rewrite Zlength_nil in H0; omega | rewrite Zlength_cons in H,H0  ]).
simpl.
do 4 f_equal. apply IHn.
omega.
Qed.

Lemma round_range:
 forall {A} (a: list A) (N:Z),
  N > 0 ->
   0 <= Zlength a / N * N <= Zlength a.
Proof.
intros.
split.
apply Z.mul_nonneg_nonneg; auto; try omega.
apply Z.div_pos; try omega.
apply Zlength_nonneg.
pose proof (Zmod_eq (Zlength a) N H).
pose proof (Z_mod_lt (Zlength a) N H).
omega.
Qed.

Lemma CBLOCKz_gt: CBLOCKz > 0.
Proof. rewrite CBLOCKz_eq; omega.
Qed.

Lemma bytelist_to_intlist_inj:
  forall a b,
   (WORD | Zlength a) ->
   (WORD | Zlength b) ->
   bytelist_to_intlist a = bytelist_to_intlist b ->
   a=b.
Proof.
intros.
rewrite <- (bytelist_to_intlist_to_bytelist a) by auto.
rewrite H1.
apply bytelist_to_intlist_to_bytelist; auto.
Qed.

Definition update_abs (incr: list byte) (a: list byte) (a': list byte) :=
    a' = a ++ incr.

Lemma update_abs_eq:
  forall msg a a',
 (update_abs msg a a' <->
  exists blocks,
    s256a_hashed a' = s256a_hashed a ++ blocks /\
    s256a_data a ++ msg = intlist_to_bytelist blocks ++ s256a_data a').
Proof.
intros. pose proof I.
unfold update_abs.
assert (0 <= 0 <= Zlength a / CBLOCKz * CBLOCKz). {
 split; [omega | ].
 apply Z.mul_nonneg_nonneg.
 apply Z.div_pos.
 apply Zlength_nonneg.
 rewrite CBLOCKz_eq; omega.
 rewrite CBLOCKz_eq; omega.
}
pose proof (round_range a _ CBLOCKz_gt).
pose proof (round_range (a++msg) _ CBLOCKz_gt).
split; intro.
*
subst a'.
unfold s256a_hashed.
exists (bytelist_to_intlist
            (sublist (Zlength a / CBLOCKz * CBLOCKz) (Zlength (a++msg) / CBLOCKz * CBLOCKz)
                  (a++msg))).
split.
 +
 rewrite (sublist_split 0 (Zlength a / CBLOCKz * CBLOCKz)); auto.
 rewrite bytelist_to_intlist_app.
 f_equal.
 rewrite sublist_app1; auto. omega.
 rewrite Zlength_sublist; auto.
 rewrite Z.sub_0_r.
 apply Z.divide_mul_r.
 exists LBLOCKz; reflexivity.
 rewrite Zlength_app.
 pose proof (Zlength_nonneg msg); omega.
 split; [ | apply round_range; apply CBLOCKz_gt].
 apply Zmult_le_compat_r; [ | rewrite CBLOCKz_eq; omega].
 apply Z.div_le_mono; [rewrite CBLOCKz_eq; omega| ].
 rewrite Zlength_app; Omega1.
 +
 rewrite bytelist_to_intlist_to_bytelist.
 2:{ rewrite Zlength_sublist. rewrite <- Z.mul_sub_distr_r.
 apply Z.divide_mul_r.
 exists LBLOCKz; reflexivity.
 split; [Omega1 | ].
 apply Zmult_le_compat_r; [ | rewrite CBLOCKz_eq; omega].
 apply Z.div_le_mono; [rewrite CBLOCKz_eq; omega| ].
 rewrite Zlength_app; Omega1.
 apply round_range. apply CBLOCKz_gt.
 }
 unfold s256a_data.
 destruct (zlt   (Zlength (a ++ msg) / CBLOCKz * CBLOCKz) (Zlength a) ).
  -
   rewrite sublist_app1; try omega.
   rewrite (sublist_split (Zlength (a ++ msg) / CBLOCKz * CBLOCKz)
               (Zlength a) (Zlength (a ++ msg))); try omega.
   rewrite sublist_app1; try omega.
   rewrite sublist_app2 by omega.
   autorewrite with sublist.
   rewrite (sublist_same 0) by omega.
   rewrite <- app_ass. f_equal.
   rewrite sublist_rejoin; try omega. auto.
   split. apply round_range; apply CBLOCKz_gt.
 apply Zmult_le_compat_r; [ | rewrite CBLOCKz_eq; omega].
 apply Z.div_le_mono; [rewrite CBLOCKz_eq; omega| ].
  Omega1.
  rewrite Zlength_app in l; omega.
  rewrite Zlength_app; Omega1.
   split. apply round_range; apply CBLOCKz_gt.
 apply Zmult_le_compat_r; [ | rewrite CBLOCKz_eq; omega].
 apply Z.div_le_mono; [rewrite CBLOCKz_eq; omega| ].
  rewrite Zlength_app; Omega1.
 -
   rewrite (sublist_split (Zlength a / CBLOCKz * CBLOCKz) (Zlength a)
                  (Zlength (a ++ msg) / CBLOCKz * CBLOCKz) ); auto.
   rewrite app_ass.
   rewrite sublist_app1; try omega.
   rewrite sublist_app2; try omega.
   rewrite Z.sub_diag.
   f_equal.
   rewrite sublist_app2; try omega.
   rewrite sublist_rejoin.
   autorewrite with sublist. auto.
   omega.
  split; try omega. rewrite Zlength_app; Omega1.
   omega.
*
destruct H3 as [blocks [? ?]].
match type of H3 with ?A = ?B =>
  assert (Zlength A * WORD = Zlength B * WORD)%Z by congruence
end.
match type of H4 with ?A = ?B =>
  assert (sublist 0 (Zlength a / CBLOCKz * CBLOCKz) a ++ A =
              sublist 0 (Zlength a / CBLOCKz * CBLOCKz) a ++ B) by congruence
end.
unfold s256a_hashed, s256a_data in *.
rewrite <- app_ass in H6.
rewrite sublist_rejoin in H6 by omega.
rewrite sublist_same in H6 by omega.
rewrite H6.
clear H6 H4.
rewrite <- (sublist_same 0 (Zlength a') a') at 1; auto.
rewrite <- app_ass.
rewrite (sublist_split 0 (Zlength a' / CBLOCKz * CBLOCKz) (Zlength a')); try omega.
f_equal.
apply bytelist_to_intlist_inj.
rewrite Zlength_sublist.
 rewrite Z.sub_0_r.
 apply Z.divide_mul_r.
 exists LBLOCKz; reflexivity.
 split; [clear; omega | ].
 apply Z.mul_nonneg_nonneg; [ | rewrite CBLOCKz_eq; omega].
 apply Z.div_pos; [ | rewrite CBLOCKz_eq; omega].
 apply Zlength_nonneg.
 apply round_range; apply CBLOCKz_gt.
 rewrite Zlength_app.
 apply Z.divide_add_r.
rewrite Zlength_sublist.
 rewrite Z.sub_0_r.
 apply Z.divide_mul_r.
 exists LBLOCKz; reflexivity.
 split; [clear; omega | ].
 apply Z.mul_nonneg_nonneg; [ | rewrite CBLOCKz_eq; omega].
 apply Z.div_pos; [ | rewrite CBLOCKz_eq; omega].
 apply Zlength_nonneg.
 apply round_range; apply CBLOCKz_gt.
 exists (Zlength blocks).
 apply Zlength_intlist_to_bytelist.
 rewrite H3.
 rewrite bytelist_to_intlist_app. f_equal.
 symmetry; apply intlist_to_bytelist_to_intlist.
rewrite Zlength_sublist.
 rewrite Z.sub_0_r.
 apply Z.divide_mul_r.
 exists LBLOCKz; reflexivity.
 auto.
 omega.
 split; [clear; omega |].
 apply round_range; apply CBLOCKz_gt.
 split; [ | clear; omega].
 apply round_range; apply CBLOCKz_gt.
Qed.

Lemma array_at_memory_block:
 forall {cs: compspecs} sh t gfs lo hi v p n,
  sizeof (nested_field_array_type t gfs lo hi) = n ->
  lo <= hi ->
  array_at sh t gfs lo hi v p |--
  memory_block sh n (field_address0 t (ArraySubsc lo :: gfs) p).
Proof.
intros.
rewrite  array_at_data_at by auto.
normalize.
unfold at_offset.
rewrite field_address0_offset by auto.
subst n.
apply data_at_memory_block.
Qed.

Hint Extern 2 (array_at _ _ _ _ _ _ _ |-- memory_block _ _ _) =>
   (apply array_at_memory_block; try reflexivity; try omega) : cancel.


Require Import Coq.Lists.List.
Require Import Coq.Strings.Ascii.
Require Import Coq.Strings.String.
Require Import MetaCoq.Template.TemplateMonad.Extractable.
Require Import MetaCoq.Template.Loader.
Require Import MetaCoq.Template.Ast.
Require Import ExtLib.Structures.Monad.
Import MonadNotation.
Local Open Scope string_scope.

Require Import seal.seal.

Module __seal.

  Local Definition q_eq := <% @eq %>.
  Local Definition q_eq_refl := <% @eq_refl %>.
  Local Definition q_opaque := <% @_opaque %>.
  Local Definition q_seal := <% @_seal %>.
  Local Definition q_opaque_ind : inductive :=
    ltac:(lazymatch eval red in q_opaque with
          | tInd ?t _ => exact t
          | _ => fail "_opaque is not an inductive?"
          end).

  Local Fixpoint string_rev (pre s : string) : string :=
    match s with
    | EmptyString => pre
    | String s ss => string_rev (String s pre) ss
    end.

  Local Fixpoint get_base (pre nm : string) : TM string :=
    match nm with
    | EmptyString => tmFail "the name must end with _def"
    | "_def" => tmReturn (string_rev "" pre)
    | String "."%char ss => get_base "" ss
    | String "#"%char ss => get_base "" ss
    | String s ss => get_base (String s pre) ss
    end.

  Instance Monad_TM : Monad TM :=
    { ret := @tmReturn
    ; bind := @tmBind }.

  Local Definition mk_sealed (name : string) (type def : Ast.term) : TM kername :=
    tmOpaqueDefinition name None
      (tApp q_seal (type :: def :: def :: tApp q_eq_refl (type :: def :: nil) :: nil)).

  Local Definition mk_eq (name base_kn : string) (type def sealed : Ast.term) : TM kername :=
    tmDefinition name
                 (Some (tApp q_eq (type :: def :: tConst base_kn nil :: nil)))
                 (tProj ((q_opaque_ind, 2), 1) sealed).

  Definition generate (def : Ast.term) : TM _ :=
    match def with
    | tConst kn ui =>
      base <- get_base "" kn ;;
      cnst <- tmQuoteConstant kn false ;;
      match cnst with
      | ParameterEntry p => tmFail "parameter, already opaque"
      | DefinitionEntry d =>
        let body := d.(definition_entry_body) in
        let type := d.(definition_entry_type) in
        sealed_kn <- mk_sealed (base ++ "_seal")%string type body ;;
        let sealed := tConst sealed_kn nil in
        base_kn <- tmDefinition base None (tProj ((q_opaque_ind, 2), 0) sealed) ;;
        mk_eq (base ++ "_eq")%string base_kn type def sealed ;;
        tmMsg ("sealed [" ++ base ++ "] as [" ++ base ++ "_seal] with equation [" ++ base ++ "_eq]")%string
      end
    | _ => tmFail "not a constant"
    end%monad.

End __seal.

Definition seal' := __seal.generate.

Notation "'seal' x" := ltac:(let p y := exact (seal' y) in quote_term x p)
   (at level 200, x at level 0, only parsing).


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import String.
Require Import List.
Require Import Sumbool.
Require Import Arith.
Require Import Bool.
Require Import EquivDec.
Require Import Assoc.
Require Import Bindings.
Require Import SortingAdd.
Require Import CoqLibAdd.
Require Import ForeignEJson.
Require Import EJson.

Section EJsonNorm.
  Context {foreign_ejson_model:Set}.
  Context {fejson:foreign_ejson foreign_ejson_model}.

  Fixpoint normalize_ejson (d:ejson) : ejson :=
    match d with
    | ejobject rl => ejobject (rec_sort (map (fun x => (fst x, normalize_ejson (snd x))) rl))
    | ejarray l => ejarray (map normalize_ejson l)
    | ejforeign fd => ejforeign (foreign_ejson_normalize fd)
    | _ => d
    end.

  Inductive ejson_normalized : ejson -> Prop :=
  | ejnnull :
      ejson_normalized ejnull
  | ejnnumber n :
      ejson_normalized (ejnumber n)
  | ejnbigint n :
      ejson_normalized (ejbigint n)
  | ejnbool b :
      ejson_normalized (ejbool b)
  | ejnstring s :
      ejson_normalized (ejstring s)
  | ejnarray dl :
      Forall (fun x => ejson_normalized x) dl -> ejson_normalized (ejarray dl)
  | ejnobject dl :
      Forall (fun d => ejson_normalized (snd d)) dl ->
      (is_list_sorted ODT_lt_dec (domain dl) = true) ->
      ejson_normalized (ejobject dl)
  | ejnforeign fd :
      foreign_ejson_normalized fd ->
      ejson_normalized (ejforeign fd).

  Theorem ejson_normalize_normalizes :
    forall (d:ejson), ejson_normalized (normalize_ejson d).
  Proof.
    induction d using ejsonInd2; simpl.
    - apply ejnnull.
    - apply ejnnumber.
    - apply ejnbigint.
    - apply ejnbool.
    - apply ejnstring.
    - apply ejnarray.
      apply Forall_forall; intros.
      induction c; elim H0; intros.
      rewrite <- H1.
      apply (H a); left; reflexivity.
      assert (forall x:ejson, In x c -> ejson_normalized (normalize_ejson x))
        by (intros; apply (H x0); right; assumption).
      specialize (IHc H2 H1).
      assumption.
    - apply ejnobject.
      + apply Forall_sorted.
        apply Forall_forall; intros.
        induction r.
        contradiction.
        simpl in *.
        elim H0; intros; clear H0.
        rewrite <- H1.
        simpl.
        apply (H (fst a) (snd a)).
        left; destruct a; reflexivity.
        assert (forall (x : string) (y : ejson),
                   In (x, y) r -> ejson_normalized (normalize_ejson y)); intros.
        apply (H x0 y); right; assumption.
        apply (IHr H0).
        assumption.
      + apply (@rec_sort_sorted string ODT_string) with (l1 := (map (fun x : string * ejson => (fst x, normalize_ejson (snd x))) r)).
        reflexivity.
    - constructor.
      apply foreign_ejson_normalize_normalizes.
  Qed.

  Theorem ejson_normalize_normalized_eq {d}:
    ejson_normalized d ->
    normalize_ejson d = d.
  Proof.
    induction d using ejsonInd2; simpl; trivial.
    - intros.
      rewrite (@map_eq _ _ normalize_ejson id).
      + rewrite map_id; trivial.
      + inversion H0; simpl; subst.
        revert H2. apply Forall_impl_in.
        auto.
    - intros.
      inversion H0; subst.
      rewrite (@map_eq _ _ (fun x : string * ejson => (fst x, normalize_ejson (snd x))) id).
      + rewrite map_id.
        rewrite rec_sorted_id; trivial.
      + revert H2. apply Forall_impl_in.
        destruct a; unfold id; simpl; intros.
        f_equal; eauto.
    - inversion 1; subst.
      f_equal.
      apply foreign_ejson_normalize_idempotent.
      trivial.
  Qed.

  Lemma ejson_map_normalize_normalized_eq c :
    Forall (fun x => ejson_normalized (snd x)) c ->
    (map
       (fun x0 : string * ejson => (fst x0, normalize_ejson (snd x0)))
       c) = c.
  Proof.
    induction c; simpl; trivial.
    destruct a; inversion 1; simpl in *; subst.
    rewrite ejson_normalize_normalized_eq; trivial.
    rewrite IHc; trivial.
  Qed.

  Corollary ejson_normalize_idem d :
    normalize_ejson (normalize_ejson d) = normalize_ejson d.
  Proof.
    apply ejson_normalize_normalized_eq.
    apply ejson_normalize_normalizes.
  Qed.

  Corollary normalize_ejson_eq_normalized {d} :
    normalize_ejson d = d -> ejson_normalized d.
  Proof.
    intros.
    generalize (ejson_normalize_normalizes d).
    congruence.
  Qed.

  Theorem normalized_ejson_dec d : {ejson_normalized d} + {~ ejson_normalized d}.
  Proof.
    destruct (normalize_ejson d == d); unfold equiv, complement in *.
    - left. apply normalize_ejson_eq_normalized; trivial.
    - right. intro dn; elim c. apply ejson_normalize_normalized_eq; trivial.
  Defined.

  Lemma ejson_normalized_jarray a l :
    (ejson_normalized a /\ ejson_normalized (ejarray l)) <->
    ejson_normalized (ejarray (a :: l)).
  Proof.
    split.
    - destruct 1 as [d1 d2]. inversion d2; subst.
      constructor; auto.
    - inversion 1; subst. inversion H1; subst.
      split; trivial.
      constructor; auto.
  Qed.

  Lemma ejson_normalized_rec_sort_app l1 l2 :
    ejson_normalized (ejobject l1) ->
    ejson_normalized (ejobject l2) ->
    ejson_normalized (ejobject (rec_sort (l1 ++ l2))).
  Proof.
    inversion 1; inversion 1; subst.
    constructor; eauto 1 with qcert.
    apply Forall_sorted.
    apply Forall_app; trivial.
  Qed.

  Lemma ejson_normalized_rec_concat_sort l1 l2 :
    ejson_normalized (ejobject l1) ->
    ejson_normalized (ejobject l2) ->
    ejson_normalized (ejobject (rec_concat_sort l1 l2)).
  Proof.
    apply ejson_normalized_rec_sort_app.
  Qed.

  Lemma ejson_normalized_jarray_in x l :
    In x l ->
    ejson_normalized (ejarray l) ->
    ejson_normalized x.
  Proof.
    inversion 2; subst.
    rewrite Forall_forall in H2.
    eauto.
  Qed.

  Lemma ejnobject_nil : ejson_normalized (ejobject nil).
  Proof.
    econstructor; trivial.
  Qed.

  Lemma ejnobject_sort_content c :
    Forall (fun d : string * ejson => ejson_normalized (snd d)) c ->
    Forall (fun d : string * ejson => ejson_normalized (snd d)) (rec_sort c).
  Proof.
    intros F.
    apply Forall_sorted; trivial.
  Qed.

  Lemma ejnobject_sort c :
    Forall (fun d : string * ejson => ejson_normalized (snd d)) c ->
    ejson_normalized (ejobject (rec_sort c)).
  Proof.
    intros F; econstructor; trivial with qcert.
    apply Forall_sorted; trivial.
  Qed.

  Lemma ejson_normalized_jarray_Forall l :
    ejson_normalized (ejarray l) <-> Forall ejson_normalized l.
  Proof.
    split; intros H.
    - invcs H; trivial.
    - constructor; trivial.
  Qed.

End EJsonNorm.


(** This file provides an efficient proof search strategy
   for our derivation system defined in [Sat]. *)
Require Import Containers.Sets.
Require Import Env Sat.
Require Import SetoidList.
Require Import Arith.
Require Import FoldProps.

Fact belim : forall b, b = false -> b = true -> False.
Proof. congruence. Qed.

(** * The functor [SATSTRATEGY] *)
Module SATCAML
  (Import CNF : Cnf.CNF)
  (Import E : ENV_INTERFACE CNF).

  (** We start by importing some efinitions from the SAT functor. *)
  Module Import S := SAT CNF E.
  Module SemF := S.SemF.
  Definition submodel_e G (M : Sem.model) := forall l, G |= l -> M l.
  Definition compatible_e G (D : cset) :=
    forall (M : Sem.model), submodel_e G M -> Sem.sat_goal M D.

  Notation "G |- D" := (mk_sequent G D) (at level 80).

  (** Relating lists of literals to clauses, and lists of lists of literals
     to sets of clauses (the reverse of [elements]). *)
  Fixpoint l2s (l : list L.t) : clause :=
    match l with
      | nil => {}
      | a::q => {a; l2s q}
    end.
  Fixpoint ll2s (l : list (list L.t)) : cset :=
    match l with
      | nil => {}
      | a::q => {l2s a; ll2s q}
    end.

  Property l2s_iff : forall l C, l \In l2s C <-> InA _eq l C.
  Proof.
    intros; induction C; simpl.
    intuition.
    split; simpl; intro H.
    rewrite add_iff in H; destruct H; intuition.
    rewrite add_iff; inversion H; intuition.
  Qed.

  Property ll2s_app : forall l l', ll2s (app l l') [=] ll2s l ++ ll2s l'.
  Proof.
    induction l; intros l'; simpl.
    intro k; set_iff; intuition.
    rewrite IHl, Props.union_add; reflexivity.
  Qed.
  Property ll2s_cfl : forall ll, cfl ll [=] ll2s ll.
  Proof.
    induction ll; rewrite cfl_1; simpl.
    reflexivity.
    apply add_m; auto. rewrite cfl_1 in IHll; exact IHll.
  Qed.
  Property l2s_Subset :
    forall C C', (forall l, InA _eq l C -> InA _eq l C') <-> l2s C [<=] l2s C'.
  Proof.
    intros C C'; split; intros H k.
    rewrite !l2s_iff; auto.
    rewrite <- !l2s_iff; auto.
  Qed.

  Lemma ll2s_expand : forall (M : Sem.model) l, M l ->
    forall C, C \In ll2s (L.expand l) -> Sem.sat_clause M C.
  Proof.
    intros M l Hl C HC.
    assert (HM := Sem.wf_expand M l Hl).
    set (L := L.expand l) in *; clearbody L; clear l Hl.
    revert L HC HM; induction L; intros; simpl in  *.
    contradiction (empty_1 HC).
    rewrite add_iff in HC; destruct HC as [HC|HC].

    destruct (HM a (or_introl _ (refl_equal _))) as [k [Hk1 Hk2]].
    clear HM; exists k; split; auto.
    assert (Hk := ListIn_In Hk1); rewrite <- l2s_iff, HC in Hk; auto.

    apply (IHL HC); intuition.
  Qed.

  (** Facts about measures of lists of (lists of) literals *)
  Property lsize_pos : forall l, l <> nil -> L.lsize l > 0.
  Proof.
    induction l; intros; simpl; auto.
    congruence.
    generalize (L.size_pos a); omega.
  Qed.
  Property llsize_app :
    forall l l', L.llsize (app l l') = L.llsize l + L.llsize l'.
  Proof.
    induction l; simpl; intros; intuition.
    generalize (IHl l'); omega.
  Qed.

  (** ** Functions computing the BCP

     The following functions compute the proof search in a way that is similar
     to the OCaml procedure in [JFLA08]. We perform all possible binary
     constraint propagation (BCP) before we start splitting on literals. *)

  (** The first function reduces a clause with respect to a partial
     assignment. It returns [redNone] if the clause contains a literal
     that is true in the assignment, and the reduced clause in the
     other case (with a flag telling if the function has changed anything). *)
  Section Reduce.
    Variable G : E.t.
    Variable D : cset.

    Inductive redRes : Type :=
    | redSome : list L.t -> bool -> redRes
    | redNone : redRes.

    Fixpoint reduce (C : list L.t) : redRes :=
      match C with
        | nil => redSome nil false
        | l::C' =>
          if query l G then redNone
            else
            match reduce C' with
              | redNone => redNone
              | redSome Cred b =>
                if query (L.mk_not l) G then
                  redSome Cred true
                  else redSome (l::Cred) b
            end
      end.

    Inductive reduce_spec_ (C : list L.t) : redRes -> Type :=
    | reduce_redSome :
      forall Cred (bred : bool)
        (HCred : Cred = List.filter (fun l => negb (query (L.mk_not l) G)) C)
        (Hsub : forall l, List.In l Cred -> query l G = false)
        (Hbred : if bred then L.lsize Cred < L.lsize C else C = Cred),
        reduce_spec_ C (redSome Cred bred)
    | reduce_redNone :
      forall l (Hl : query l G = true) (Hin : List.In l C),
        reduce_spec_ C redNone.
    Theorem reduce_spec : forall C, reduce_spec_ C (reduce C).
    Proof.
      induction C; simpl.
      constructor; auto; intros; contradiction.
      case_eq (query a G); intro Hq.
      constructor 2 with a; intuition.
      destruct IHC; simpl.
      case_eq (query (L.mk_not a) G); intro Hnq.
      constructor; auto; simpl.
      rewrite Hnq; simpl; auto.
      generalize (L.size_pos a); destruct bred; try rewrite Hbred; omega.
      constructor.
      simpl; rewrite Hnq; simpl; congruence.
      intros l Hl; inversion Hl; subst; eauto.
      destruct bred; try congruence; simpl; omega.
      constructor 2 with l; intuition.
    Qed.

    Unset Regular Subst Tactic.

    Corollary reduce_correct : forall C Cred bred,
      reduce C = redSome Cred bred -> derivable (G |- {l2s Cred; D}) ->
      derivable (G |- {l2s C; D}).
    Proof.
      intros C Cred bred Hred Hder;
        destruct (reduce_spec C); inversion Hred; subst.
      set (reds := filter (fun l : L.t => query (L.mk_not l) G) (l2s C)).
      assert (M : Proper (_eq ==> @eq bool) (fun l => query (L.mk_not l) G))
        by (eauto with typeclass_instances).
      apply ARed with reds (l2s C).

      unfold reds; intros k Hk; apply (filter_2 Hk).
      unfold reds; intros k Hk; apply (filter_1 Hk).
      apply add_1; auto.
      assert (E : l2s Cred [=] l2s C \ reds).
      rewrite <- H0; unfold reds; revert M; clear; intro M; induction C; simpl.
      intuition.
      case_eq (query (L.mk_not a) G); intro Ha; simpl.
      rewrite IHC, EProps.filter_add_1; auto.
      intro k; set_iff; intuition.
      apply H1; apply filter_3; auto; rewrite <- H2; assumption.
      rewrite IHC, EProps.filter_add_2; auto.
      intro k; set_iff; intuition.
      rewrite H0 in Ha; rewrite (filter_2 H) in Ha; discriminate.
      rewrite <- E; refine (weakening _ Hder _ _); split; simpl; intuition.
    Qed.
(*     Corollary reduce_complete : forall C Cred bred M, *)
(*       reduce C = redSome Cred bred ->  *)
(*       submodel_e G M -> Sem.sat_clause M (l2s C) -> Sem.sat_clause M (l2s Cred). *)
(*     Proof. *)
(*       intros C Cred bred M Hred Hsub;  *)
(*         destruct (reduce_spec C); inversion Hred; subst. *)
(*       intros [l Hsatl]; exists l; intuition. *)
(*       rewrite <- H0; revert H H1 Hsub; clear; induction C; simpl; auto; intros. *)
(*       rewrite add_iff in H1; destruct H1. *)
(*       case_eq (query (L.mk_not a) G); intro Hq; simpl. *)
(*       contradiction (SemF.model_em M l H). *)
(*       apply Hsub; rewrite <- H0; auto. *)
(*       apply add_1; auto. *)
(*       destruct (negb (query (L.mk_not a) G)); [apply add_2 |]; *)
(*         exact (IHC H H0 Hsub). *)
(*     Qed. *)
    Corollary reduce_complete : forall C Cred bred M,
      reduce C = redSome Cred bred ->
      submodel_e G M -> Sem.sat_clause M (l2s Cred) ->
      Sem.sat_clause M (l2s C).
    Proof.
      intros C Cred bred M Hred Hsub;
        destruct (reduce_spec C); inversion Hred; subst.
      intros [l Hsatl]; exists l; intuition.
      rewrite <- H0 in H1; revert H H1 Hsub; clear;
        induction C; simpl; auto; intros.
      destruct (query (L.mk_not a) G); simpl in *.
      apply add_2; apply IHC; auto.
      rewrite add_iff in H1; destruct H1; [apply add_1 | apply add_2]; auto.
    Qed.

  End Reduce.

  (** The second function simplifies a set of clauses  with respect
     to a partial assignment. It returns [bcpNone] if one of the clauses
     reduced to the empty clause. Otherwise, it returns the set of
     simplified clauses along with a new partial assignment. Indeed,
     if simplification yields a unitary clause, [AAssume] is
     immediately applied and the literal is added to the partial
     assignment for the rest of the simplification. Again, we return
     a flag saying if the function has simplified anything or not.
     *)
  Section BCP.
    Inductive bcpRes : Type :=
    | bcpSome : E.t -> list (list L.t) -> bool -> bcpRes
    | bcpNone : bcpRes.

    Definition extend l s := app (L.expand l) s.
    Fixpoint bcp (G : E.t) (D : list (list L.t)) : bcpRes :=
      match D with
        | nil => bcpSome G nil false
        | C::D' =>
          match reduce G C with
            | redNone =>
              match bcp G D' with
                | bcpNone => bcpNone
                | bcpSome G' D' _ => bcpSome G' D' true
              end
            | redSome nil bred => bcpNone
            | redSome (l::nil) _ =>
              match assume l G with
                | Normal newG =>
                  match bcp newG D' with
                    | bcpNone => bcpNone
                    | bcpSome G' D' _ => bcpSome G' (extend l D') true
                  end
                | Inconsistent => bcpNone
              end
            | redSome Cred bred =>
              match bcp G D' with
                | bcpNone => bcpNone
                | bcpSome G' D' b =>
                  bcpSome G' (Cred::D') (bred || b)
              end
          end
      end.

    Lemma weak_assume :
      forall (G : t) (D : cset) (l : L.t),
        singleton l \In D -> ~ G |= l ->
        forall newG, assume l G = Normal newG ->
        derivable (newG |- cfl (L.expand l) ++ D) ->
        derivable (G |- D).
    Proof.
      intros G0 D0 l Hl HGl G1 Hass1 Hder.
      case_eq (query (L.mk_not l) G0); intro Hquery.
      (* - if [L.mk_not l] is entailed by [G0] then
         we can reduce [{l}] and apply [AConflict]. *)
      apply ARed with (reds:={l}) (C:={l}); intuition.
      rewrite <- (singleton_1 H); assumption.
      apply AConflict; apply add_1; intro k; set_iff; intuition.
      (* - otherwise, we first [AUnsat] with [l], the left branch
         is our hypothesis and we reduce and apply [AConflict] on
         the right. *)
      case_eq (assume (L.mk_not l) G0); [intros G2 Hass2 | intros Hass2].
      apply (AUnsat G0 D0 l G1 G2 Hass1 Hass2 Hder).
      apply ARed with (reds:={l}) (C:={l}).
      intro k; set_iff; intro Hk; apply query_assumed;
        rewrite (assumed_assume Hass2); apply add_1; rewrite Hk; auto.
      reflexivity.
      apply union_3; auto.
      apply AConflict; apply add_1; intro k; set_iff; intuition.
      contradiction HGl; rewrite <- (L.mk_not_invol l);
        apply assumed_inconsistent; assumption.
    Qed.

    Theorem bcp_correct :
      forall D Dbasis G Gext Dred b,
        bcp G D = bcpSome Gext Dred b ->
        derivable (Gext |- ll2s Dred ++ Dbasis) ->
        derivable (G |- ll2s D ++ Dbasis).
    Proof with (eauto with typeclass_instances).
      intro D0; induction D0; intros Dbasis G0 Gext Dred b Hbcp Hder;
        simpl in Hbcp.
      inversion Hbcp; subst; simpl in Hder; inversion Hder; eauto with set.
      assert (Hred := reduce_correct G0 (ll2s D0 ++ Dbasis) a).
      assert (Hred' := reduce_spec G0 a).
      destruct (reduce G0 a) as [ared bred|].
      (* - if the reduction returned a clause (it can't be empty) *)
      destruct ared as [|l ared]; try discriminate.
      inversion Hred'; subst; destruct ared.
      (* - if it is a singleton [{l}], [l] is consistent with [G0] and
         we can apply [AAssume] *)
      assert (Hl' : ~ (G0 |= l)) by
        (intro abs; rewrite (Hsub l (or_introl _ (refl_equal _))) in abs;
          discriminate).
      case_eq (assume l G0); [intros newG Hass | intros Hass];
        rewrite Hass in Hbcp.
      simpl; rewrite Props.union_add.
      apply (Hred (l::nil) bred (refl_equal _)); clear Hred.
      assert (IH := IHD0 (cfl (L.expand l) ++ Dbasis) newG); clear IHD0.
      destruct (bcp newG D0) as [Gext' Dred' b'|];
        try discriminate; inversion Hbcp.
      assert (IH' := IH Gext' Dred' b' (refl_equal _)); clear IH; subst.
      assert (Hl : Equal (l2s (l::nil)) {l})
        by (simpl; symmetry; apply Props.singleton_equal_add).
      destruct (In_dec (ll2s D0 ++ Dbasis) {l}).
      refine (weak_assume G0 _ l (add_1 _ _) Hl' _ Hass _)...
      rewrite Props.add_equal.
      2:(simpl; rewrite <- Props.singleton_equal_add; exact Htrue).
      rewrite <- Props.union_assoc.
      rewrite (Props.union_sym (cfl (L.expand l)) (ll2s D0)).
      rewrite Props.union_assoc; apply IH'.
      unfold extend in Hder; rewrite ll2s_app in Hder.
      rewrite ll2s_cfl, <- Props.union_assoc,
        (Props.union_sym (ll2s Dred')); exact Hder.
      refine (AAssume G0 _ l (add_1 _ _) _ Hass _)...
      rewrite Hl, Props.remove_add; auto.
      rewrite <- Props.union_assoc.
      rewrite (Props.union_sym (cfl (L.expand l)) (ll2s D0)).
      rewrite Props.union_assoc; apply IH'.
      unfold extend in Hder; rewrite ll2s_app in Hder.
      rewrite ll2s_cfl, <- Props.union_assoc,
        (Props.union_sym (ll2s Dred')); exact Hder.
      assert (Z : List.In l (l::nil)) by (left; auto).
      assert (Hnotl : ~ (G0 |= L.mk_not l)).
      rewrite HCred, filter_In in Z; destruct (query (L.mk_not l) G0);
        auto; destruct Z; discriminate.
      contradiction (Hnotl (assumed_inconsistent Hass)).
      (* - if the reduced clause is not unitary *)
      simpl; rewrite Props.union_add.
      apply (Hred _ _ (refl_equal _)).
      set (Cred := l::t0::ared) in *; clearbody Cred.
      assert (IH := IHD0 {l2s Cred; Dbasis} G0); clear IHD0.
      destruct (bcp G0 D0) as [Gext' Dred' b'|];
        try discriminate; inversion Hbcp.
      assert (IH' := IH Gext' Dred' b' (refl_equal _)); clear IH; subst.
      rewrite Props.union_sym, <- Props.union_add, Props.union_sym.
      apply IH'.
      rewrite Props.union_sym, Props.union_add,
        Props.union_sym, <- Props.union_add; exact Hder.
      (* - if the clause was eliminated *)
      assert (IH := fun D => IHD0 D G0).
      destruct (bcp G0 D0); inversion Hbcp; subst.
      refine (weakening _ (IH _ _ _ _ (refl_equal _) Hder) _ _).
      split; simpl; try rewrite Props.union_add; intuition.
    Qed.

    Theorem bcp_unsat :
      forall D Dbasis G, bcp G D = bcpNone -> derivable (G |- ll2s D ++ Dbasis).
    Proof with (eauto with typeclass_instances).
      intro D0; induction D0; intros Dbasis G0 Hbcp; simpl in Hbcp.
      discriminate.
      assert (Hred := reduce_correct G0 (ll2s D0 ++ Dbasis) a).
      destruct (reduce_spec G0 a).
      (* - if the clause reduced to the empty clause, we apply [AConflict] *)
      simpl; rewrite Props.union_add.
      destruct Cred as [|l Cred].
      apply (Hred nil bred (refl_equal _)).
      apply AConflict; apply add_1; reflexivity.
      destruct Cred.
      (* - if the clause is a singleton [{l}], [G0] must be
         consistent with [l] *)
      assert (Z : List.In l (l::nil)) by (left; auto).
      assert (Hnotl : ~ (G0 |= L.mk_not l)).
      rewrite HCred, filter_In in Z; destruct (query (L.mk_not l) G0);
        auto; destruct Z; discriminate.
      assert (Hl' : ~ (G0 |= l)) by
        (intro abs; rewrite (Hsub l (or_introl _ (refl_equal _))) in abs;
          discriminate).
      clear Z; apply (Hred (l::nil) bred (refl_equal _)).
      case_eq (assume l G0); [intros newG Hass | intros Hass];
        rewrite Hass in Hbcp.
      2:(contradiction (Hnotl (assumed_inconsistent Hass))).
      assert (IH := IHD0 (ll2s (L.expand l) ++ Dbasis) newG);
        clear IHD0.
      destruct (bcp newG D0); try discriminate.
      simpl; rewrite <- Props.singleton_equal_add.
      assert (Hl : Equal (l2s (l::nil)) {l})
        by (simpl; symmetry; apply Props.singleton_equal_add).
      destruct (In_dec (ll2s D0 ++ Dbasis) {l}).
      refine (weak_assume G0 _ l (add_1 _ _) Hl' _ Hass _)...
      rewrite Props.add_equal; auto.
      rewrite <- Props.union_assoc.
      rewrite (Props.union_sym (cfl (L.expand l)) (ll2s D0)).
      rewrite Props.union_assoc, ll2s_cfl; exact (IH (refl_equal _)).
      refine (AAssume G0 _ l (add_1 _ _) _ Hass _)...
      rewrite Props.remove_add; auto.
      rewrite <- Props.union_assoc.
      rewrite (Props.union_sym (cfl (L.expand l)) (ll2s D0)).
      rewrite Props.union_assoc, ll2s_cfl; exact (IH (refl_equal _)).
      (* if the clause is not unitary after reduction *)
      assert (IH := IHD0 Dbasis G0); clear IHD0.
      destruct (bcp G0 D0); try discriminate.
      apply (Hred _ _ (refl_equal _)).
      refine (weakening _ (IH (refl_equal _)) _ _).
      split; simpl; intuition.
      (* if the clause was eliminated *)
      assert (IH := IHD0 Dbasis G0); clear IHD0.
      destruct (bcp G0 D0); try discriminate.
      refine (weakening _ (IH (refl_equal _)) _ _).
      split; simpl; intuition; rewrite Props.union_add; intuition.
    Qed.

    Theorem bcp_progress :
      forall D G Gext Dred b,
        bcp G D = bcpSome Gext Dred b ->
        if b then L.llsize Dred < L.llsize D else Gext = G /\ Dred = D.
    Proof.
      intro D0; induction D0; intros G0 Gext Dred b Hbcp; simpl in Hbcp.
      inversion Hbcp; subst; split; reflexivity.
      destruct (reduce_spec G0 a).
      destruct Cred; try discriminate.
      destruct Cred.
      case_eq (assume t0 G0); [intros newG Hass | intros Hass];
        rewrite Hass in Hbcp; try discriminate.
      assert (IH := IHD0 newG).
      destruct (bcp newG D0); inversion Hbcp; subst.
      assert (IH' := IH _ _ _ (refl_equal _)); destruct b0.
      unfold extend; simpl; rewrite llsize_app.
      destruct bred; subst; simpl in *; generalize (L.size_expand t0); omega.
      destruct IH'; subst; unfold extend; simpl; rewrite llsize_app.
      destruct bred; subst; simpl in *; generalize (L.size_expand t0); omega.
      assert (IH := IHD0 G0).
      destruct (bcp G0 D0); inversion Hbcp; subst.
      destruct bred; simpl.
      assert (IH' := IH _ _ _ (refl_equal _)); destruct b0; simpl in *.
      omega. rewrite (proj2 IH'); omega.
      assert (IH' := IH _ _ _ (refl_equal _)); destruct b0; simpl in *.
      rewrite Hbred; simpl; omega.
      destruct IH'; split; congruence.
      assert (IH := IHD0 G0).
      destruct (bcp G0 D0); inversion Hbcp; subst.
      assert (IH' := IH _ _ _ (refl_equal _)); destruct b0; simpl.
      omega.
      rewrite (proj2 IH'); revert Hin; clear; induction a; simpl.
      contradiction. generalize (L.size_pos a); intuition.
    Qed.

    Theorem bcp_consistent :
      forall D G Gext Dred,
        bcp G D = bcpSome Gext Dred false ->
        forall l C, C \In ll2s Dred -> l \In C ->
          ~ Gext |= l /\ ~ Gext |= L.mk_not l.
    Proof.
      intros D0 G0 Gext Dred Hbcp l C HC Hl.
      assert (Hprog := bcp_progress D0 G0 _ _ _ Hbcp).
      destruct Hprog; subst.
      revert G0 l C Hl HC Hbcp; induction D0; intros; simpl in Hbcp.
      simpl in HC; contradiction (empty_1 HC).
      destruct (reduce_spec G0 a).
      destruct Cred; try discriminate.
      destruct Cred.
      case_eq (assume t0 G0); [intros newG Hass | intros Hass];
        rewrite Hass in Hbcp; try discriminate.
      destruct (bcp newG D0); discriminate.
      assert (IH := IHD0 G0 l); clear IHD0.
      destruct (bcp G0 D0); inversion Hbcp; subst.
      destruct bred; simpl in H3; try discriminate.
      set (Z := t0 :: t1 :: Cred) in *; clearbody Z.
      simpl in HC; rewrite add_iff in HC; destruct HC.
      rewrite <- H in Hl; rewrite l2s_iff in Hl.
      rewrite InA_alt in Hl; destruct Hl as [k [Hk1 Hk2]].
      split; intro abs.
      assert (Hk := Hsub k Hk2); rewrite <- Hk1 in Hk; congruence.
      rewrite HCred in Hk2; rewrite filter_In in Hk2.
      rewrite Hk1 in abs; destruct (query (L.mk_not k) G0);
        destruct Hk2; discriminate.
      clear HCred; subst; eauto.
      destruct (bcp G0 D0); inversion Hbcp; subst.
    Qed.

    Lemma bcp_monotonic_env :
      forall D G Gext Dred b,
        bcp G D = bcpSome Gext Dred b -> dom G [<=] dom Gext.
    Proof.
      intro D0; induction D0; intros G0 Gext Dred b Hbcp;
        simpl in Hbcp.
      inversion Hbcp; subst; simpl; reflexivity.
      destruct (reduce G0 a) as [Cred bred|].
      destruct Cred as [|l Cred]; try discriminate.
      destruct Cred.
      case_eq (assume l G0); [intros newG Hass | intros Hass];
        rewrite Hass in Hbcp; try discriminate.
      assert (IH := IHD0 newG).
      destruct (bcp newG D0); inversion Hbcp; subst.
      transitivity (dom newG).
      rewrite (assumed_assume Hass); intuition.
      exact (IH _ _ _ (refl_equal _)).
      assert (IH := IHD0 G0).
      destruct (bcp G0 D0); inversion Hbcp; subst.
      exact (IH _ _ _ (refl_equal _)).
      assert (IH := IHD0 G0).
      destruct (bcp G0 D0); inversion Hbcp; subst.
      exact (IH _ _ _ (refl_equal _)).
    Qed.

(*     Theorem bcp_complete :  *)
(*       forall D Dbasis G Gext Dred b, *)
(*         bcp G D = bcpSome Gext Dred b -> *)
(*         compatible_e G (ll2s D ++ Dbasis) ->  *)
(*         compatible_e Gext (ll2s Dred ++ Dbasis). *)
(*     Proof. *)
(*       intro D0; induction D0; intros Dbasis G0 Gext Dred b Hbcp Hsat; *)
(*         simpl in Hbcp. *)
(*       inversion Hbcp; subst; simpl; exact Hsat. *)
(*       assert (Hred := reduce_complete G0 a). *)
(*       destruct (reduce G0 a) as [Cred bred|]. *)
(*       destruct Cred as [|l Cred]; try discriminate. *)
(*       destruct Cred. *)

(*       assert (Hmon := bcp_monotonic_env D0 (assume l G0)). *)
(*       assert (IH := IHD0 (ll2s (L.expand l) ++ Dbasis) (assume l G0)); *)
(*         clear IHD0; destruct (bcp (assume l G0) D0); inversion Hbcp; subst. *)
(*       assert (IH' := IH _ _ _ (refl_equal _)); clear IH. *)
(*       intros M HM C HC; unfold extend in HC;  *)
(*         simpl in HC; rewrite ll2s_app in HC. *)
(*       rewrite (Props.union_sym _ (ll2s l0)), Props.union_assoc in HC. *)
(*       revert M HM C HC; apply IH'. *)
(*       intros M HM C HC; unfold extend in HC; simpl in HC;  *)
(*         rewrite (Props.union_sym (ll2s D0)),  Props.union_assoc in HC. *)
(*       rewrite union_iff in HC; destruct HC. *)
(*       apply ll2s_expand with l; auto; apply HM; apply EnvF.query_assume; auto. *)
(*       apply Hsat; auto. *)
(*       intros k Hk; apply HM; apply query_monotonic with G0; auto. *)
(*       rewrite assumed_assume; intuition. *)
(*       simpl; rewrite Props.union_add, Props.union_sym; apply add_2; auto. *)

(*       assert (Hmon := bcp_monotonic_env D0 G0). *)
(*       assert (IH := IHD0 Dbasis G0); *)
(*         clear IHD0; destruct (bcp G0 D0); inversion Hbcp; subst. *)
(*       assert (IH' := IH _ _ _ (refl_equal _)); clear IH. *)
(*       intros M HM C HC; simpl in HC; rewrite Props.union_add in HC. *)
(*       rewrite add_iff in HC; destruct HC. *)
(*       destruct (Hred _ _ M (refl_equal _)). *)
(*       intros k Hk; apply HM; apply query_monotonic with G0; auto; *)
(*         exact (Hmon _ _ _ (refl_equal _)). *)
(*       apply Hsat; [|simpl; apply union_2; apply add_1; auto]. *)
(*       intros k Hk; apply HM; apply query_monotonic with G0; auto; *)
(*         exact (Hmon _ _ _ (refl_equal _)). *)
(*       exists x; rewrite <- H; exact H0. *)
(*       apply IH'; auto; intros M' HM' C' HC'; apply Hsat; auto; *)
(*         simpl; rewrite Props.union_add; apply add_2; auto. *)

(*       assert (IH := IHD0 Dbasis G0); clear IHD0; destruct (bcp G0 D0); *)
(*         inversion Hbcp; subst. *)
(*       apply (IH Gext Dred b0 (refl_equal _)). *)
(*       intros M HM C HC; apply Hsat; auto. *)
(*       simpl; rewrite Props.union_add; apply add_2; exact HC. *)
(*     Qed. *)

    Theorem bcp_complete :
      forall D Dbasis G Gext Dred b M,
        bcp G D = bcpSome Gext Dred b ->
        submodel_e Gext M -> Sem.sat_goal M (ll2s Dred ++ Dbasis) ->
        submodel_e G M /\ Sem.sat_goal M (ll2s D ++ Dbasis).
    Proof.
      intro D0; induction D0; intros Dbasis G0 Gext Dred b M Hbcp Hsub Hsat;
        simpl in Hbcp.
      inversion Hbcp; subst; simpl; tauto.
      assert (Hred := reduce_spec G0 a).
      assert (Hred' := reduce_complete G0 a).
      destruct (reduce G0 a) as [Cred bred|].
      destruct Cred as [|l Cred]; try discriminate.
      destruct Cred.

      case_eq (assume l G0); [intros newG Hass | intros Hass];
        rewrite Hass in Hbcp; try discriminate.
      assert (IH := IHD0 (ll2s (L.expand l) ++ Dbasis) newG); clear IHD0.
      destruct (bcp newG D0) as [Gext' Dred' b'|];
        inversion Hbcp; subst.
      destruct (IH Gext Dred' b' M) as [IH1 IH2]; auto.
      intros C HC; apply Hsat; simpl; unfold extend;
        rewrite ll2s_app, (Props.union_sym _ (ll2s Dred')),
          Props.union_assoc; exact HC.
      split.
      intros k Hk; apply IH1; apply query_monotonic with G0; auto.
      rewrite (assumed_assume Hass); intuition.
      intros C HC; simpl in HC; rewrite Props.union_add, add_iff in HC;
        destruct HC as [HC|HC].
      destruct (Hred' _ _ M (refl_equal _)) as [k [Hk1 Hk2]].
      intros k Hk; apply IH1; apply query_monotonic with G0; auto.
      rewrite (assumed_assume Hass); intuition.
      simpl; exists l; simpl; split; intuition.
      apply IH1; apply (EnvF.query_assume Hass); auto.
      exists k; rewrite <- HC; tauto.
      apply IH2; revert HC; set_iff; clear; tauto.

      assert (IH := IHD0 Dbasis G0); clear IHD0.
      destruct (bcp G0 D0) as [Gext' Dred' b'|]; inversion Hbcp; subst.
      destruct (IH Gext Dred' b' M) as [IH1 IH2]; auto.
      intros C HC; apply Hsat; simpl; rewrite Props.union_add;
        apply add_2; auto.
      split; auto; intros C HC; simpl in HC;
        rewrite Props.union_add, add_iff in HC;
          destruct HC as [HC|HC].
      destruct (Hred' _ _ _ (refl_equal _) IH1) as [k [Hk1 Hk2]].
      apply Hsat; simpl; apply union_2; apply add_1; auto.
      exists k; rewrite <- HC; tauto.
      auto.

      assert (IH := IHD0 Dbasis G0); clear IHD0.
      destruct (bcp G0 D0); inversion Hbcp; subst.
      destruct (IH Gext Dred b0 M) as [IH1 IH2]; auto.
      split; auto; intros C HC; simpl in HC;
        rewrite Props.union_add, add_iff in HC; destruct HC as [HC|HC].
      inversion Hred; exists l; split.
      apply IH1; auto. rewrite <- HC, l2s_iff; exact (ListIn_In Hin).
      apply IH2; auto.
    Qed.

  End BCP.

  (** ** The main [proof_search] function *)
  (**  The [proof_search] function applies [bcp] repeatedly as long as
     progress has been made, and otherwise just picks a literal to split on. *)
  Inductive Res : Type :=
  | Sat : E.t -> Res
  | Unsat.
  Fixpoint proof_search (G : E.t) (D : list (list L.t))
    (n : nat) {struct n} : Res :=
    match n with
      | O => Sat empty (* assert false *)
      | S n0 =>
        match bcp G D with
          | bcpNone => Unsat
          | bcpSome newG newD b =>
            match newD with
              | nil => Sat newG
              | cons nil newD' => Unsat (* assert false *)
              | cons (cons l C) newD' =>
  (*   tant qu'on a progressé avec bcp, on reessaye *)
  (*   (si bcp etait recursive on n'aurait pas besoin de ça  *)
  (*    mais ca ne change rien en terme de performance ici) *)
                if b then proof_search newG newD n0
                else (* from that point on, G = newG, D = newD *)
                  match assume l G with
                    | Normal G1 =>
                      match proof_search G1 (extend l newD') n0 with
                        | Sat M => Sat M
                        | Unsat =>
                          let lbar := L.mk_not l in
                            match assume lbar G with
                              | Normal G2 =>
                                proof_search G2 (extend lbar (cons C newD')) n0
                              | Inconsistent => Unsat
                            end
                      end
                    | Inconsistent => Unsat
                  end
            end
        end
    end.

  Lemma expand_nonrec :
    forall l C, C \In (cfl (L.expand l)) -> l \In C -> False.
  Proof.
    intros l C; rewrite cfl_1.
    assert (Hsize := L.size_expand l).
    revert Hsize; generalize (L.expand l); intro L; induction L;
      intros Hsize H Hl; simpl in *.
    contradiction (empty_1 H).
    rewrite add_iff in H; destruct H.
    set (N := L.llsize L) in *; clearbody N; clear L IHL.
    rewrite <- H in Hl; clear H C; induction a.
    simpl in Hl; contradiction (empty_1 Hl).
    simpl in Hl; rewrite add_iff in Hl; destruct Hl.
    simpl in Hsize; rewrite H in Hsize; omega.
    simpl in Hsize; apply IHa; auto; omega.
    apply IHL; auto.
    revert Hsize; clear; induction a; simpl; auto.
    intro; omega.
  Qed.
  Lemma expand_nonrec_2 :
    forall l C, C \In (cfl (L.expand l)) -> L.mk_not l \In C -> False.
  Proof.
    intros l C; rewrite cfl_1.
    assert (Hsize := L.size_expand l).
    revert Hsize; generalize (L.expand l); intro L; induction L;
      intros Hsize H Hl; simpl in *.
    contradiction (empty_1 H).
    rewrite add_iff in H; destruct H.
    set (N := L.llsize L) in *; clearbody N; clear L IHL.
    rewrite <- H in Hl; clear H C; induction a.
    simpl in Hl; contradiction (empty_1 Hl).
    simpl in Hl; rewrite add_iff in Hl; destruct Hl.
    simpl in Hsize; rewrite H in Hsize; assert (Z := L.size_mk_not l); omega.
    simpl in Hsize; apply IHa; auto; omega.
    apply IHL; auto.
    revert Hsize; clear; induction a; simpl; auto.
    intro; omega.
  Qed.

  Property remove_transpose : forall (D : cset) (C C' : clause),
    {{D ~ C'} ~ C} [=] {{D ~ C} ~ C'}.
  Proof.
    intros; intro k; set_iff; intuition.
  Qed.
  Lemma remove_union : forall (D D' : cset) (C : clause),
    ~C \In D -> {(D ++ D') ~ C} [=] D ++ {D' ~ C}.
  Proof.
    intros; intro k; set_iff; intuition.
    intro abs; rewrite abs in H; tauto.
  Qed.
  Lemma union_remove : forall (D D' : cset) (C : clause),
    C \In D -> D ++ D' [=] D ++ {D' ~ C}.
  Proof.
    intros; intro k; set_iff; intuition.
    destruct (eq_dec C k); auto.
    rewrite H0 in H; left; auto.
  Qed.

(*   Lemma remove_singleton : forall l (A : clause),  *)
(*     singleton l \ A =/= singleton l -> singleton l \ A === {}. *)
(*   Proof. *)
(*     intros; intro k; split; set_iff; intuition. *)
(*     apply H; intro z; set_iff; intuition. *)
(*     rewrite <- H1 in H2; rewrite H0 in H2; tauto. *)
(*   Qed. *)
(*   Lemma diff_union : forall (A B C : clause), C \ (A ++ B) [=] C \ A \ B. *)
(*   Proof. *)
(*     intros; intro k; set_iff; intuition. *)
(*   Qed. *)

  Theorem proof_search_unsat :
    forall n G D, proof_search G D n = Unsat -> derivable (G |- ll2s D).
  Proof with (eauto with typeclass_instances).
    induction n; intros G0 D0; unfold proof_search.
    (* - if [D0] is empty, it is satisfiable *)
    intro abs; discriminate abs.
    (* - otherwise, we do a step of BCP *)
    fold proof_search; intro Hunsat.
    assert (Hbcp := bcp_correct D0 {} G0).
    assert (Hbcp2 := bcp_unsat D0 {} G0).
    assert (Hprogress := bcp_progress D0 G0).
    assert (Hcons := bcp_consistent D0 G0).
    destruct (bcp G0 D0) as [Gext Dred b|].
    (* -- if BCP returns a sequent, it can't be empty *)
    assert (Hbcp' := Hbcp Gext _ _ (refl_equal _)); clear Hbcp.
    rewrite !Props.empty_union_2 in Hbcp'; intuition.
    rewrite !Props.empty_union_2 in Hbcp2; intuition.
    (* -- if BCP returns a sequent, it can't be empty *)
    destruct Dred as [|C Dred]; try discriminate.
    destruct C as [|l C].
    (* -- if BCP returned a sequent with the empty clause, [AConflict] *)
    apply Hbcp'; simpl; apply AConflict; apply add_1; auto.
    destruct b; auto.
    (* -- if BCP didnt change anything... *)
    assert (Hcons' := Hcons Gext _ (refl_equal _)); clear Hcons.
    destruct (Hprogress _ _ _ (refl_equal _)); subst.
    simpl in Hcons'; destruct (Hcons' l {l; l2s C}) as [Hl Hnotl];
      try (simpl; apply add_1; reflexivity).
    case_eq (assume l G0); [intros G1 Hass1 | intros Hass1];
      rewrite Hass1 in Hunsat.
    2:(contradiction (Hnotl (assumed_inconsistent Hass1))).
    assert (IH1 := IHn G1 (extend l Dred)).
    (* -- the first recursive call must have return Unsat *)
    destruct (proof_search G1 (extend l Dred)); try discriminate.
    case_eq (assume (L.mk_not l) G0); [intros G2 Hass2 | intros Hass2];
      rewrite Hass2 in Hunsat.
    2:(rewrite <- (L.mk_not_invol l) in Hl;
      contradiction (Hl (assumed_inconsistent Hass2))).
    destruct (In_dec (ll2s Dred) (l2s (l :: C))).
    simpl; rewrite Props.add_equal; auto.
    apply AUnsat with l G1 G2; auto.
    unfold extend in IH1; rewrite ll2s_app in IH1.
    rewrite ll2s_cfl; exact (IH1 (refl_equal _)).
    destruct (In_dec (l2s C) l).
    simpl in Htrue; rewrite (Props.add_equal Htrue0) in Htrue.
    assert (IH2 := IHn _ _ Hunsat); unfold extend in IH2.
    rewrite ll2s_app in IH2; rewrite ll2s_cfl.
    simpl in IH2; rewrite (Props.add_equal Htrue) in IH2.
    exact IH2.
    apply ARed with {l} {l; l2s C}.
    intro k; set_iff; intro Hk; apply (EnvF.query_assume Hass2);
      rewrite Hk; auto.
    intro k; set_iff; intuition.
    apply union_3; auto.
    assert (IH2 := IHn _ _ Hunsat); unfold extend in IH2.
    rewrite ll2s_app in IH2; rewrite ll2s_cfl.
    rewrite Props.union_sym, <- Props.union_add, Props.union_sym.
    rewrite <- Props.remove_diff_singleton, (Props.remove_add Hfalse).
    exact IH2.

    apply AUnsat with l G1 G2; auto.
    apply AElim with l (l2s (l::C)).
    apply query_assumed; rewrite (assumed_assume Hass1); apply add_1; auto.
    simpl; apply add_1; auto.
    apply union_3; simpl; apply add_1; auto.
    rewrite remove_union.
    2:(intro abs; apply expand_nonrec with l {l; l2s C}; intuition).
    simpl in Hfalse |- *; rewrite (Props.remove_add Hfalse).
    rewrite ll2s_cfl; unfold extend in IH1.
    rewrite ll2s_app in IH1; exact (IH1 (refl_equal _)).
    assert (IH2 := IHn _ _ Hunsat).
    unfold extend in IH2; rewrite ll2s_app, <- ll2s_cfl in IH2; simpl in *.
    destruct (In_dec (l2s C) l).
    simpl in *; rewrite (Props.add_equal Htrue).
    exact IH2.
    apply AStrongRed with (C:=l2s (l::C))(reds := {l}).
    intro k; set_iff; intro Hk; apply (EnvF.query_assume Hass2);
      rewrite Hk; auto.
    intro k; simpl; set_iff; intuition.
    apply union_3; simpl; apply add_1; auto.
    rewrite remove_union.
    2:(intro abs; apply expand_nonrec_2
      with (L.mk_not l) {l; l2s C}; try rewrite L.mk_not_invol; intuition).
    simpl in Hfalse; rewrite (Props.remove_add Hfalse).
    rewrite Props.union_sym, <- Props.union_add, Props.union_sym.
    rewrite <- Props.remove_diff_singleton.
    rewrite (Props.remove_add Hfalse0).
    exact IH2.
    (* -- if BCP did not return a sequent, we apply the correctness of [bcp] *)
    rewrite Props.empty_union_2 in Hbcp2.
    exact (Hbcp2 (refl_equal _)).
    intuition.
  Qed.

  Theorem proof_search_sat :
    forall n G D M, L.llsize D < n ->
      proof_search G D n = Sat M ->
      dom G [<=] dom M /\ compatible_e M (ll2s D).
  Proof.
    induction n; intros G0 D0 M Hlt; unfold proof_search.

    apply False_rec; omega.

    fold proof_search; intros Hsat.
    assert (Hbcp := bcp_complete D0 {} G0).
    assert (Hmon := bcp_monotonic_env D0 G0).
    assert (Hprogress := bcp_progress D0 G0).
    destruct (bcp G0 D0) as [Gext Dred b|]; try discriminate.
    destruct Dred as [|C Dred].

    inversion Hsat; subst; split.
    exact (Hmon _ _ _ (refl_equal _)).
    intros Model Hsub; destruct (Hbcp _ _ _ _ (refl_equal _) Hsub).
    intros k Hk; simpl in Hk.
    rewrite !Props.empty_union_2 in Hk; try solve [intuition].
    contradiction (empty_1 Hk).
    intros C HC; apply H0; apply union_2; auto.

    destruct C as [|l C]; try discriminate.
    assert (Hbcp' := fun Model => Hbcp _ _ _ Model (refl_equal _)); clear Hbcp.
    assert (Hprogress' := Hprogress _ _ _ (refl_equal _)); clear Hprogress.
    assert (Hmon' := Hmon _ _ _ (refl_equal _)); clear Hmon.
    destruct b; auto.

    destruct (IHn Gext ((l::C)::Dred) M) as [IH1 IH2]; auto; try omega.
    split. transitivity (dom (Gext)); auto.
    intros Model Hsub; destruct (Hbcp' Model) as [Hbcp1 Hbcp2].
    intros k Hk; apply Hsub; apply query_monotonic with Gext; auto.
    intros B HB; rewrite !Props.empty_union_2 in HB; try solve [intuition].
    apply IH2; auto.
    intros B HB; apply Hbcp2; apply union_2; auto.

    destruct Hprogress'; subst; clear Hmon' Hbcp'.
    case_eq (assume l G0) ; [intros G1 Hass1 | intros Hass1];
      rewrite Hass1 in Hsat; try discriminate.
    case_eq (proof_search G1 (extend l Dred) n);
      [intros M' Heq | intros Heq]; rewrite Heq in Hsat; simpl in Hsat.
    inversion Hsat; subst.
    destruct (IHn G1 (extend l Dred) M) as [IH1 IH2]; auto.
    unfold extend; simpl in *; rewrite llsize_app.
    generalize (L.size_expand l); omega.
    split.
    transitivity (dom G1); auto. rewrite (assumed_assume Hass1); intuition.
    simpl; intros Model Hsub B HB; rewrite add_iff in HB; destruct HB.
    exists l; split; [|rewrite <- H; apply add_1; auto].
    apply Hsub; apply query_monotonic with G1; auto.
    apply (EnvF.query_assume Hass1); auto.
    apply IH2; auto; unfold extend; rewrite ll2s_app; apply union_3; auto.

    case_eq (assume (L.mk_not l) G0); [intros G2 Hass2 | intros Hass2];
      rewrite Hass2 in Hsat; try discriminate.
    destruct (IHn G2 (extend (L.mk_not l) (C::Dred)) M) as [IH1 IH2]; auto.
    unfold extend; simpl in *; rewrite llsize_app; simpl.
    generalize (L.size_mk_not l) (L.size_expand (L.mk_not l)); omega.
    split.
    transitivity (dom G2); auto.
    rewrite (assumed_assume Hass2); intuition.
    simpl; intros Model Hsub B HB; rewrite add_iff in HB; destruct HB.
    destruct (IH2 _ Hsub (l2s C)) as [k [Hk1 Hk2]].
    unfold extend; rewrite ll2s_app; apply union_3; apply add_1; auto.
    exists k; split; auto; rewrite <- H; apply add_2; auto.
    apply IH2; auto; unfold extend; rewrite ll2s_app;
      apply union_3; apply add_2; auto.
  Qed.

  (** ** The main entry point to the SAT-solver *)
  Definition dpll (Pb : formula) :=
    let D0 := make Pb in
    let D0_as_list := List.map elements (elements D0) in
    let mu := (Datatypes.S (L.llsize D0_as_list)) in
      proof_search empty D0_as_list mu.

  Remark l2s_elements : forall C, l2s (elements C) [=] C.
  Proof.
    intros C k; rewrite (elements_iff C).
    remember (elements C) as L; clear C HeqL; revert k; induction L.
    simpl; split; intuition.
    intros k; split; intuition.
    simpl in H; rewrite add_iff in H; destruct H.
    constructor 1; auto.
    constructor 2; exact ((proj1 (IHL k)) H).
    inversion H; subst.
    apply add_1; auto.
    apply add_2; exact ((proj2 (IHL k)) H1).
  Qed.
  Remark ll2s_map_elements :
    forall D, ll2s (List.map elements (elements D)) [=] D.
  Proof.
    intros D0 k; rewrite (elements_iff D0).
    remember (elements D0) as L; clear HeqL; revert D0 k; induction L.
    simpl; split; intuition.
    intros D0 k; split; intuition.
    simpl in H; rewrite add_iff in H; destruct H.
    constructor 1. rewrite l2s_elements in H; symmetry; auto.
    constructor 2; exact ((proj1 (H0 k)) H).
    simpl; inversion H; subst.
    apply add_1; rewrite l2s_elements; symmetry; auto.
    apply add_2; exact ((proj2 (H0 k)) H2).
  Qed.

  Theorem dpll_correct :
    forall Pb, dpll Pb = Unsat -> Sem.incompatible {} (make Pb).
  Proof.
    intros Pb Hunsat; unfold dpll in Hunsat.
    intros M HM; apply (soundness (empty |- make Pb)).
    assert (H := proof_search_unsat _ _ _ Hunsat).
    rewrite ll2s_map_elements in H; assumption.
    simpl; intros l; rewrite assumed_empty; set_iff; intro Hl.
    rewrite <- (Sem.morphism _ _ _ Hl); apply Sem.wf_true.
  Qed.

End SATCAML.


From iris.program_logic Require Import weakestpre.
Require Import FunctionalExtensionality.
From iris.base_logic.lib Require Import gen_heap.
From iris.proofmode Require Import tactics.
Require Import Ctypes.

Module monad.

  Section monad_rules.
    Context {state  : Type}.
    Context ( M : Type -> Type).
    Context ( ret : forall X, X -> M X).
    Context ( bind : forall X Y, M X -> (X -> M Y) -> M Y ).
    Arguments ret {_} x.
    Arguments bind {_ _} x f.
    Inductive err (X: Type) : Type :=
    | Erro : Errors.errmsg -> err X
    | Res : X -> err X.

    Class MonadProp :=
      {
        left_id (X Y : Type) (a : X) (f : X -> M Y) : bind (ret a) f = f a;
        right_id (X : Type) (m : M X) : bind m ret = m;
        assoc_bind (X Y Z : Type) (m : M X) f (g : Y -> M Z) :
          bind (bind m f) g = bind m (fun x => bind (f x) g)
      }.

  End monad_rules.

  Structure monad :=
    Monad {
        M : Type -> Type;
        state : Type;
        ret : forall (X : Type), X -> M X;
        bind : forall X Y, M X -> (X -> M Y) -> M Y;
        run : forall X, M X -> state -> err (state * X);
        prop : MonadProp M ret bind
      }.

End monad.

Module gensym.
  Import monad.
  Local Open Scope positive_scope.

  Definition ident := positive.
  Definition state := gmap ident type.
  Definition empty_state : state := gmap_empty.
  Definition state_to_list (s : state) := gmap_to_list s.

  (* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%ùùùùù*)
  Inductive sig (X : Type) : Type :=
  | Err : Errors.errmsg -> sig X
  | Gensym : type -> (ident -> X) -> sig X.

  Arguments Err [X].
  Arguments Gensym [X].

  Inductive mon (X : Type) : Type :=
  | ret : X -> mon X
  | op : sig (mon X) -> mon X.

  Arguments ret {_} x.
  Arguments op {_} s.

  Fixpoint bind {X Y} (m : mon X) (f : X -> mon Y) : mon Y :=
    match m with
    | ret x => f x
    | op (Err e) => op (Err e)
    | op (Gensym t g) => op (Gensym t (fun x => bind (g x) f))
    end.

  Definition error {X} (e : Errors.errmsg) : mon X := op (Err e).
  Definition gensym (t : type) : mon ident := op (Gensym t ret).

  Lemma lid : forall X Y (a : X) (f : X -> mon Y), bind (ret a) f = f a.
  Proof. auto. Qed.

  Lemma rid : forall X (m : mon X), bind m ret = m.
  Proof.
    fix m 2.
    destruct m0.
    * reflexivity.
    * destruct s.
      ** reflexivity.
      ** simpl. do 2 f_equal. apply functional_extensionality. intro. apply m.
  Qed.

  Lemma ass_bind : forall X Y Z (m : mon X) f (g : Y -> mon Z),
      bind (bind m f) g = bind m (fun x => bind (f x) g).
  Proof.
    fix m 4.
    destruct m0; intros.
    * reflexivity.
    * destruct s.
      ** reflexivity.
      ** simpl. do 2 f_equal. apply functional_extensionality. intro. apply m.
  Qed.

  Hint Resolve lid rid ass_bind.

  Instance mP : @MonadProp mon (@ret) (@bind).
  Proof. split; eauto. Qed.

  Arguments Erro [X].
  Arguments Res [X].
  Local Open Scope positive_scope.

  Definition fresh (s : state) :=
    map_fold (fun x _ res => Pos.max res (x+1)) 1 s.

  Fixpoint run {X} (m : mon X) : state -> err (state * X) :=
    match m with
    | ret v => fun s => Res (s, v)
    | op (Err e) => fun s => Erro e
    | op (Gensym t f) =>
      fun s =>
        let l := fresh s in
        run (f l) (<[l := t]>s)
    end.

  Canonical Structure gensym_monad := @Monad mon state (@ret) (@bind) (@run) mP.

End gensym.

Module weakestpre_gensym.
  Import monad.
  Export gensym.
  Export gen_heap.

  (** Override the notations so that scopes and coercions work out *)
  Notation "l ↦ t" :=
    (mapsto (L:=ident) (V:=type) l 1 t) (at level 20) : bi_scope.

  Notation "\s l" :=
    (∃ t, l ↦ t)%I (at level 20) : bi_scope.

  Notation "P ⨈ Q" := (((P -∗ False) ∗ (Q -∗ False)) -∗ False)%I (at level 19) : bi_scope.
  Class heapG Σ :=
    HeapG {
        heap_preG_iris :> invG Σ;
        heapG_gen_heapG :> gen_heapG ident type Σ;
      }.
  Section mwp.
    Context `{!heapG Σ}.

    Fixpoint mwp {X} `{!heapG Σ} (e1 : mon X) (Q : X -> iProp Σ) : iProp Σ :=
      match e1 with
      | ret v => Q v
      | op (Err e) => True
      | op (Gensym t f) =>
        ∀ σ, gen_heap_ctx σ ==∗ mwp (f (fresh σ)) Q ∗ gen_heap_ctx (<[ fresh σ := t ]>σ)
      end%I.
  End mwp.

  Notation "'WP' e |{ Φ } |" := (mwp e Φ)
                                  (at level 20, e, Φ at level 200, only parsing) : bi_scope.

  Notation "'WP' e |{ v , Q } |" := (mwp e (λ v, Q))
                                      (at level 20, e, Q at level 200,
                                       format "'[' 'WP'  e  '[ ' |{  v ,  Q  } | ']' ']'") : bi_scope.

  Notation "'|{{' P } } | e |{{ x .. y , 'RET' pat ; Q } } |" :=
    (∀ Φ,
        P -∗ (∀ x, .. (∀ y, Q -∗ Φ pat) .. ) -∗ WP e |{ Φ }|)%I
        (at level 20, x closed binder, y closed binder,
        format "'[hv' |{{  P  } } |  '/  ' e  '/'  |{{  x  ..  y ,  RET  pat ;  Q  } } | ']'") : bi_scope.

  Lemma fresh_is_fresh : forall σ, σ !! (fresh σ) = None.
  Admitted.

  Section mwp_proof.
    Context `{!heapG Σ}.
    Lemma mwp_value' {X} Φ (v : X) : Φ v ⊢ WP ret v |{ Φ }|.
    Proof. auto. Qed.
    Lemma mwp_value_inv' {X} Φ (v : X) : WP ret v |{ Φ }| -∗ Φ v.
    Proof. auto. Qed.

    Lemma mwp_mono {X} e Φ Ψ :
      WP e |{ Φ }| -∗ (∀ (v : X), Φ v -∗ Ψ v) -∗ WP e |{ Ψ }|.
    Proof.
      iIntros "HA HB". revert e. fix e 1.
      destruct e0.
      { iApply "HB". iApply "HA". }
      { destruct s.
        { simpl. trivial. }
        { simpl. iIntros (σ) "HC".
          iDestruct ("HA" with "HC") as "HA".
          iMod "HA" as "[HA HC]".
          iFrame "HC". iModIntro.
          iPoseProof "HB" as "HB". apply e. }}
    Qed.

    Lemma mwp_bind {X Y} (e : mon X) (f :  X → mon Y) (Φ : Y -> iProp Σ)  (Φ' : X -> iProp Σ) :
      WP e |{ Φ' }| -∗ (∀ v,  Φ' v -∗ WP (f v) |{ Φ }|) -∗ WP bind e f |{ Φ }|%I.
    Proof.
      iIntros "HA HB". revert e. fix e 1.
      destruct e0.
      { iApply "HB". iApply "HA". }
      { destruct s.
        { simpl. auto. }
        { simpl. iIntros (σ) "HC". iDestruct ("HA" with "HC") as "HA".
          iMod "HA" as "[HA HC]". iFrame "HC".
          iPoseProof "HB" as "HB". iModIntro. apply e. }}
    Qed.

    Open Scope bi_scope.
    Lemma mwp_gensym t : WP gensym t |{ l, l ↦ t }|.
    Proof.
      simpl. iIntros (σ) "HA". iDestruct (gen_heap_alloc with "HA") as "HA".
      apply fresh_is_fresh. iMod "HA" as "[HA [HB _]]". iFrame. iModIntro. trivial. Qed.

    Lemma mwp_frame_l {X} (e : mon X) Φ (R : iProp Σ) : R ∗ WP e |{ Φ }| ⊢ WP e |{ v, R ∗ Φ v }|.
    Proof. iIntros "[? H]". iApply (mwp_mono with "H"). auto with iFrame. Qed.
    Lemma mwp_frame_r {X} (e : mon X) Φ R : WP e |{ Φ }| ∗ R ⊢ WP e |{ v, Φ v ∗ R }|.
    Proof. iIntros "[H ?]". iApply (mwp_mono with "H"); auto with iFrame. Qed.

  End mwp_proof.
  Open Scope bi_scope.

  Section adequacy.
    Inductive step {X} : mon X -> state -> mon X -> state -> Prop :=
    | gensym_step : forall σ t m,
        step (op (Gensym t m)) σ (m (fresh σ)) (<[ fresh σ := t ]>σ).

    Inductive nsteps {X} : nat ->  mon X -> state -> mon X -> state -> Prop :=
    | step_0 : forall e σ, nsteps 0 e σ e σ
    | step_l : forall e1 σ1 e2 σ2 e3 σ3 n,
        step e1 σ1 e2 σ2 ->
        nsteps n e2 σ2 e3 σ3 ->
        nsteps (S n) e1 σ1 e3 σ3.

    Section step.
      Context `{!heapG Σ}.

      Lemma wp_step {X} (e1 : mon X) σ1 e2 σ2 (Φ : X -> iProp Σ) :
        step e1 σ1 e2 σ2 →
        gen_heap_ctx σ1 -∗ WP e1 |{ Φ }| ==∗
        gen_heap_ctx σ2 ∗ WP e2 |{ Φ }|.
      Proof.
        iIntros (Hstep) "HA HB".
        inversion Hstep. subst.
        simpl.
        iDestruct ("HB" with "HA") as "HA".
        iMod "HA" as "[HA HB]". iModIntro. iFrame.
      Qed.

      Lemma wp_steps {X} n (e1 e2 : mon X) σ1 σ2 Φ :
        nsteps n e1 σ1 e2 σ2 →
        gen_heap_ctx σ1 -∗ WP e1 |{ Φ }| ==∗ gen_heap_ctx σ2 ∗ WP e2 |{ Φ }|.
      Proof.
        revert e1 e2 σ1 σ2 Φ.
        induction n as [| n IH]=> e1 e2 σ1 σ2 Φ /=.
        * inversion_clear 1. iIntros "HA HB". iFrame.  trivial.
        * iIntros (Hsteps) "HA HB". inversion_clear Hsteps.
          eapply (wp_step _ _ _ _ Φ)in H. iDestruct (H with "HA") as "HA".
          iMod ("HA" with "HB") as "HC".
          apply (IH _ _ _ _ Φ) in H0. iDestruct "HC" as "[HA HB]".
          iDestruct (H0 with "HA") as "HC". iMod ("HC" with "HB") as "HC".
          iFrame. trivial.
      Qed.
    End step.

    Class heapPreG Σ :=
    HeapPreG {
        heappre_preG_iris :> invPreG Σ;
        heap_preG_heap :> gen_heapPreG ident type Σ;
      }.

    Theorem wp_strong_adequacy {X} `{!heapPreG Σ} n (e1 : mon X) σ1 e2 σ2 φ :
      (∀ `{Hinv : !invG Σ},
          (|==> ∃ (heap : gen_heapG ident type Σ)
                  (Φ : X → iProp Σ),
                let _ : heapG Σ := HeapG Σ _ heap in
                gen_heap_ctx σ1 ∗
                WP e1 |{ Φ }| ∗
                (gen_heap_ctx σ2 ==∗ ⌜ φ ⌝))%I) →
      nsteps n e1 σ1 e2 σ2 →
      φ.
    Proof.
      intros Hwp ?.
      epose (step_fupdN_soundness' φ 2).
      simpl in φ0. apply φ0. intro.
      iMod Hwp as (heap Φ) "(HA & HB & HC)".
      iApply step_fupd_intro; eauto. iNext.
      epose step_fupdN_S_fupd.
      iApply (e 0%nat).
      iApply (step_fupdN_wand _ _ _ (gen_heap_ctx σ2)with "[-HC]").
      - simpl in Hwp. iDestruct (@wp_steps _ (HeapG _ Hinv heap) _ _ _ _ _ _ Φ) as "HC".
        + apply H.
        + iDestruct ("HC" with "HA") as "HA".
          iDestruct ("HA" with "HB") as "HD". iMod "HD" as "[HD HE]". iFrame "HD".
          iApply step_fupd_mask_mono; eauto.
      - iIntros "HA". iDestruct ("HC" with "HA") as "HB". iMod "HB" as "HB".
        iModIntro. iApply "HB".
    Qed.

    Definition adequate {X} (e : mon X) σ (Q : X -> state -> Prop) : Prop :=
      match run e σ with
      | Erro e => True
      | Res (σ', v) => Q v σ'
      end.

    Corollary wp_adequacy Σ {X} `{!heapPreG Σ} (e : mon X) σ φ :
      (∀ `{Hinv : !invG Σ}, |==> ∃ (heap : gen_heapG ident type Σ),
              let _ : heapG Σ := HeapG Σ _ heap in
              gen_heap_ctx σ ∗ WP e |{ v, ⌜φ v⌝ }|)%I →
      adequate e σ (λ v _, φ v).
    Proof.
      revert e σ φ. fix e 1; intros.
      unfold adequate.
      destruct e0; simpl.
      - eapply (wp_strong_adequacy 0 (ret x)). iIntros.
        iMod (H $! Hinv) as (heap) "[HA #HB]".
        iModIntro. iExists heap. iExists (fun x => ⌜ φ x ⌝).
        iFrame. iSplitL. iFrame "HB". iFrame "HB". eauto. constructor.
      - destruct s; simpl; auto.
        eapply (wp_strong_adequacy 1 (op (Gensym t m))).
        + iIntros. iMod (H $! Hinv) as (heap) "[HA HB]".
          iIntros. iModIntro. iExists heap. iExists (fun x => ⌜ φ x ⌝).
          iFrame. iIntros.
          iModIntro. iPureIntro. apply e.
          simpl in H. iIntros. iMod (H $! Hinv0) as (heap0) "[HA HB]".
          iMod ("HB" with "HA") as "[HA HB]".
          iModIntro. iExists heap0. iFrame.
        + do 3 econstructor.
    Qed.

    Lemma step_to_run {X} : forall n (e : mon X) σ v σ',
        nsteps n e σ (ret v) σ' -> run e σ = Res (σ',v).
    Proof.
      induction n; intros.
      - inversion H. subst. simpl. reflexivity.
      - inversion H. subst.
        inversion H1. subst. simpl in *. apply IHn.
        apply H2.
    Qed.

    Lemma run_to_step {X} : forall (e : mon X) σ v σ',
        run e σ = Res (σ',v) -> exists n, nsteps n e σ (ret v) σ' .
    Proof.
      fix e 1. destruct e0; intros.
      - exists (0)%nat. inversion H. subst. constructor.
      - destruct s.
        + inversion H.
        + simpl in *. apply e in H. destruct H. exists (S x). econstructor.
          * constructor.
          * apply H.
    Qed.

    Definition heap_adequacy Σ {X} `{!heapPreG Σ} (e : mon X) σ Q :
      (∀ `{!heapG Σ}, WP e |{ v, ⌜Q v⌝ }|%I) →
      adequate e σ (λ v _, Q v).
    Proof.
      intros Hwp. eapply (wp_adequacy Σ).
      iMod (gen_heap_init σ) as (?) "Hh".
      iIntros. iModIntro. iExists H. iFrame. iApply Hwp.
    Qed.
  End adequacy.

End weakestpre_gensym.

Module proofmode.
  Export weakestpre_gensym.
  Open Scope bi_scope.
  Ltac early S := iIntros (Φ) S.
  Section proofmode_intro.
    Context `{!heapG Σ}.

    Lemma gensym_spec t :
    |{{ True }}| gensym t |{{ l, RET l; l ↦ t }}|.
    Proof.
      iIntros (Φ) "HA HB". simpl.
      iIntros (σ) "HC". pose mwp_gensym.
      simpl in u. iMod (u $! σ with "HC") as "[HC HD]".
      iModIntro. iFrame. iApply "HB". iApply "HC".
    Qed.

    Lemma ret_spec {X} (v : X) :
    |{{ True }}| ret v |{{ v', RET v'; ⌜ v' = v ⌝  }}|.
    Proof. early "HA HB". iApply "HB". auto. Qed.

    Lemma ret_spec_bis {X} (v : X) (Q : X -> iProp Σ) :
      Q v
      <->
    |{{ True }}| ret v |{{ v', RET v'; Q v' }}|.
    Proof.
      split.
      - intro. early "HA HB". iApply "HB". iApply H.
      - intro. iApply H; eauto.
    Qed.

    Lemma error_spec {X} (Q : X -> iProp Σ) e :
    |{{ True }}| error e |{{ v, RET v; Q v }}|.
    Proof. early "HA HB". iApply "HA". Qed.

    Lemma bind_spec {X Y} (e : mon X) (f : X -> mon Y) Φ' Φ'' H :
    |{{ H }}| e |{{ v, RET v; Φ'' v }}| ->
                                        (∀ v, |{{ Φ'' v }}| (f v) |{{ v', RET v'; Φ' v' }}|) ->
    |{{ H }}| (bind e f) |{{ v, RET v; Φ' v}}|.
    Proof.
      intros. early "HA HB".
      iApply (mwp_bind e f _ Φ'' with "[HA]").
      - iApply (H0 with "[HA]"); auto.
      - iIntros (v) "HC". iApply (H1 with "[HC]"); auto.
    Qed.

    Lemma frame_r {X} H R Φ' (e : mon X) :
    |{{ H }}| e |{{ v, RET v; Φ' v }}| ->
    |{{ H ∗ R }}| e |{{ v, RET v; Φ' v ∗ R }}|.
    Proof.
      intro P. early "HA HB". iDestruct "HA" as "[HA HC]".
      iApply (P with "[HA]"); auto.
      iIntros (v) "HA". iApply "HB". iFrame.
    Qed.

    Lemma frame_l {X} H R Φ' (e : mon X) :
    |{{ H }}| e |{{ v, RET v; Φ' v }}| ->
    |{{ R ∗ H }}| e |{{ v, RET v; R ∗ Φ' v }}|.
    Proof. intro P. early "HA HB". iDestruct "HA" as "[HA HC]".
           iApply (P with "[HC]"); auto.
           iIntros (v) "HC". iApply "HB". iFrame.
    Qed.

    Lemma consequence_post {X} Φ'' H Φ'  (e : mon X) :
      (forall v, Φ'' v -∗ Φ' v) ->
    |{{ H }}| e |{{ v, RET v; Φ'' v }}| ->
    |{{ H }}| e |{{ v, RET v; Φ' v }}|.
    Proof.
      intros P P'. early "HA HB".
      iApply (P' with "[HA]"); auto.
      iIntros (v) "HA". iApply "HB". iApply P. iApply "HA".
    Qed.

    Lemma consequence_pre {X} H' Φ' (H : iProp Σ)  (e : mon X) :
      (H -∗ H') ->
    |{{ H' }}| e |{{ v, RET v; Φ' v }}| ->
    |{{ H }}| e |{{ v, RET v; Φ' v }}|.
    Proof.
      intros P P'. early "HA HB".
      iApply (P' with "[HA]"); auto.
      iApply P. iApply "HA".
    Qed.

    Lemma tLeft {X} (Q : X -> iProp Σ) (R : X -> iProp Σ) S (e : mon X) :
    |{{ S }}| e |{{ v, RET v; R v }}| ->
    |{{ S }}| e |{{ v, RET v; R v ⨈ Q v }}|.
    Proof.
      intro H. early "HA HB".
      iApply (H with "[HA]"); auto.
      iIntros (v) "HA". iApply "HB". iIntros "HB". iDestruct "HB" as "[HB HC]".
      iApply "HB". iApply "HA".
    Qed.

    Lemma tRight {X} (Q : X -> iProp Σ) (R : X -> iProp Σ) S (e : mon X) :
    |{{ S }}| e |{{ v, RET v; Q v }}| ->
    |{{ S }}| e |{{ v, RET v; R v ⨈ Q v }}|.
    Proof.
      intro H. early "HA HB".
      iApply (H with "[HA]"); auto.
      iIntros (v) "HA". iApply "HB". iIntros "HB". iDestruct "HB" as "[HB HC]".
      iApply "HC". iApply "HA".
    Qed.

    Lemma ret_spec_complete {X} (Q : X -> iProp Σ) S (v : X) :
      (S -∗ Q v) ->
    |{{ S }}| ret v |{{ v', RET v'; Q v' }}|.
    Proof.
      intro. early "HA HB". iApply "HB". iDestruct (H with "HA") as "HA". iApply "HA".
    Qed.

    Lemma True_pre_l {X} H Φ' (e : mon X) :
    |{{ True ∗ H}}| e |{{ v, RET v; Φ' v }}| ->
    |{{ H }}| e |{{ v, RET v; Φ' v }}|.
    Proof.
      intro P. early "HA HB".
      iApply (P with "[HA]"); auto.
    Qed.

    Lemma True_pre_r {X} H Φ' (e : mon X) :
    |{{ H ∗ True}}| e |{{ v, RET v; Φ' v }}| ->
    |{{ H }}| e |{{ v, RET v; Φ' v }}|.
    Proof.
      intro P. early "HA HB".
      iApply (P with "[HA]"); auto.
    Qed.

  End proofmode_intro.

  Ltac tFrame_l := apply True_pre_r; apply frame_l; eauto.
  Ltac tFrame_r := apply True_pre_l; apply frame_r; eauto.

  Section proofmode_divers.
    Context `{!heapG Σ}.

    Lemma comm_post {X} R Φ' (e : mon X) H :
    |{{ H }}| e |{{ v, RET v; Φ' v ∗ R v }}| ->
    |{{ H }}| e |{{ v, RET v; R v ∗ Φ' v}}|.
    Proof.
      intro P. early "HA HB".
      iApply (P with "[HA]"); auto.
      iIntros (v) "HA". iApply "HB". iDestruct "HA" as "[HA HC]". iFrame.
    Qed.

    Lemma comm_pre {X} R Φ' (e : mon X) H :
    |{{ R ∗ H}}| e |{{ v, RET v; Φ' v }}| ->
    |{{ H ∗ R}}| e |{{ v, RET v; Φ' v}}|.
    Proof.
      intro P. early "HA HB".
      iApply (P with "[HA]"); auto.
      iDestruct "HA" as "[HA HC]". iFrame.
    Qed.

    Lemma impl_post_id {X} R P Φ' (e : mon X) :
    |{{ R }}| e |{{ v, RET v; Φ' v }}| ->
    |{{ R }}| e |{{ v, RET v; P -∗ P ∗ Φ' v}}|.
    Proof.
      intro H. early "HA HB".
      iApply (H with "[HA]"); auto.
      iIntros (v) "HA". iApply "HB". iIntros "HB". iFrame.
    Qed.

    Lemma impl_post {X} R P Φ' (e : mon X) :
    |{{ R }}| e |{{ v, RET v; Φ' v }}| ->
    |{{ R }}| e |{{ v, RET v; P -∗ Φ' v}}|.
    Proof.
      intro H. early "HA HB".
      iApply (H with "[HA]"); auto.
      iIntros (v) "HA". iApply "HB". eauto.
    Qed.

    Lemma star_assoc_post {X} R Q S T (e : mon X) :
    |{{ T }}| e |{{ v, RET v; R v ∗ (Q v ∗ S v)}}| <->
    |{{ T }}| e |{{ v, RET v; (R v ∗ Q v) ∗ S v }}|.
    Proof.
      split; intro H; early "HA HB";
        iApply (H with "[HA]"); try (iApply "HA");
          iIntros (v) "HA"; iApply "HB".
      - iDestruct "HA" as "[HA [HB HC]]". iFrame.
      - iDestruct "HA" as "[[HA HB] HC]". iFrame.
    Qed.

    Lemma star_assoc_pre {X} R Q S T (e : mon X) :
    |{{ (T ∗ R) ∗ S }}| e |{{ v, RET v; Q v }}| <->
    |{{ T ∗ (R ∗ S) }}| e |{{ v, RET v; Q v }}|.
    Proof.
      split; intro H; early "HA HB"; iApply (H with "[HA]"); eauto.
      - iDestruct "HA" as "[HA [HB HC]]". iFrame.
      - iDestruct "HA" as "[[HA HB] HC]". iFrame.
    Qed.

    Lemma impl_true_pre {X} (R : X -> iProp Σ) Q (e : mon X) :
    |{{ Q }}| e |{{ v', RET v'; R v'}}| ->
    |{{ True -∗ Q }}| e |{{ v', RET v'; R v'}}|.
    Proof.
      intro H. early "HA HB". iApply (H with "[HA]"); eauto. iApply "HA"; auto.
    Qed.

    Lemma impl_true_post {X} (R : X -> iProp Σ) Q (e : mon X) :
    |{{ Q }}| e |{{ v', RET v'; R v'}}| ->
    |{{ Q }}| e |{{ v', RET v'; True -∗ R v'}}|.
    Proof.
      intro H. early "HA HB". iApply (H with "[HA]"); eauto.
      iIntros (v') "HA". iApply "HB". auto.
    Qed.

    Lemma exist {X Y} v (R : Y -> X -> iProp Σ) Q (e : mon X) :
    |{{ Q }}| e |{{ v', RET v'; R v v'}}| ->
    |{{ Q }}| e |{{ v', RET v'; ∃ t, R t v'}}|.
    Proof.
      intro H. early "HA HB".
      iApply (H with "[HA]"); auto.
      iIntros (v0) "HC". iApply "HB". iExists v. iFrame.
    Qed.

    Lemma exists_frame_r {X Y} v (Q : Y -> iProp Σ) R (e : mon X) :
    |{{ True }}| e |{{ v', RET v'; R v v' }}| ->
    |{{ Q v }}| e |{{ v', RET v'; ∃ t, R t v' ∗ Q t}}|.
    Proof.
      intro.
      iApply (exist v). tFrame_r.
    Qed.

    Lemma exists_frame_l {X Y} v (Q : Y -> iProp Σ) R (e : mon X) :
    |{{ True }}| e |{{ v', RET v'; R v v'}}| ->
    |{{ Q v }}| e |{{ v', RET v'; ∃ t, Q t ∗ R t v'}}|.
    Proof.
      intro.
      iApply (exist v).
      tFrame_l.
    Qed.

    Lemma exists_out_l {X Y} (Q : iProp Σ) (R : Y -> X -> iProp Σ) S (e : mon X) :
    |{{ S }}| e |{{ v', RET v'; Q ∗ ∃ t, R t v' }}| ->
    |{{ S }}| e |{{ v', RET v'; ∃ t, Q ∗ R t v'}}|.
    Proof.
      intro H. early "HA HB".
      iApply (H with "[HA]"); auto.
      iIntros (v) "HA". iApply "HB". iDestruct "HA" as "[HA HB]". iDestruct "HB" as (t) "HB".
      iExists t. iFrame.
    Qed.

    Lemma exists_out_r {X Y} (Q : iProp Σ) (R : Y -> X -> iProp Σ) S (e : mon X) :
    |{{ S }}| e |{{ v', RET v'; (∃ t, R t v') ∗ Q }}| ->
    |{{ S }}| e |{{ v', RET v'; ∃ t, R t v' ∗ Q }}|.
    Proof.
      intro H. early "HA HB".
      iApply (H with "[HA]"); auto.
      iIntros (v) "HA". iApply "HB". iDestruct "HA" as "[HA HB]". iDestruct "HA" as (t) "HA".
      iExists t. iFrame.
    Qed.

    Lemma ret_frame_l {X Y} (R : Y -> iProp Σ) (R' Φ' : X -> iProp Σ) (v' : X) (v'': Y) :
      Φ' v' -> R v'' = R' v' ->
    |{{ R v'' }}| ret v' |{{ v, RET v; R' v ∗ Φ' v }}|.
    Proof.
      intros H H'. early "HA HB".
      iApply mwp_value'. iApply "HB". rewrite H'. iFrame. iApply H.
    Qed.

    Lemma ret_frame_r {X Y} (R : Y -> iProp Σ) (R' Φ' : X -> iProp Σ) (v' : X) (v'' : Y):
      Φ' v' -> R v'' = R' v' ->
    |{{ R v'' }}| ret v' |{{ v, RET v; Φ' v ∗ R' v }}|.
    Proof.
      intros H H'. early "HA HB".
      iApply mwp_value'. iApply "HB". rewrite H'. iFrame. iApply H.
    Qed.

  End proofmode_divers.

End proofmode.


Require Import ParserArg.

(* Grammar should be parametrized by a PARSER_ARG module; however, that
   would impede code extraction because of a Coq bug.  Instead, we
   introduce a bunch of definitions below to achieve some separation as
   long as we never directly use definitions in X86_PARSER_ARG *)
Definition char_p := X86_PARSER_ARG.char_p.
Definition char_dec := X86_PARSER_ARG.char_dec.
Definition user_type := X86_PARSER_ARG.user_type.
Definition user_type_dec := X86_PARSER_ARG.user_type_dec.
Definition user_type_denote := X86_PARSER_ARG.user_type_denote.
Definition token_id := X86_PARSER_ARG.token_id.
Definition num_tokens := X86_PARSER_ARG.num_tokens.
Definition token_id_to_chars := X86_PARSER_ARG.token_id_to_chars.

(** The [type]s for our grammars. *)
Inductive type : Type :=
| Unit_t : type
| Char_t : type
| Void_t : type
| Pair_t : type -> type -> type
| Sum_t : type -> type -> type
| List_t : type -> type
| Option_t : type -> type
| User_t : user_type -> type.

(** [void] is an empty type. *)
Inductive void : Type := .

(** The interpretation of [type]s as Coq [Type]s. *)
Fixpoint interp (t:type) : Type :=
  match t with
    | Unit_t => unit
    | Char_t => char_p
    | Void_t => void
    | Pair_t t1 t2 => (interp t1) * (interp t2)
    | Sum_t t1 t2 => (interp t1) + (interp t2)
    | List_t t => list (interp t)
    | Option_t t => option (interp t)
    | User_t t => user_type_denote t
  end%type.