Require Import msl.msl_standard.
Require Import share_dec_base.
Require Import share_equation_system.
Require Import base_properties.
Require Import share_dec_interface.

Module Bool_formula (sv : SV) <: BOOL_FORMULA sv.

 Definition var := sv.t.
 Definition context := var -> bool.

 Inductive bF : Type :=
 |valF : bool -> bF
 |varF : var  -> bF
 |andF : bF -> bF -> bF
 |orF  : bF -> bF -> bF
 |implF: bF -> bF -> bF
 |negF : bF -> bF
 |exF  : var -> bF -> bF
 |allF : var -> bF -> bF.

 Fixpoint bF_vars f :=
  match f with
  |valF b => nil
  |varF v => v::nil
  |andF f1 f2
  |orF f1 f2
  |implF f1 f2 => (bF_vars f1)++(bF_vars f2)
  |negF f'  => bF_vars f'
  |exF v f'
  |allF v f' => v::bF_vars f'
  end.

 Instance bF_varsable : varsable bF var.
 constructor. intros. apply (bF_vars X).
 Defined.

 Fixpoint beval (ctx : context) (f : bF):=
  match f with
  |valF b => b
  |varF v => ctx v
  |andF f1 f2 => (beval ctx f1) && (beval ctx f2)
  |orF f1 f2 => (beval ctx f1) || (beval ctx f2)
  |implF f1 f2 => implb (beval ctx f1) (beval ctx f2)
  |negF f' => negb (beval ctx f')
  |exF v f' => (beval (upd ctx v true) f') || (beval (upd ctx v false) f')
  |allF v f' => (beval (upd ctx v true) f') && (beval (upd ctx v false) f')
  end.
 Instance bF_eval: evalable context bF.
 constructor. intros rho f.
 apply (beval rho f = true).
 Defined.

 Definition valid {A B} `{evalable A B}:=
  fun (b : B) => forall a, a |= b.
 Definition unsat {A B} `{evalable A B}:=
  fun (b : B) => forall a, ~(a |= b).

 Fixpoint not_free v f: Prop :=
  match f with
  |valF b => True
  |varF v' => match eq_dec v v' with
              |left _ => False
              |right _ => True
              end
  |andF f1 f2
  |orF f1 f2
  |implF f1 f2 => (not_free v f1) /\ (not_free v f2)
  |negF f' => not_free v f'
  |exF v' f'
  |allF v' f' => match eq_dec v v' with
                |left _ => True
                |right _ => not_free v f'
                end
  end.

 Definition full_quan :=
  fun f => forall v, In v (vars f) -> not_free v f.

 Fixpoint bsize (f : bF) :=
  match f with
  |valF b => 1
  |varF v => 1
  |andF f1 f2
  |orF f1 f2
  |implF f1 f2 => 1 + (bsize f1) + (bsize f2)
  |negF f'  => 1 + (bsize f')
  |exF v f'
  |allF v f' => 1 + (bsize f')
  end.

 Fixpoint bsubst (f : bF) (v : var) (b : bool) :=
  match f with
  |valF b'    => valF b'
  |varF v'    => match eq_dec v v' with
                 |left _  => valF b
                 |right _ => varF v'
                 end
  |andF f1 f2 => andF (bsubst f1 v b) (bsubst f2 v b)
  |orF f1 f2 => orF (bsubst f1 v b) (bsubst f2 v b)
  |implF f1 f2 => implF (bsubst f1 v b) (bsubst f2 v b)
  |negF f'    => negF (bsubst f' v b)
  |exF v' f'  => match eq_dec v v' with
                 |left _  => exF v' f'
                 |right _ => exF v' (bsubst f' v b)
                 end
  |allF v' f' => match eq_dec v v' with
                 |left _  => allF v' f'
                 |right _ => allF v' (bsubst f' v b)
                 end
  end.

 Lemma bF_valid_rewrite: forall (f : bF),
  valid f <-> forall rho, beval rho f = true.
 Proof with try tauto.
  intros...
 Qed.
 Lemma bF_unsat_rewrite: forall (f : bF),
  unsat f <-> forall rho, beval rho f = false.
 Proof with try tauto.
  intros. split;repeat intro.
  spec H rho. simpl in H.
  icase (beval rho f)...
  spec H a. simpl in H0.
  icase (beval a f)...
 Qed.

 Lemma bsize_bsubst : forall v b f,
  bsize (bsubst f v b) = bsize f.
 Proof with try tauto.
  induction f;intros;
  simpl...
  destruct (eq_dec v v0)...
  rewrite IHf1,IHf2...
  rewrite IHf1,IHf2...
  rewrite IHf1,IHf2...
  rewrite IHf...
  destruct (eq_dec v v0)... simpl.
  rewrite IHf...
  destruct (eq_dec v v0)... simpl.
  rewrite IHf...
 Qed.

 Instance bF_eq_dec: EqDec bF.
 Proof with try tauto;disc.
 induction a;intros.
 icase a'.
 destruct (bool_dec b b0)... left;subst...
 right;intro;subst;inv H...
 right... right... right... right... right...
 right... right...
 icase a'. right...
 destruct (eq_dec v v0);subst...
 right;intro;inv H...
 right... right... right... right... right... right...
 icase a'. right... right...
 spec IHa1 a'1. spec IHa2 a'2.
 destruct IHa1;destruct IHa2;subst...
 right;intro;inv H... right;intro;inv H...
 right;intro;inv H... right... right... right... right... right...
 icase a'. right... right... right...
 spec IHa1 a'1. spec IHa2 a'2.
 destruct IHa1;destruct IHa2;subst...
 right;intro;inv H... right;intro;inv H...
 right;intro;inv H... right... right... right... right...
 icase a'. right... right... right... right...
 spec IHa1 a'1. spec IHa2 a'2.
 destruct IHa1;destruct IHa2;subst...
 right;intro;inv H... right;intro;inv H...
 right;intro;inv H... right... right... right...
 icase a'. right... right... right... right... right...
 spec IHa a'. destruct IHa ;subst...
 right;intro;inv H...
 right... right...
 icase a'. right... right... right... right... right... right...
 spec IHa a'. destruct IHa ;subst...
 destruct (eq_dec v v0);subst... right;intro;inv H...
 right;intro;inv H... right...
 icase a'. right... right... right... right... right... right... right...
 spec IHa a'. destruct IHa ;subst...
 destruct (eq_dec v v0);subst... right;intro;inv H...
 right;intro;inv H...
 Defined.

 Lemma beval_bsubst: forall f rho v b,
  beval rho (bsubst f v b) = beval (upd rho v b) f.
 Proof with try tauto.
  induction f;intros;
  simpl...
  destruct (eq_dec v0 v);simpl.
  subst;rewrite upd_eq...
  rewrite upd_neq...
  f_equal. apply IHf1. apply IHf2.
  f_equal. apply IHf1. apply IHf2.
  f_equal. apply IHf1. apply IHf2.
  f_equal. apply IHf.
  destruct (eq_dec v0 v);subst;simpl.
  repeat rewrite upd_absorb...
  f_equal;rewrite upd_swap;
  try apply IHf...
  destruct (eq_dec v0 v);subst;simpl.
  repeat rewrite upd_absorb...
  f_equal;rewrite upd_swap;
  try apply IHf...
 Qed.

 Lemma bsubst_id: forall f v b,
  ~In v (vars f) ->
  bsubst f v b = f.
 Proof with try tauto.
  induction f;intros;simpl.
  icase b.
  simpl in H.
  destruct (eq_dec v0 v)...
  subst...
  simpl in H. repeat rewrite in_app_iff in H.
  assert (~In v (vars f1) /\ ~In v (vars f2)) by tauto.
  destruct H0. spec IHf1 v b H0.  spec IHf2 v b H1.
  rewrite IHf1,IHf2...
  simpl in H. repeat rewrite in_app_iff in H.
  assert (~In v (vars f1) /\ ~In v (vars f2)) by tauto.
  destruct H0. spec IHf1 v b H0.  spec IHf2 v b H1.
  rewrite IHf1,IHf2...
  simpl in H. repeat rewrite in_app_iff in H.
  assert (~In v (vars f1) /\ ~In v (vars f2)) by tauto.
  destruct H0. spec IHf1 v b H0.  spec IHf2 v b H1.
  rewrite IHf1,IHf2...
  spec IHf v b H. rewrite IHf...
  simpl in H. assert (v <> v0 /\ ~In v0 (vars f)) by tauto.
  destruct H0.
  destruct (eq_dec v0 v)... rewrite IHf...
  simpl in H. assert (v <> v0 /\ ~In v0 (vars f)) by tauto.
  destruct H0.
  destruct (eq_dec v0 v)... rewrite IHf...
 Qed.

 Lemma bsubst_reduce: forall v b b' f,
  bsubst (bsubst f v b) v b' = bsubst f v b.
 Proof with try tauto.
  induction f;intros;
  simpl...
  destruct (eq_dec v v0)...
  simpl.
  destruct (eq_dec v v0)...
  f_equal...
  f_equal...
  f_equal...
  f_equal...
  destruct (eq_dec v v0). subst.
  simpl. destruct (eq_dec v0 v0)...
  simpl. destruct (eq_dec v v0)...
  rewrite IHf...
  destruct (eq_dec v v0). subst.
  simpl. destruct (eq_dec v0 v0)...
  simpl. destruct (eq_dec v v0)...
  rewrite IHf...
 Qed.

 Lemma bsubst_comm: forall v v' b b' f,
  v <> v' ->
  bsubst (bsubst f v b) v' b' = bsubst (bsubst f v' b') v b.
 Proof with try tauto.
  induction f;intros;
  simpl...
  destruct (eq_dec v v0)...
  simpl. subst.
  destruct (eq_dec v' v0).
  simpl;subst... simpl.
  destruct (eq_dec v0 v0)...
  destruct (eq_dec v' v0).
  subst. simpl. destruct (eq_dec v0 v0)...
  simpl. destruct (eq_dec v' v0);
  destruct (eq_dec v v0)...
  spec IHf1 H. spec IHf2 H.
  congruence.
  spec IHf1 H. spec IHf2 H.
  congruence.
  spec IHf1 H. spec IHf2 H.
  congruence.
  spec IHf H. congruence.
  spec IHf H.
  destruct (eq_dec v v0);
  destruct (eq_dec v' v0);subst;simpl...
  destruct (eq_dec v' v0)...
  destruct (eq_dec v0 v0)...
  destruct (eq_dec v0 v0)...
  destruct (eq_dec v v0)...
  destruct (eq_dec v' v0)...
  destruct (eq_dec v v0)...
  rewrite IHf...
  destruct (eq_dec v v0);
  destruct (eq_dec v' v0);subst;simpl...
  destruct (eq_dec v' v0)...
  destruct (eq_dec v0 v0)...
  destruct (eq_dec v0 v0)...
  destruct (eq_dec v v0)...
  destruct (eq_dec v' v0)...
  destruct (eq_dec v v0)...
  rewrite IHf...
 Qed.

 Lemma bsubst_sublist: forall v b f,
  sublist (vars (bsubst f v b)) (vars f).
 Proof with try tauto.
  induction f;repeat intro;simpl in *...
  destruct (eq_dec v v0)...

  rewrite in_app_iff in *.
  destruct H. left. apply IHf1...
  right. apply IHf2...
  rewrite in_app_iff in *.
  destruct H. left. apply IHf1...
  right. apply IHf2...
  rewrite in_app_iff in *.
  destruct H. left. apply IHf1...
  right. apply IHf2...

  apply IHf...
  destruct (eq_dec v v0)...
  simpl in H. destruct H...
  right. apply IHf...
  destruct (eq_dec v v0)...
  simpl in H. destruct H...
  right. apply IHf...
 Qed.

 Lemma bsubst_in: forall f v v' b,
  v' <> v ->
  In v' (vars f) ->
  In v' (vars (bsubst f v b)).
 Proof with try tauto.
  induction f;intros;simpl in *...
  destruct H0;subst...
  destruct (eq_dec v0 v');subst...
  simpl...
  rewrite in_app_iff in *.
  destruct H0. left. apply IHf1...
  right. apply IHf2...
  rewrite in_app_iff in *.
  destruct H0. left. apply IHf1...
  right. apply IHf2...
  rewrite in_app_iff in *.
  destruct H0. left. apply IHf1...
  right. apply IHf2...
  apply IHf...
  destruct (eq_dec v0 v);subst.
  destruct H0;subst... simpl.
  right. apply bsubst_sublist with (v:=v)(b:=b).
  apply IHf...
  destruct H0;subst...
  simpl... simpl. right. apply IHf...
  destruct (eq_dec v0 v);subst.
  destruct H0;subst... simpl.
  right. apply bsubst_sublist with (v:=v)(b:=b).
  apply IHf...
  destruct H0;subst...
  simpl... simpl. right. apply IHf...
 Qed.

 Lemma bsubst_not_free_id: forall v b f,
  not_free v (bsubst f v b).
 Proof with try tauto.
  induction f;intros;
  simpl...
  destruct (eq_dec v v0);
  simpl... destruct (eq_dec v v0)...
  destruct (eq_dec v v0)...
  subst. simpl. destruct (eq_dec v0 v0)...
  simpl. destruct (eq_dec v v0)...
  destruct (eq_dec v v0)...
  subst. simpl. destruct (eq_dec v0 v0)...
  simpl. destruct (eq_dec v v0)...
 Qed.

 Lemma bsubst_not_free_diff: forall v v' b f,
  v <> v' ->
  (not_free v (bsubst f v' b) <-> not_free v f).
 Proof with try tauto.
  induction f;intros...
  simpl. destruct (eq_dec v' v0)...
  subst. destruct (eq_dec v v0)...

  spec IHf1 H. spec IHf2 H. simpl...
  spec IHf1 H. spec IHf2 H. simpl...
  spec IHf1 H. spec IHf2 H. simpl...
  spec IHf H. simpl.
  destruct (eq_dec v' v0)...
  destruct (eq_dec v v0);
  subst;simpl. destruct (eq_dec v0 v0)...
  destruct (eq_dec v v0)...
  spec IHf H. simpl.
  destruct (eq_dec v' v0)...
  destruct (eq_dec v v0);
  subst;simpl. destruct (eq_dec v0 v0)...
  destruct (eq_dec v v0)...
 Qed.

 Lemma bsubst_upd_reduce: forall f rho v b b',
  beval (upd rho v b) (bsubst f v b') = beval rho (bsubst f v b').
 Proof with try tauto.
  induction f;intros;
  simpl...
  destruct (eq_dec v0 v);simpl...
  rewrite upd_neq...
  f_equal. apply IHf1. apply IHf2.
  f_equal. apply IHf1. apply IHf2.
  f_equal. apply IHf1. apply IHf2.
  f_equal. apply IHf.
  destruct (eq_dec v0 v);subst;simpl.
  repeat rewrite upd_absorb...
  f_equal;rewrite upd_swap;
  try apply IHf...
  destruct (eq_dec v0 v);subst;simpl.
  repeat rewrite upd_absorb...
  f_equal;rewrite upd_swap;
  try apply IHf...
 Qed.

 Lemma beval_upd_not_in: forall f v b rho,
  ~In v (vars f) ->
  beval (upd rho v b) f = beval rho f.
 Proof with try tauto.
  induction f;intros;simpl...
  simpl in H. assert (v <> v0) by tauto.
  rewrite upd_neq... intro;subst...
  assert (~In v (vars f1) /\ ~In v (vars f2)).
   simpl in H. rewrite in_app_iff in H...
  destruct H0.
  rewrite IHf1,IHf2...
  assert (~In v (vars f1) /\ ~In v (vars f2)).
   simpl in H. rewrite in_app_iff in H...
  destruct H0.
  rewrite IHf1,IHf2...
  assert (~In v (vars f1) /\ ~In v (vars f2)).
   simpl in H. rewrite in_app_iff in H...
  destruct H0.
  rewrite IHf1,IHf2...
  rewrite IHf...
  simpl in H. assert (v <> v0 /\ ~In v0 (vars f)) by tauto.
  destruct H0.
  assert (v0 <> v). intro;subst...
  f_equal;rewrite upd_swap;try rewrite IHf...
  simpl in H. assert (v <> v0 /\ ~In v0 (vars f)) by tauto.
  destruct H0.
  assert (v0 <> v). intro;subst...
  f_equal;rewrite upd_swap;try rewrite IHf...
 Qed.

  Lemma not_free_upd: forall f v rho,
   not_free v f -> forall b, beval (upd rho v b) f = beval rho f.
  Proof with try tauto.
   induction f;intros;simpl in *...
   icase (eq_dec v0 v);subst;simpl...
   rewrite upd_neq...
   rewrite IHf1,IHf2...
   rewrite IHf1,IHf2...
   rewrite IHf1,IHf2...
   rewrite IHf...
   icase (eq_dec v0 v);subst.
   repeat rewrite upd_absorb...
   repeat rewrite upd_swap with (x:=v0)...
   spec IHf v0. repeat rewrite IHf...
   icase (eq_dec v0 v);subst.
   repeat rewrite upd_absorb...
   repeat rewrite upd_swap with (x:=v0)...
   spec IHf v0. repeat rewrite IHf...
  Qed.

 Lemma not_free_trivial: forall bf v,
  ~In v (vars bf) -> not_free v bf.
 Proof with try tauto.
  induction bf;intros;simpl in *...
  destruct (eq_dec v0 v);subst...
  rewrite in_app_iff in H.
  split;try apply IHbf1; try apply IHbf2...
  rewrite in_app_iff in H.
  split;try apply IHbf1; try apply IHbf2...
  rewrite in_app_iff in H.
  split;try apply IHbf1; try apply IHbf2...
  apply IHbf...
  destruct (eq_dec v0 v);subst... apply IHbf...
  destruct (eq_dec v0 v);subst... apply IHbf...
 Qed.

 Lemma full_quan_andF: forall f1 f2,
  full_quan (andF f1 f2) <-> full_quan f1 /\ full_quan f2.
 Proof with try tauto.
  intros.
  split;intros H.
  split;intros v H1;
  spec H v;simpl in *;rewrite in_app_iff in *...
  destruct H.
  intros v H2;spec H v;spec H0 v.
  simpl in H2. rewrite in_app_iff in H2;simpl in *...
  generalize (not_free_trivial f1 v);intro.
  generalize (not_free_trivial f2 v);intro.
  tauto.
 Qed.

 Lemma full_quan_orF: forall f1 f2,
  full_quan (orF f1 f2) <-> full_quan f1 /\ full_quan f2.
 Proof with try tauto.
  intros.
  split;intros H.
  split;intros v H1;
  spec H v;simpl in *;rewrite in_app_iff in *...
  destruct H.
  intros v H2;spec H v;spec H0 v.
  simpl in H2. rewrite in_app_iff in H2;simpl in *...
  generalize (not_free_trivial f1 v);intro.
  generalize (not_free_trivial f2 v);intro.
  tauto.
 Qed.

 Lemma full_quan_implF: forall f1 f2,
  full_quan (implF f1 f2) <-> full_quan f1 /\ full_quan f2.
 Proof with try tauto.
  intros.
  split;intros H.
  split;intros v H1;
  spec H v;simpl in *;rewrite in_app_iff in *...
  destruct H.
  intros v H2;spec H v;spec H0 v.
  simpl in H2. rewrite in_app_iff in H2;simpl in *...
  generalize (not_free_trivial f1 v);intro.
  generalize (not_free_trivial f2 v);intro.
  tauto.
 Qed.

 Lemma full_quan_negF: forall f,
  full_quan (negF f) <-> full_quan f.
 Proof with try tauto.
  intros. split;intros H v H1;spec H v;firstorder.
 Qed.

 Lemma full_quan_exF: forall f v b,
  full_quan (exF v f) <-> full_quan (bsubst f v b).
 Proof with try tauto.
  intros.
  unfold full_quan.
  split;intros.
  simpl in *.
  destruct (eq_dec v v0);subst.
  apply bsubst_not_free_id.
  spec H v0. spec H. right.
  eapply bsubst_sublist. apply H0.
  destruct (eq_dec v0 v);subst...
  apply bsubst_not_free_diff...

  simpl in H0. simpl.
  destruct (eq_dec v0 v);subst...
  destruct H0;subst...
  rewrite<- bsubst_not_free_diff...
  apply H...
  apply bsubst_in... trivial.
 Qed.

 Lemma full_quan_allF: forall f v b,
  full_quan (allF v f) <-> full_quan (bsubst f v b).
 Proof with try tauto.
  intros.
  unfold full_quan.
  split;intros.
  simpl in *.
  destruct (eq_dec v v0);subst.
  apply bsubst_not_free_id.
  spec H v0. spec H. right.
  eapply bsubst_sublist. apply H0.
  destruct (eq_dec v0 v);subst...
  apply bsubst_not_free_diff...

  simpl in H0. simpl.
  destruct (eq_dec v0 v);subst...
  destruct H0;subst...
  rewrite<- bsubst_not_free_diff...
  apply H...
  apply bsubst_in... trivial.
 Qed.

 Lemma full_quan_case: forall f,
  full_quan f ->
  (valid f \/ unsat f).
 Proof with try tauto.
  intros f H. remember (bsize f) as n.
  assert (bsize f <= n) by omega. clear Heqn.
  revert H0 H. revert f. induction n;intros;rewrite bF_unsat_rewrite in *.
  inv H0. icase f. icase f.
  - icase b; firstorder.
  - spec H v. simpl in H. spec H...
    destruct (eq_dec v v)...
  - assert (bsize f1 <= n /\ bsize f2 <= n) by (simpl in H0;omega).
    destruct H1 as [Hf1 Hf2].
    rewrite full_quan_andF in H.
    destruct H.
    generalize (IHn f1 Hf1 H);generalize (IHn f2 Hf2 H1);
    repeat rewrite bF_unsat_rewrite;intros;simpl;
    icase H2;icase H3;[left|right|right|right];
    intro rho;spec H2 rho;spec H3 rho;simpl in *;try rewrite H2,H3...
  - assert (bsize f1 <= n /\ bsize f2 <= n) by (simpl in H0;omega).
    destruct H1 as [Hf1 Hf2].
    rewrite full_quan_orF in H.
    destruct H.
    generalize (IHn f1 Hf1 H);generalize (IHn f2 Hf2 H1);
    repeat rewrite bF_unsat_rewrite;intros;simpl;
    icase H2;icase H3;[left|left|left|right];
    intro rho;spec H2 rho;spec H3 rho;simpl in *;try rewrite H2,H3...
  - assert (bsize f1 <= n /\ bsize f2 <= n) by (simpl in H0;omega).
    destruct H1 as [Hf1 Hf2].
    rewrite full_quan_implF in H.
    destruct H.
    generalize (IHn f1 Hf1 H);generalize (IHn f2 Hf2 H1);
    repeat rewrite bF_unsat_rewrite;intros;simpl;
    icase H3;icase H2; [left|right|left|left];
    intro rho;spec H2 rho;spec H3 rho;simpl in *;try rewrite H2,H3...
  - assert (bsize f <= n) by (simpl in H0;omega).
    rewrite full_quan_negF in H. spec IHn f H1 H.
    repeat rewrite bF_unsat_rewrite in *;intros;simpl.
    icase IHn;[right|left];
    intro rho; spec H2 rho;simpl in*;try rewrite H2...
  - assert (bsize (bsubst f v true) <= n /\ bsize (bsubst f v false) <= n).
     split;rewrite bsize_bsubst;simpl in H0;omega.
    destruct H1.
    copy H. rewrite full_quan_exF with (b:=true) in H.
    rewrite full_quan_exF with (b:= false) in H3.
    generalize (IHn _ H1 H);intro.
    generalize (IHn _ H2 H3);intro.
    repeat rewrite bF_unsat_rewrite in *.
    icase H4;icase H5;[left|left|left|right];
    intro rho;spec H4 rho;spec H5 rho;
    simpl in *;rewrite beval_bsubst in *; rewrite H4,H5...
  - assert (bsize (bsubst f v true) <= n /\ bsize (bsubst f v false) <= n).
     split;rewrite bsize_bsubst;simpl in H0;omega.
    destruct H1.
    copy H. rewrite full_quan_allF with (b:=true) in H.
    rewrite full_quan_allF with (b:= false) in H3.
    generalize (IHn _ H1 H);intro.
    generalize (IHn _ H2 H3);intro.
    repeat rewrite bF_unsat_rewrite in *.
    icase H4;icase H5;[left|right|right|right];
    intro rho;spec H4 rho;spec H5 rho;
    simpl in *;rewrite beval_bsubst in *; rewrite H4,H5...
  Qed.

End Bool_formula.

Module BF_solver (sv : SV) (Import bf : BOOL_FORMULA sv) <: BF_SOLVER sv bf.

 Inductive fType : Type :=
 |bT : bool -> fType
 |fT : bF -> fType.

 Definition check_bval (f : bF) :=
 match f with
 |valF b => bT b
 |_ => fT f
 end.

 Lemma check_bval_bT : forall f b,
  check_bval f = bT b <-> f = valF b.
 Proof with try tauto.
  intros. icase f;simpl;
  split;intros;inv H...
 Qed.

 Lemma check_bval_fT : forall f f',
  check_bval f = fT f' -> f = f'.
 Proof with try tauto.
  intros. icase f;inv H...
 Qed.

 Lemma check_bval_fT2: forall f f',
  check_bval f = fT f' -> f = f' /\ forall b, f <> valF b.
 Proof with try tauto.
  intros. icase f;inv H;
  split;repeat intro;disc...
 Qed.

 Fixpoint fsimpl_onepass (f : bF) : bF :=
 match f with
 |andF f1 f2 => match check_bval f1 with
                |bT b => if b then f2 else valF false
                |fT f1' => match check_bval f2 with
                           |bT b => if b then f1 else valF false
                           |fT f2' => andF f1 f2
                           end
                end
 |orF f1 f2 => match check_bval f1 with
                |bT b => if b then valF true else f2
                |fT f1' => match check_bval f2 with
                           |bT b => if b then valF true else f1
                           |fT f2' => orF f1 f2
                           end
               end
 |implF f1 f2 => match check_bval f1 with
                  |bT b => if b then f2 else valF true
                  |fT f1' => match check_bval f2 with
                             |bT b => if b then valF true else negF f1
                             |fT f2' => implF f1 f2
                             end
                  end
 |negF f' => match check_bval f' with
              |bT b => valF (negb b)
              |fT f'' => negF f'
              end
 |exF v f' => match check_bval f' with
               |bT b => valF b
               |fT f'' => exF v f'
               end
 |allF v f' => match check_bval f' with
               |bT b => valF b
               |fT f'' => allF v f'
               end
 |_ => f
 end.

 Lemma fsimpl_onepass_andF: forall f1 f2,
  (fsimpl_onepass (andF f1 f2) = valF false /\ (f1 = valF false \/ f2 = valF false)) \/
  (fsimpl_onepass (andF f1 f2) = f1 /\ f2 = valF true) \/
  (fsimpl_onepass (andF f1 f2) = f2 /\ f1 = valF true) \/
  (fsimpl_onepass (andF f1 f2) = andF f1 f2 /\ forall b, f1 <> valF b /\ f2 <> valF b).
 Proof with try tauto.
  intros. simpl.
  case_eq (check_bval f1);intros.
  apply check_bval_bT in H. rewrite H.
  icase b.
  apply check_bval_fT2 in H.
  destruct H. rewrite H.
  case_eq (check_bval f2);intros...
  apply check_bval_bT in H1. rewrite H1.
  icase b0.
  apply check_bval_fT2 in H1.
  destruct H1. rewrite H1.
  repeat right. split;repeat intro;split;repeat intro;subst;
  spec H0 b1;spec H2 b1...
 Qed.

 Lemma fsimpl_onepass_orF: forall f1 f2,
  (fsimpl_onepass (orF f1 f2) = valF true /\ (f1 = valF true \/ f2 = valF true)) \/
  (fsimpl_onepass (orF f1 f2) = f1 /\ f2 = valF false) \/
  (fsimpl_onepass (orF f1 f2) = f2 /\ f1 = valF false) \/
  (fsimpl_onepass (orF f1 f2) = orF f1 f2 /\ forall b, f1 <> valF b /\ f2 <> valF b).
 Proof with try tauto.
  intros. simpl.
  case_eq (check_bval f1);intros.
  apply check_bval_bT in H. rewrite H.
  icase b.
  apply check_bval_fT2 in H.
  destruct H. rewrite H.
  case_eq (check_bval f2);intros...
  apply check_bval_bT in H1. rewrite H1.
  icase b0.
  apply check_bval_fT2 in H1.
  destruct H1. rewrite H1.
  repeat right. split;repeat intro;split;repeat intro;subst;
  spec H0 b1;spec H2 b1...
 Qed.

 Lemma fsimpl_onepass_implF: forall f1 f2,
  (fsimpl_onepass (implF f1 f2) = valF true /\ (f1 = valF false \/ f2 = valF true)) \/
  (fsimpl_onepass (implF f1 f2) = f2 /\ f1 = valF true) \/
  (fsimpl_onepass (implF f1 f2) = negF f1 /\ f2 = valF false) \/
  (fsimpl_onepass (implF f1 f2) = implF f1 f2 /\ forall b, f1 <> valF b /\ f2 <> valF b).
 Proof with try tauto.
  intros. simpl.
  case_eq (check_bval f1);intros.
  apply check_bval_bT in H. rewrite H.
  icase b.
  apply check_bval_fT2 in H.
  destruct H. rewrite H.
  case_eq (check_bval f2);intros...
  apply check_bval_bT in H1. rewrite H1.
  icase b0.
  apply check_bval_fT2 in H1.
  destruct H1. rewrite H1.
  repeat right. split;repeat intro;split;repeat intro;subst;
  spec H0 b1;spec H2 b1...
 Qed.

 Lemma fsimpl_onepass_negF: forall f,
  (exists b, fsimpl_onepass (negF f) = valF (negb b) /\ f = valF b) \/
  (fsimpl_onepass (negF f) = negF f /\ forall b, f <> valF b).
 Proof with try tauto.
  intros. simpl.
  case_eq (check_bval f);intros.
  apply check_bval_bT in H;rewrite H.
  left;exists b...
  right... split...
  apply check_bval_fT2 in H...
 Qed.

 Lemma fsimpl_onepass_exF: forall f v,
  (exists b, fsimpl_onepass (exF v f) = valF b /\ f = valF b)\/
  (fsimpl_onepass (exF v f) = exF v f /\ forall b, f <> valF b).
 Proof with try tauto.
  intros. simpl.
  case_eq (check_bval f);intros.
  apply check_bval_bT in H;rewrite H.
  left;exists b...
  right... split...
  apply check_bval_fT2 in H...
 Qed.

 Lemma fsimpl_onepass_allF: forall f v,
  (exists b, fsimpl_onepass (allF v f) = valF b /\ f = valF b)\/
  (fsimpl_onepass (allF v f) = allF v f /\ forall b, f <> valF b).
 Proof with try tauto.
  intros. simpl.
  case_eq (check_bval f);intros.
  apply check_bval_bT in H;rewrite H.
  left;exists b...
  right... split...
  apply check_bval_fT2 in H...
 Qed.

 Opaque fsimpl_onepass.

 Lemma fsimpl_onepass_beval: forall f rho,
  beval rho f = beval rho (fsimpl_onepass f).
 Proof with try tauto.
  intros.
  icase f;simpl.

  - generalize (fsimpl_onepass_andF f1 f2);intros.
    firstorder;try subst f1; try subst f2;try rewrite H;simpl;
    try rewrite andb_false_r;
    try rewrite andb_true_r...

  - generalize (fsimpl_onepass_orF f1 f2);intros.
    firstorder;try subst f1; try subst f2;try rewrite H;simpl;
    try rewrite orb_true_r;
    try rewrite orb_false_r...

  - generalize (fsimpl_onepass_implF f1 f2);intros.
    firstorder;try subst f1; try subst f2;try rewrite H;simpl...
    icase (beval rho f1).

  - generalize (fsimpl_onepass_negF f);intros.
    firstorder;subst;try rewrite H...

  - generalize (fsimpl_onepass_exF f v);intros.
    firstorder;subst;try rewrite H...
    compute. icase x.

  - generalize (fsimpl_onepass_allF f v);intros.
    firstorder;subst;try rewrite H...
    compute. icase x.
  Qed.

 Transparent fsimpl_onepass.

 Lemma fsimpl_onepass_bsize: forall f,
  bsize (fsimpl_onepass f) <= bsize f.
 Proof with try tauto;try omega.
  intros. icase f;simpl.
  - icase ( check_bval f1);icase (check_bval f2);
    try icase b;try icase b0;simpl...
  - icase ( check_bval f1);icase (check_bval f2);
    try icase b;try icase b0;simpl...
  - icase ( check_bval f1);icase (check_bval f2);
    try icase b;try icase b0;simpl...
  - icase (check_bval f);try icase b;simpl...
  - icase (check_bval f);try icase b;simpl...
  - icase (check_bval f);try icase b;simpl...
 Qed.

 Opaque fsimpl_onepass.

 Fixpoint fsimpl (f : bF) :=
  match f with
  |valF b => valF b
  |varF v => varF v
  |andF f1 f2 => fsimpl_onepass (andF (fsimpl f1) (fsimpl f2))
  |orF f1 f2 => fsimpl_onepass (orF (fsimpl f1) (fsimpl f2))
  |implF f1 f2 => fsimpl_onepass (implF (fsimpl f1) (fsimpl f2))
  |negF f' => fsimpl_onepass (negF (fsimpl f'))
  |exF v f' => fsimpl_onepass (exF v (fsimpl f'))
  |allF v f' => fsimpl_onepass (allF v (fsimpl f'))
  end.

 Lemma fsimpl_beval: forall f rho,
  beval rho f = beval rho (fsimpl f).
 Proof with try tauto.
  induction f;intros;simpl;
  try rewrite<- fsimpl_onepass_beval;
  try rewrite IHf1,IHf2;
  try repeat rewrite IHf...
 Qed.

 Lemma fsimpl_bsize: forall f,
  bsize (fsimpl f) <= bsize f.
 Proof with try tauto;try omega.
   induction f;intros;simpl;
   try rewrite fsimpl_onepass_bsize;simpl...
 Qed.

 Definition quan_elim_exF (v : var) (f : bF) :=
  fsimpl_onepass (orF (fsimpl (bsubst f v true)) (fsimpl (bsubst f v false))).

 Lemma quan_elim_exF_beval: forall f v rho,
  beval rho (exF v f) = beval rho (quan_elim_exF v f).
 Proof with try tauto.
  intros.
  unfold quan_elim_exF. simpl.
  repeat rewrite<- beval_bsubst.
  f_equal;
  rewrite<- fsimpl_onepass_beval;simpl;
  repeat rewrite<-fsimpl_beval...
 Qed.

 Definition quan_elim_allF (v : var) (f : bF) :=
  fsimpl_onepass (andF (fsimpl (bsubst f v true)) (fsimpl (bsubst f v false))).

 Lemma quan_elim_allF_beval: forall f v rho,
  beval rho (allF v f) = beval rho (quan_elim_allF v f).
 Proof with try tauto.
  intros.
  unfold quan_elim_allF. simpl.
  repeat rewrite<- beval_bsubst.
  f_equal;
  rewrite<- fsimpl_onepass_beval;simpl;
  repeat rewrite<-fsimpl_beval...
 Qed.

 Fixpoint quan_elim (f : bF): bF :=
  match f with
  |valF b => valF b
  |varF v => varF v
  |andF f1 f2 => fsimpl_onepass (andF (quan_elim f1) (quan_elim f2))
  |orF f1 f2 => fsimpl_onepass (orF (quan_elim f1) (quan_elim f2))
  |implF f1 f2 => fsimpl_onepass (implF (quan_elim f1) (quan_elim f2))
  |negF f' => fsimpl_onepass (negF (quan_elim f'))
  |exF v f'  => quan_elim_exF v (quan_elim f')
  |allF v f' => quan_elim_allF v (quan_elim f')
  end.

  Lemma quan_elim_beval: forall bf rho,
   beval rho (quan_elim bf) = beval rho bf.
  Proof with try tauto.
   induction bf;intros;simpl;
   try rewrite<- fsimpl_onepass_beval;simpl...
   f_equal;try apply IHbf1;try apply IHbf2.
   f_equal;try apply IHbf1;try apply IHbf2.
   f_equal;try apply IHbf1;try apply IHbf2.
   f_equal;apply IHbf.
   rewrite <- quan_elim_exF_beval. simpl.
   f_equal;apply IHbf.
   rewrite <- quan_elim_allF_beval. simpl.
   f_equal;apply IHbf.
  Qed.

 Definition var_free {A} `{varsable A var}:= fun (a : A) => vars a = nil.

 Definition var_free_spec (A : Type) {B} `{varsable A var} `{evalable B A} :=
  forall a, var_free a -> (valid a \/ unsat a).

 Class var_free_prop (A : Type) {B} `{varsable A var} `{evalable B A} := Var_free_prop {
   var_free_case: var_free_spec A
 }.

 Instance bf_var_free: var_free_prop bF.
 Proof with try tauto.
  constructor.
  induction a;intros H; unfold var_free in *;simpl in *;
  rewrite bF_unsat_rewrite,bF_valid_rewrite in *.
  icase b. left. repeat intro...
  inv H.

  apply app_eq_nil in H.
  destruct H. spec IHa1 H. spec IHa2 H0.
  icase IHa1;icase IHa2.
  left. repeat intro;simpl.
  spec H1 rho. spec H2 rho.
  rewrite H1,H2...
  right. repeat intro;simpl.
  spec H1 rho. spec H2 rho.
  rewrite H1,H2...
  right. repeat intro;simpl.
  spec H1 rho. spec H2 rho.
  rewrite H1,H2...
  right. repeat intro;simpl.
  spec H1 rho. spec H2 rho.
  rewrite H1,H2...

  apply app_eq_nil in H.
  destruct H. spec IHa1 H. spec IHa2 H0.
  icase IHa1;icase IHa2.
  left. repeat intro;simpl.
  spec H1 rho. spec H2 rho.
  rewrite H1,H2...
  left. repeat intro;simpl.
  spec H1 rho. spec H2 rho.
  rewrite H1,H2...
  left. repeat intro;simpl.
  spec H1 rho. spec H2 rho.
  rewrite H1,H2...
  right. repeat intro;simpl.
  spec H1 rho. spec H2 rho.
  rewrite H1,H2...

  apply app_eq_nil in H.
  destruct H. spec IHa1 H. spec IHa2 H0.
  icase IHa1;icase IHa2.
  left. repeat intro;simpl.
  spec H1 rho. spec H2 rho.
  rewrite H1,H2...
  right. repeat intro;simpl.
  spec H1 rho. spec H2 rho.
  rewrite H1,H2...
  left. repeat intro;simpl.
  spec H1 rho. spec H2 rho.
  rewrite H1,H2...
  left. repeat intro;simpl.
  spec H1 rho. spec H2 rho.
  rewrite H1,H2...

  spec IHa H.
  destruct IHa;[right|left];
  repeat intro;simpl; spec H0 rho;
  rewrite H0...
  inv H. inv H.
 Qed.

 Transparent fsimpl_onepass.

 Lemma fsimpl_reduce: forall f,
  fsimpl (fsimpl f) = fsimpl f.
 Proof with try tauto.
  induction f;simpl...
  - case_eq (check_bval (fsimpl f1));intros.
    apply check_bval_bT in H. rewrite H in *.
    icase b.
    case_eq (check_bval (fsimpl f2));intros.
    apply check_bval_bT in H0. rewrite H0 in *.
    icase b0.
    simpl. rewrite IHf1,IHf2,H,H0...
  - case_eq (check_bval (fsimpl f1));intros.
    apply check_bval_bT in H. rewrite H in *.
    icase b.
    case_eq (check_bval (fsimpl f2));intros.
    apply check_bval_bT in H0. rewrite H0 in *.
    icase b0.
    simpl. rewrite IHf1,IHf2,H,H0...
  - case_eq (check_bval (fsimpl f1));intros.
    apply check_bval_bT in H. rewrite H in *.
    icase b.
    case_eq (check_bval (fsimpl f2));intros.
    apply check_bval_bT in H0. rewrite H0 in *.
    icase b0;simpl. rewrite IHf1,H...
    simpl. rewrite IHf1,IHf2,H,H0...
  - case_eq (check_bval (fsimpl f));intros...
    simpl. rewrite IHf,H...
  - case_eq (check_bval (fsimpl f));intros...
    simpl. rewrite IHf,H...
  - case_eq (check_bval (fsimpl f));intros...
    simpl. rewrite IHf,H...
 Qed.

 Lemma fsimpl_bsubst_reduce: forall f v b,
  fsimpl (bsubst (fsimpl f) v b) = fsimpl (bsubst f v b).
 Proof with try tauto.
  induction f;intros;simpl...
  - case_eq (check_bval (fsimpl f1));intros;simpl.
    apply check_bval_bT in H.
    rewrite H in IHf1.
    rewrite <- IHf1. simpl.
    icase b0...
    case_eq (check_bval (fsimpl f2));intros;simpl.
    apply check_bval_bT in H0.
    rewrite H0 in IHf2.
    rewrite <- IHf2. simpl.
    icase b1...
    rewrite IHf1.
    case_eq (check_bval (fsimpl (bsubst f1 v b)));intros...
    apply check_bval_bT in H1. rewrite H1. icase b1...
    case_eq (check_bval (fsimpl (bsubst f1 v b)));intros;simpl...
    icase b1...
    rewrite IHf1,IHf2...
  - case_eq (check_bval (fsimpl f1));intros;simpl.
    apply check_bval_bT in H.
    rewrite H in IHf1.
    rewrite <- IHf1. simpl.
    icase b0...
    case_eq (check_bval (fsimpl f2));intros;simpl.
    apply check_bval_bT in H0.
    rewrite H0 in IHf2.
    rewrite <- IHf2. simpl.
    icase b1...
    case_eq (check_bval (fsimpl (bsubst f1 v b)));intros... icase b1.
    rewrite IHf1.
    case_eq (check_bval (fsimpl (bsubst f1 v b)));intros...
    apply check_bval_bT in H1. rewrite H1. icase b1...
    rewrite IHf1,IHf2...
  - case_eq (check_bval (fsimpl f1));intros;simpl.
    apply check_bval_bT in H.
    rewrite H in IHf1.
    rewrite <- IHf1. simpl.
    icase b0...
    case_eq (check_bval (fsimpl f2));intros;simpl.
    apply check_bval_bT in H0.
    rewrite H0 in IHf2.
    rewrite <- IHf2. simpl.
    icase b1...
    case_eq (check_bval (fsimpl (bsubst f1 v b)));intros... icase b1.
    simpl. rewrite IHf1.
    case_eq (check_bval (fsimpl (bsubst f1 v b)));intros... icase b1.
    rewrite IHf1,IHf2...
  - case_eq (check_bval (fsimpl f));intros;simpl.
    apply check_bval_bT in H. rewrite H in IHf.
    simpl in IHf. rewrite<- IHf. simpl...
    rewrite IHf...
  - destruct (eq_dec v0 v);subst;simpl.
    case_eq (check_bval (fsimpl f));intros;simpl...
    destruct (eq_dec v v);subst;simpl...
    rewrite fsimpl_reduce,H...
    case_eq (check_bval (fsimpl f));intros;simpl.
    apply check_bval_bT in H. rewrite H in *.
    rewrite<- IHf with (v:=v0)(b:=b);simpl...
    destruct (eq_dec v0 v);subst...
    simpl. rewrite IHf...
  - destruct (eq_dec v0 v);subst;simpl.
    case_eq (check_bval (fsimpl f));intros;simpl...
    destruct (eq_dec v v);subst;simpl...
    rewrite fsimpl_reduce,H...
    case_eq (check_bval (fsimpl f));intros;simpl.
    apply check_bval_bT in H. rewrite H in *.
    rewrite<- IHf with (v:=v0)(b:=b);simpl...
    destruct (eq_dec v0 v);subst...
    simpl. rewrite IHf...
 Qed.

 Lemma quan_elim_bsubst: forall f v b,
  quan_elim (bsubst f v b) = fsimpl (bsubst (quan_elim f) v b).
 Proof with try tauto.
  intro f. remember (bsize f) as n.
  assert (bsize f <= n) by omega. clear Heqn.
  revert H. revert f.
  induction n;intros;simpl in *... inv H. icase f...
  icase f;simpl.
  - destruct (eq_dec v v0);subst...
  - assert (bsize f1 <= n /\ bsize f2 <= n) by (simpl in H;omega).
    repeat rewrite IHn...
    case_eq (check_bval (quan_elim f1));intros...
    rewrite check_bval_bT in H1. rewrite H1. icase b0.
    case_eq (check_bval (quan_elim f2));intros...
    rewrite check_bval_bT in H2. rewrite H2. simpl. icase b1.
    case_eq (check_bval (fsimpl (bsubst (quan_elim f1) v b)));intros...
    apply check_bval_bT in H3;rewrite H3. icase b1.
    case_eq (check_bval (fsimpl (bsubst (quan_elim f1) v b)));intros...
    icase b1.
  - assert (bsize f1 <= n /\ bsize f2 <= n) by (simpl in H;omega).
    repeat rewrite IHn...
    case_eq (check_bval (quan_elim f1));intros...
    rewrite check_bval_bT in H1. rewrite H1. icase b0.
    case_eq (check_bval (quan_elim f2));intros...
    rewrite check_bval_bT in H2. rewrite H2. simpl. icase b1.
    case_eq (check_bval (fsimpl (bsubst (quan_elim f1) v b)));intros...
    icase b1.
    case_eq (check_bval (fsimpl (bsubst (quan_elim f1) v b)));intros...
    apply check_bval_bT in H3;rewrite H3. icase b1.
  - assert (bsize f1 <= n /\ bsize f2 <= n) by (simpl in H;omega).
    repeat rewrite IHn...
    case_eq (check_bval (quan_elim f1));intros...
    rewrite check_bval_bT in H1. rewrite H1. icase b0.
    case_eq (check_bval (quan_elim f2));intros...
    rewrite check_bval_bT in H2. rewrite H2. simpl. icase b1.
    case_eq (check_bval (fsimpl (bsubst (quan_elim f1) v b)));intros...
    icase b1. simpl.
    case_eq (check_bval (fsimpl (bsubst (quan_elim f1) v b)));intros...
    icase b1.
  - simpl in H;rewrite IHn;try omega.
    case_eq (check_bval (quan_elim f));intros...
    apply check_bval_bT in H0;rewrite H0;simpl...
  - simpl in H.
    assert (bsize f <= n) by omega.
    assert (bsize (bsubst f v true) <= n /\ bsize (bsubst f v false) <= n).
     split;rewrite bsize_bsubst...
    destruct (eq_dec v v0);subst;simpl...
    + unfold quan_elim_exF.
      repeat rewrite<- IHn...
      simpl.
      case_eq (check_bval (quan_elim (bsubst f v0 true)));intros.
      icase b0. rewrite <- IHn...
      rewrite bsubst_reduce...
      case_eq (check_bval (quan_elim (bsubst f v0 false)));intros.
      icase b1. rewrite <- IHn...
      rewrite bsubst_reduce...
      simpl. repeat rewrite <-IHn...
      repeat rewrite bsubst_reduce.
      rewrite H2,H3...
    + unfold quan_elim_exF.
      repeat rewrite<- IHn;try rewrite bsize_bsubst...
      simpl.
      case_eq (check_bval (quan_elim (bsubst f v0 true)));intros.
      apply check_bval_bT in H2.
      rewrite bsubst_comm...
      rewrite IHn;try rewrite bsize_bsubst...
      rewrite H2. simpl.
      icase b0... repeat rewrite IHn;try rewrite bsize_bsubst...
      repeat rewrite fsimpl_bsubst_reduce.
      rewrite bsubst_comm...
      case_eq (check_bval (quan_elim (bsubst f v0 false)));intros.
      apply check_bval_bT in H3.
      generalize (bsubst_comm v v0 b false f n0);intro.
      repeat rewrite H4.
      assert (bsize (bsubst f v0 false) <= n) by (rewrite bsize_bsubst;omega).
      generalize (IHn _ H5 v b);intro.
      rewrite H3 in H6.
      repeat rewrite H6. simpl.
      icase b1.
      case_eq (check_bval (quan_elim (bsubst (bsubst f v b) v0 true)));intros...
      icase b1. rewrite <-IHn;try rewrite bsize_bsubst...
      rewrite bsubst_comm...
      case_eq (check_bval (quan_elim (bsubst (bsubst f v0 true) v b)));intros...
      apply check_bval_bT in H7;rewrite H7. icase b1.
      repeat rewrite IHn;try rewrite bsize_bsubst...
      simpl.
      repeat rewrite fsimpl_bsubst_reduce.
      assert (forall f' v' b1 b2, v <> v' -> bsubst (bsubst f' v b1) v' b2 = bsubst (bsubst f' v' b2) v b1).
        intros;apply bsubst_comm...
      repeat rewrite H4...
  - simpl in H.
    assert (bsize f <= n) by omega.
    assert (bsize (bsubst f v true) <= n /\ bsize (bsubst f v false) <= n).
     split;rewrite bsize_bsubst...
    destruct (eq_dec v v0);subst;simpl...
    + unfold quan_elim_allF.
      repeat rewrite<- IHn...
      simpl.
      case_eq (check_bval (quan_elim (bsubst f v0 true)));intros.
      icase b0. rewrite <- IHn...
      rewrite bsubst_reduce...
      case_eq (check_bval (quan_elim (bsubst f v0 false)));intros.
      icase b1. rewrite <- IHn...
      rewrite bsubst_reduce...
      simpl. repeat rewrite <-IHn...
      repeat rewrite bsubst_reduce.
      rewrite H2,H3...
    + unfold quan_elim_allF.
      repeat rewrite<- IHn;try rewrite bsize_bsubst...
      simpl.
      case_eq (check_bval (quan_elim (bsubst f v0 true)));intros.
      apply check_bval_bT in H2.
      rewrite bsubst_comm...
      rewrite IHn;try rewrite bsize_bsubst...
      rewrite H2. simpl.
      icase b0... repeat rewrite IHn;try rewrite bsize_bsubst...
      repeat rewrite fsimpl_bsubst_reduce.
      rewrite bsubst_comm...
      case_eq (check_bval (quan_elim (bsubst f v0 false)));intros.
      apply check_bval_bT in H3.
      generalize (bsubst_comm v v0 b false f n0);intro.
      repeat rewrite H4.
      assert (bsize (bsubst f v0 false) <= n) by (rewrite bsize_bsubst;omega).
      generalize (IHn _ H5 v b);intro.
      rewrite H3 in H6.
      repeat rewrite H6. simpl.
      rewrite bsubst_comm...
      icase b1;try rewrite <- IHn;try rewrite bsize_bsubst...
      case_eq (check_bval (quan_elim (bsubst (bsubst f v0 true) v b)));intros...
      apply check_bval_bT in H7. icase b1...
      simpl.
      case_eq (check_bval (quan_elim (bsubst (bsubst f v0 true) v b)));intros...
      icase b1...
      repeat rewrite IHn;try rewrite bsize_bsubst...
      simpl.
      repeat rewrite fsimpl_bsubst_reduce.
      assert (forall f' v' b1 b2, v <> v' -> bsubst (bsubst f' v b1) v' b2 = bsubst (bsubst f' v' b2) v b1).
        intros;apply bsubst_comm...
      repeat rewrite H4...
  Qed.

 Lemma quan_elim_full_quan: forall f,
  full_quan f ->
  exists b, quan_elim f = valF b.
 Proof with try tauto.
  intro. remember (bsize f) as n. symmetry in Heqn.
  assert (bsize f <= n) by omega.
  clear Heqn. revert H. revert f. induction n;intros.
  inv H;icase f.
  icase f;simpl...
  exists b...
  spec H0 v. spec H0;simpl...
  simpl in H0. destruct (eq_dec v v);subst...

  simpl in H.
  assert (bsize f1 <= n /\ bsize f2 <= n) by omega.
  destruct H1.
  assert (full_quan f1 /\ full_quan f2).
   split;intros v H3;spec H0 v;simpl in H0;detach H0;
   try rewrite in_app_iff...
  destruct H3.
  generalize (IHn f1 H1 H3);intro.
  generalize (IHn f2 H2 H4);intro.
  destruct H5 as [b1 H5]. destruct H6 as [b2 H6].
  rewrite H5,H6. simpl. icase b1. exists b2... exists false...

  simpl in H.
  assert (bsize f1 <= n /\ bsize f2 <= n) by omega.
  destruct H1.
  assert (full_quan f1 /\ full_quan f2).
   split;intros v H3;spec H0 v;simpl in H0;detach H0;
   try rewrite in_app_iff...
  destruct H3.
  generalize (IHn f1 H1 H3);intro.
  generalize (IHn f2 H2 H4);intro.
  destruct H5 as [b1 H5]. destruct H6 as [b2 H6].
  rewrite H5,H6. simpl. icase b1. exists true... exists b2...

  simpl in H.
  assert (bsize f1 <= n /\ bsize f2 <= n) by omega.
  destruct H1.
  assert (full_quan f1 /\ full_quan f2).
   split;intros v H3;spec H0 v;simpl in H0;detach H0;
   try rewrite in_app_iff...
  destruct H3.
  generalize (IHn f1 H1 H3);intro.
  generalize (IHn f2 H2 H4);intro.
  destruct H5 as [b1 H5]. destruct H6 as [b2 H6].
  rewrite H5,H6. simpl. icase b1. exists b2... exists true...

  simpl in H.
  assert (bsize f <= n) by omega.
  assert (full_quan f).
   intros v H2. spec H0 v. spec H0...
  spec IHn f H1 H2. destruct IHn as [b IHn].
  rewrite IHn. simpl. exists (negb b)...

  simpl in H.
  assert (bsize f <= n) by omega.
  assert (bsize (bsubst f v true) <= n /\ bsize (bsubst f v false) <= n).
   split;rewrite bsize_bsubst...
  destruct H2.
  assert (full_quan (bsubst f v true) /\ full_quan (bsubst f v false)).
   split;intros v' H4;
   spec H0 v';detach H0...
   simpl in H0. destruct (eq_dec v' v);subst.
   apply bsubst_not_free_id. apply bsubst_not_free_diff...
   apply bsubst_sublist in H4... right...
   simpl in H0. destruct (eq_dec v' v);subst.
   apply bsubst_not_free_id. apply bsubst_not_free_diff...
   apply bsubst_sublist in H4... right...
  destruct H4.
  generalize (IHn _ H2 H4);intro.
  generalize (IHn _ H3 H5);intro.
  destruct H6 as [b1 H6]. destruct H7 as [b2 H7].
  unfold quan_elim_exF.
  repeat rewrite<- quan_elim_bsubst.
  rewrite H7,H6. simpl. icase b1... exists true... exists b2...

  simpl in H.
  assert (bsize f <= n) by omega.
  assert (bsize (bsubst f v true) <= n /\ bsize (bsubst f v false) <= n).
   split;rewrite bsize_bsubst...
  destruct H2.
  assert (full_quan (bsubst f v true) /\ full_quan (bsubst f v false)).
   split;intros v' H4;
   spec H0 v';detach H0...
   simpl in H0. destruct (eq_dec v' v);subst.
   apply bsubst_not_free_id. apply bsubst_not_free_diff...
   apply bsubst_sublist in H4... right...
   simpl in H0. destruct (eq_dec v' v);subst.
   apply bsubst_not_free_id. apply bsubst_not_free_diff...
   apply bsubst_sublist in H4... right...
  destruct H4.
  generalize (IHn _ H2 H4);intro.
  generalize (IHn _ H3 H5);intro.
  destruct H6 as [b1 H6]. destruct H7 as [b2 H7].
  unfold quan_elim_allF.
  repeat rewrite<- quan_elim_bsubst.
  rewrite H7,H6. simpl. icase b1... exists b2... exists false...
 Qed.

 Definition bsolver (f : bF) :=
 match check_bval (quan_elim (fsimpl f)) with
 |bT b => Some b
 |_ => None
 end.

 Lemma fsimpl_onepass_vars: forall f,
  sublist (vars (fsimpl_onepass f)) (vars f).
 Proof with try tauto.
  intros f v.
  icase f;simpl in *;
  try case_eq (check_bval f1);
  try case_eq (check_bval f2);
  try case_eq (check_bval f);
  intros;
  try icase b0; try icase b;
  simpl in *; try rewrite in_app_iff in *...
 Qed.

 Lemma fsimpl_onepass_not_free: forall f v,
  not_free v f -> not_free v (fsimpl_onepass f).
 Proof with try tauto.
  intros.
  icase f;simpl in *;
  try case_eq (check_bval f1);
  try case_eq (check_bval f2);
  try case_eq (check_bval f);
  simpl;intros;
  try icase b0;try icase b;simpl...
 Qed.

 Opaque fsimpl_onepass.

 Lemma fsimpl_vars: forall f,
  sublist (vars (fsimpl f)) (vars f).
 Proof with try tauto.
  induction f;simpl;repeat intro...
  apply fsimpl_onepass_vars in H;simpl in *.
  repeat rewrite in_app_iff in *. spec IHf1 e;spec IHf2 e...
  apply fsimpl_onepass_vars in H;simpl in *.
  repeat rewrite in_app_iff in *. spec IHf1 e;spec IHf2 e...
  apply fsimpl_onepass_vars in H;simpl in *.
  repeat rewrite in_app_iff in *. spec IHf1 e;spec IHf2 e...
  apply fsimpl_onepass_vars in H;simpl in *. spec IHf e...
  apply fsimpl_onepass_vars in H;simpl in *. spec IHf e...
  apply fsimpl_onepass_vars in H;simpl in *. spec IHf e...
 Qed.

 Lemma fsimpl_not_free: forall f v,
  not_free v f -> not_free v (fsimpl f).
 Proof with try tauto.
  induction f;simpl;repeat intro;
  try apply fsimpl_onepass_not_free;simpl;
  try spec IHf1 v;try spec IHf2 v; try generalize (IHf v);intros...
  destruct (eq_dec v0 v);subst...
  apply IHf...
  destruct (eq_dec v0 v);subst...
  apply IHf...
 Qed.

 Lemma fsimpl_full_quan_preserve: forall f,
  full_quan f -> full_quan (fsimpl f).
 Proof with try tauto.
  intros. unfold full_quan in *.
  intros.
  apply fsimpl_not_free.
  apply H. apply fsimpl_vars...
 Qed.

 Lemma bsolver_Some: forall f,
  full_quan f ->
  exists b, bsolver f = Some b.
 Proof with try tauto.
  intros. apply fsimpl_full_quan_preserve in H.
  unfold bsolver.
  case_eq (check_bval (quan_elim (fsimpl f)));intros.
  exists b...
  apply quan_elim_full_quan in H.
  destruct H as [b1 H]. rewrite H in H0.
  inv H0.
 Qed.

 Lemma bsolver_valid: forall f,
  full_quan f ->
  (bsolver f = Some true <-> valid f).
 Proof with try tauto.
  intros. apply fsimpl_full_quan_preserve in H.
  unfold bsolver.
  generalize (quan_elim_full_quan _ H);intro.
  destruct H0 as [b H0]. rewrite H0. simpl.
  split;intros. inv H1. repeat intro.
  generalize (quan_elim_beval (fsimpl f) a);intro.
  rewrite H0 in H1. rewrite<- fsimpl_beval in H1.
  simpl in *. rewrite H1...
  spec H1 (fun (v : var) => false).
  simpl in H1.
  rewrite fsimpl_beval in H1.
  rewrite <- quan_elim_beval in H1.
  rewrite H0 in H1. simpl in H1.
  subst...
 Qed.

 Lemma bsolver_unsat: forall f,
  full_quan f ->
  (bsolver f = Some false <-> unsat f).
 Proof with try tauto.
  intros. apply fsimpl_full_quan_preserve in H.
  rewrite bF_unsat_rewrite.
  unfold bsolver.
  generalize (quan_elim_full_quan _ H);intro.
  destruct H0 as [b H0]. rewrite H0. simpl.
  split;intros. inv H1. repeat intro.
  generalize (quan_elim_beval (fsimpl f) rho);intro.
  rewrite H0 in H1. rewrite<- fsimpl_beval in H1.
  simpl in *. rewrite H1...
  spec H1 (fun (v : var) => false).
  simpl in H1.
  rewrite fsimpl_beval in H1.
  rewrite <- quan_elim_beval in H1.
  rewrite H0 in H1. simpl in H1.
  subst...
 Qed.

End BF_solver.

(*
 Module es := Equation_system sv_nat.
 Module bv := Bool_formula sv_nat.
 Module test := BF_solver sv_nat bv.
 Import bv test.

 Definition eqF := fun f1 f2 => orF (andF f1 f2) (andF (negF f1) (negF f2)).

 Fixpoint lF (l1 l2 : list nat) :=
 match (l1,l2) with
 |(nil,nil) => valF true
 |(v1::l1',v2::l2') => andF (eqF (varF v1) (varF v2)) (lF l1' l2')
 |_ => valF false
 end.

 Fixpoint exl (l : list nat) f:=
 match l with
 | nil => f
 |v::l' => exF v (exl l' f)
 end.

 Fixpoint axl (l : list nat) f:=
 match l with
 | nil => f
 |v::l' => allF v (axl l' f)
 end.

 Definition l1 := 1::2::3::4::5::6::7::8::9::10::nil.
 Definition l2 := 11::12::13::14::15::16::17::18::19::20::nil.
 Definition f2 := lF l1 l2.
 Definition f3 := axl l1 (exl l2 f2).
 Eval compute in f3.
 Time Eval compute in (quan_elim f3).

 Definition f1 := exF 1 (allF 2 (orF (varF 1) (varF 2))).

 Time Eval compute in (quan_elim f1).
*)


Require Import FloydSeq.base2.
Require Import FloydSeq.client_lemmas.

Local Open Scope logic.

Fixpoint power_later (n:nat) P :=
    match n with
    | 0%nat => P
    | S n' => later (power_later n' P)
    end
.

Lemma power_now_later: forall n P, P |-- power_later n P.
Proof.
   induction n.
   (* Base step *)
   intros. unfold power_later.
   apply derives_refl.
   (* Induction step *)
   intros. simpl.
   apply derives_trans with (power_later n P).
   apply IHn. apply now_later.
Qed.

Lemma power_later_andp: forall (n:nat) (P Q : mpred), power_later n (P && Q) = (power_later n P) && (power_later n Q).
Proof.
   induction n; intros; simpl.
   reflexivity.
   rewrite -> IHn. apply later_andp.
Qed.

Lemma power_later_exp': forall (n:nat) T (any:T) F,
     power_later n (EX x:T, F x) = EX x:T, (power_later n (F x)).
Proof.
   induction n; intros; simpl.
   reflexivity.
   rewrite -> (IHn T any). apply (later_exp' T any).
Qed.

Lemma power_later_sepcon: forall n P Q, power_later n (P * Q) = (power_later n P) * (power_later n Q).
Proof.
   induction n; intros; simpl.
   reflexivity.
   rewrite -> IHn. apply later_sepcon.
Qed.

Lemma power_later_connect: forall n P, power_later n (|> P) = power_later (n + 1) P.
Proof.
   induction n; intros; simpl.
   reflexivity.
   rewrite -> IHn. reflexivity.
Qed.

Lemma power_later_connect': forall n P, |> (power_later n P) = power_later (n + 1) P.
Proof.
   induction n; intros; simpl.
   reflexivity.
   rewrite -> IHn. reflexivity.
Qed.

Lemma power_later_derives: forall n:nat, forall P Q:mpred,
   P |-- Q -> (power_later n P) |-- (power_later n Q).
Proof.
   induction n; intros; simpl.
   assumption.
   apply later_derives. apply IHn. assumption.
Qed.

Lemma power_later_TT: forall n, TT = power_later n TT.
Proof.
   intros.
   apply pred_ext.
   apply power_now_later.
   normalize.
Qed.

Lemma corable_power_later: forall n P, corable P -> corable (power_later n P).
Proof.
  intros.
  induction n; simpl.
  + exact H.
  + exact (corable_later _ IHn).
Qed.

Ltac power_normalize :=
    repeat (
      try rewrite -> power_later_andp;
      try rewrite -> power_later_sepcon;
      try rewrite <- power_later_TT)
.

Lemma power_later_erase: forall n P Q R, P * Q |-- R -> power_later n P * Q |-- power_later n R.
Proof.
  intros.
  apply derives_trans with (power_later n (P * Q)).
  power_normalize.
  cancel.
  apply power_now_later.
  apply power_later_derives.
  assumption.
Qed.

Lemma power_prop_andp_sepcon:
  forall (n:nat) P Q R, ((power_later n (!! P)) && Q) * R = (power_later n (!! P)) && (Q * R).
Proof.
  intros.
  apply (corable_andp_sepcon1 (power_later n (!! P))).
  apply corable_power_later.
  exact (corable_prop P).
Qed.


(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*              Solange Coupet-Grimal & Catherine Nouvet                    *)
(*                                                                          *)
(*                                                                          *)
(*       Laboratoire d'Informatique Fondamentale de Marseille               *)
(*               CMI-Technopole de Chateau-Gombert                          *)
(*                   39, Rue F. Joliot Curie                                *)
(*                   13453 MARSEILLE Cedex 13                               *)
(*           Contact :Solange.Coupet@cmi.univ-mrs.fr                        *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V7.0                                  *)
(*                             Septembre 2001                               *)
(*                                                                          *)
(****************************************************************************)
(*                             well_founded.v                               *)
(****************************************************************************)

Section well_founded.

Require Export LTL.
Require Import Relations.

Variables (Alpha : Set) (state : Set).

Notation Stream := (stream state) (only parsing).
Notation State_formula := (state_formula state) (only parsing).

Lemma wf_leadsto :
 forall (meas : state -> Alpha -> Prop) (r : relation Alpha)
   (A B C : state_formula state),
 well_founded r ->
 forall str : stream state,
 (forall v : Alpha,
  leads_to_via (state2stream_formula (fun s : state => A s /\ meas s v))
    (state2stream_formula B)
    (state2stream_formula
       (fun s : state => A s /\ (exists t : Alpha, meas s t /\ r t v) \/ C s))
    str) ->
 A (head_str str) /\ (exists v : Alpha, meas (head_str str) v) ->
 until (state2stream_formula B) (state2stream_formula C) str.

intros mes r A B C H_wf str; unfold leads_to_via in |- *;
 unfold implies in |- *; intros H h; elim h; clear h.
intros A_head h; elim h; clear h.
intro v0; generalize str H A_head; clear H A_head str.
elim (H_wf v0); clear v0.
intros v0 H_acc H_rec str H A_head H_meas.
cut
 (always
    (fun str : stream state =>
     state2stream_formula (fun s : state => A s /\ mes s v0) str ->
     until (state2stream_formula B)
       (state2stream_formula
          (fun s : state =>
           A s /\ (exists t : Alpha, mes s t /\ r t v0) \/ C s)) str) str);
 auto.
intro h; inversion h; clear h.
rewrite H2; rewrite H2 in H0; generalize H1; replace str0 with (tl_str str).
2: rewrite <- H2; auto.
clear H1 H2 s0 str0; unfold state2stream_formula in H0;
 cut
  (until (fun str : stream state => B (head_str str))
     (fun str : stream state =>
      A (head_str str) /\ (exists t : Alpha, mes (head_str str) t /\ r t v0) \/
      C (head_str str)) str); try apply H0; auto.
clear H0; intro H_until; generalize H; elim H_until.
clear H H_until A_head H_meas str; intros str H H_always H_always_v0; elim H;
 clear H.
intro H; elim H; clear H.
intros A_head H; elim H; clear H.
intros v H; elim H; clear H.
intros H_meas H_r; apply H_rec with (y := v); auto.
constructor 1; auto.
clear H_rec H_acc H_wf H A_head H_meas H_until str;
 intros s str H_B H_until H_rec H_always; constructor 2;
 auto.
apply H_rec.
intro v;
 cut
  (always
     (fun str : stream state =>
      state2stream_formula (fun s : state => A s /\ mes s v) str ->
      until (state2stream_formula B)
        (state2stream_formula
           (fun s : state =>
            A s /\ (exists t : Alpha, mes s t /\ r t v) \/ C s)) str)
     (cons_str s str)); auto.
clear H_always; intro H_always; inversion H_always; assumption.
simpl in H1; inversion H1; rewrite H2; generalize H0;
 replace str0 with (tl_str str); auto.
rewrite <- H2; auto.
Qed.

Hint Resolve wf_leadsto.

Lemma wf_leadsto_rule :
 forall (mes : state -> Alpha -> Prop) (r : relation Alpha)
   (A B C : state_formula state),
 well_founded r ->
 forall str : stream state,
 (forall v : Alpha,
  leads_to_via (state2stream_formula (fun s : state => A s /\ mes s v))
    (state2stream_formula B)
    (state2stream_formula
       (fun s : state => A s /\ (exists t : Alpha, mes s t /\ r t v) \/ C s))
    str) ->
 leads_to_via
   (state2stream_formula
      (fun s : state => A s /\ (exists t : Alpha, mes s t)))
   (state2stream_formula B) (state2stream_formula C) str.

intros mes r A B C wf_op; cofix.
intro str; case str; intros s tl H; constructor; eauto.
unfold leads_to_via in wf_leadsto_rule; unfold implies in wf_leadsto_rule;
 apply wf_leadsto_rule.
intro v;
 cut
  (leads_to_via (state2stream_formula (fun s : state => A s /\ mes s v))
     (state2stream_formula B)
     (state2stream_formula
        (fun s : state => A s /\ (exists t : Alpha, mes s t /\ r t v) \/ C s))
     (cons_str s tl)); auto.
unfold leads_to_via in |- *; unfold implies in |- *; intro H0;
 inversion_clear H0; assumption.
Qed.

End well_founded.


Require Import init.

Require Import linear_bilinear.
Require Import tensor_product_universal.

Require Import set.
Require Import unordered_list.

Require Import module_category.

(* begin hide *)
Section TensorProductIsomorphisms.

(* end hide *)
Context {F : CRingObj} (M N O : ModuleObj F).

(* begin hide *)
Let U := cring_U F.
Let UP := cring_plus F.
Let UZ := cring_zero F.
Let UN := cring_neg F.
Let UPA := cring_plus_assoc F.
Let UPC := cring_plus_comm F.
Let UPZ := cring_plus_lid F.
Let UPN := cring_plus_linv F.
Let UM := cring_mult F.
Let UO := cring_one F.
Let UMA := cring_mult_assoc F.
Let UMC := cring_mult_comm F.
Let UMO := cring_mult_lid F.
Let UMD := cring_ldist F.
Let V1 := module_V M.
Let VP1 := module_plus M.
Let VZ1 := module_zero M.
Let VN1 := module_neg M.
Let VPA1 := module_plus_assoc M.
Let VPC1 := module_plus_comm M.
Let VPZ1 := module_plus_lid M.
Let VPN1 := module_plus_linv M.
Let SM1 := module_scalar M.
Let SMO1 := module_scalar_id M.
Let SML1 := module_scalar_ldist M.
Let SMR1 := module_scalar_rdist M.
Let SMC1 := module_scalar_comp M.
Let V2 := module_V N.
Let VP2 := module_plus N.
Let VZ2 := module_zero N.
Let VN2 := module_neg N.
Let VPA2 := module_plus_assoc N.
Let VPC2 := module_plus_comm N.
Let VPZ2 := module_plus_lid N.
Let VPN2 := module_plus_linv N.
Let SM2 := module_scalar N.
Let SMO2 := module_scalar_id N.
Let SML2 := module_scalar_ldist N.
Let SMR2 := module_scalar_rdist N.
Let SMC2 := module_scalar_comp N.
Let V3 := module_V O.
Let VP3 := module_plus O.
Let VZ3 := module_zero O.
Let VN3 := module_neg O.
Let VPA3 := module_plus_assoc O.
Let VPC3 := module_plus_comm O.
Let VPZ3 := module_plus_lid O.
Let VPN3 := module_plus_linv O.
Let SM3 := module_scalar O.
Let SMO3 := module_scalar_id O.
Let SML3 := module_scalar_ldist O.
Let SMR3 := module_scalar_rdist O.
Let SMC3 := module_scalar_comp O.
Existing Instances UP UZ UN UPA UPC UPZ UPN UM UO UMA UMC UMO UMD VP1 VZ1 VN1
    VPA1 VPC1 VPZ1 VPN1 SM1 SMO1 SML1 SMR1 SMC1 VP2 VZ2 VN2 VPA2 VPC2 VPZ2 VPN2
    SM2 SMO2 SML2 SMR2 SMC2 VP3 VZ3 VN3 VPA3 VPC3 VPZ3 VPN3 SM3 SMO3 SML3 SMR3
    SMC3.

(* end hide *)
(* begin show *)
Local Infix "⊗12" := (tensor_mult M N) (at level 40, left associativity).
Local Infix "⊗23" := (tensor_mult N O) (at level 40, left associativity).
Local Infix "⊗1_23" := (tensor_mult M (tensor_product N O)) (at level 40, left associativity).
Local Infix "⊗12_3" := (tensor_mult (tensor_product M N) O) (at level 40, left associativity).
(* end show *)

(* begin hide *)
Let V12 := tensor_product M N.
Let V23 := tensor_product N O.
Let V1_23 := tensor_product M V23.
Let V12_3 := tensor_product V12 O.
Let T1_23_plus := module_plus V1_23.
Let T1_23_scalar := module_scalar V1_23.
Let T12_3_plus := module_plus V12_3.
Let T12_3_scalar := module_scalar V12_3.
Existing Instances T1_23_plus T1_23_scalar T12_3_plus T12_3_scalar.

(* end hide *)
Theorem tensor_product_assoc :
    ∃ f : cat_morphism (MODULE F)
            (tensor_product M (tensor_product N O))
            (tensor_product (tensor_product M N) O),
        isomorphism f ∧
        ∀ a b c, f (a ⊗1_23 (b ⊗23 c)) = (a ⊗12 b) ⊗12_3 c.
Proof.
    pose (T12_plus := module_plus V12).
    pose (T12_zero := module_zero V12).
    pose (T12_neg := module_neg V12).
    pose (T12_plus_comm := module_plus_comm V12).
    pose (T12_plus_assoc := module_plus_assoc V12).
    pose (T12_plus_lid := module_plus_lid V12).
    pose (T12_plus_linv := module_plus_linv V12).
    pose (T12_scalar := module_scalar V12).
    pose (T12_scalar_comp := module_scalar_comp V12).
    pose (T12_scalar_id := module_scalar_id V12).
    pose (T12_scalar_ldist := module_scalar_ldist V12).
    pose (T12_scalar_rdist := module_scalar_rdist V12).
    pose (T23_plus := module_plus V23).
    pose (T23_zero := module_zero V23).
    pose (T23_neg := module_neg V23).
    pose (T23_plus_comm := module_plus_comm V23).
    pose (T23_plus_assoc := module_plus_assoc V23).
    pose (T23_plus_lid := module_plus_lid V23).
    pose (T23_plus_linv := module_plus_linv V23).
    pose (T23_scalar := module_scalar V23).
    pose (T23_scalar_comp := module_scalar_comp V23).
    pose (T23_scalar_id := module_scalar_id V23).
    pose (T23_scalar_ldist := module_scalar_ldist V23).
    pose (T23_scalar_rdist := module_scalar_rdist V23).
    pose (T1_23_zero := module_zero V1_23).
    pose (T1_23_neg := module_neg V1_23).
    pose (T1_23_plus_comm := module_plus_comm V1_23).
    pose (T1_23_plus_assoc := module_plus_assoc V1_23).
    pose (T1_23_plus_lid := module_plus_lid V1_23).
    pose (T1_23_plus_linv := module_plus_linv V1_23).
    pose (T1_23_scalar_comp := module_scalar_comp V1_23).
    pose (T1_23_scalar_id := module_scalar_id V1_23).
    pose (T1_23_scalar_ldist := module_scalar_ldist V1_23).
    pose (T1_23_scalar_rdist := module_scalar_rdist V1_23).
    pose (T12_3_zero := module_zero V12_3).
    pose (T12_3_neg := module_neg V12_3).
    pose (T12_3_plus_comm := module_plus_comm V12_3).
    pose (T12_3_plus_assoc := module_plus_assoc V12_3).
    pose (T12_3_plus_lid := module_plus_lid V12_3).
    pose (T12_3_plus_linv := module_plus_linv V12_3).
    pose (T12_3_scalar_comp := module_scalar_comp V12_3).
    pose (T12_3_scalar_id := module_scalar_id V12_3).
    pose (T12_3_scalar_ldist := module_scalar_ldist V12_3).
    pose (T12_3_scalar_rdist := module_scalar_rdist V12_3).
    pose (f1 a b c := (a ⊗12 b) ⊗12_3 c).
    assert (∀ a, bilinear (f1 a)) as f1_bil.
    {
        intros v.
        unfold f1.
        repeat split; intros.
        -   rewrite (tensor_rscalar M N).
            rewrite tensor_lscalar.
            reflexivity.
        -   rewrite (tensor_rscalar _ O).
            reflexivity.
        -   rewrite (tensor_ldist M N).
            rewrite tensor_rdist.
            reflexivity.
        -   rewrite (tensor_ldist _ O).
            reflexivity.
    }
    pose (f2_base a := make_bilinear _ _ _ _ (f1_bil a)).
    pose (f2 a := ex_singleton (tensor_product_universal _ _ (f2_base a))).
    cbn in f2.
    pose (f3 a b := [f2 a|] b).
    assert (bilinear f3) as f3_bil.
    {
        repeat split; intros.
        -   unfold f3.
            unfold f2.
            destruct (ex_singleton _) as [fav fav_in].
            destruct (ex_singleton _) as [fv fv_in]; cbn.
            unfold bilinear_from_set in fav_in, fv_in.
            cbn in fav, fav_in, fv, fv_in.
            pose proof (tensor_sum _ _ v2) as [l v2_eq]; subst v2.
            induction l using ulist_induction.
            +   rewrite ulist_image_end, ulist_sum_end.
                do 2 rewrite module_homo_zero.
                rewrite scalar_ranni.
                reflexivity.
            +   rewrite ulist_image_add, ulist_sum_add.
                rewrite (@module_homo_plus _ _ _ fav).
                rewrite (@module_homo_plus _ _ _ fv).
                rewrite scalar_ldist.
                rewrite <- IHl.
                apply rplus.
                destruct a0 as [a0 [u [v eq]]]; subst a0; cbn.
                unfold tensor_mult; cbn.
                rewrite fav_in, fv_in.
                unfold f1.
                rewrite (tensor_lscalar M N).
                rewrite tensor_lscalar.
                reflexivity.
        -   unfold f3.
            apply (@module_homo_scalar _ _ _ [f2 v1|]).
        -   unfold f3.
            unfold f2.
            destruct (ex_singleton _) as [fv12 fv12_in].
            destruct (ex_singleton _) as [fv1 fv1_in].
            destruct (ex_singleton _) as [fv2 fv2_in].
            cbn.
            unfold bilinear_from_set in fv12_in, fv1_in, fv2_in.
            cbn in fv12, fv12_in, fv1, fv1_in, fv2, fv2_in.
            pose proof (tensor_sum _ _ v3) as [l v3_eq]; subst v3.
            induction l using ulist_induction.
            +   rewrite ulist_image_end, ulist_sum_end.
                do 3 rewrite module_homo_zero.
                rewrite plus_lid.
                reflexivity.
            +   rewrite ulist_image_add, ulist_sum_add.
                rewrite (@module_homo_plus _ _ _ fv12).
                rewrite (@module_homo_plus _ _ _ fv1).
                rewrite (@module_homo_plus _ _ _ fv2).
                rewrite IHl; clear IHl.
                do 2 rewrite plus_assoc.
                apply rplus.
                rewrite plus_comm.
                rewrite (plus_comm (fv1 [a|])).
                rewrite <- plus_assoc.
                apply lplus.
                destruct a as [a [u [v eq]]]; subst a; cbn.
                unfold tensor_mult; rewrite fv12_in, fv1_in, fv2_in.
                unfold f1.
                rewrite (tensor_rdist M N).
                rewrite tensor_rdist.
                reflexivity.
        -   unfold f3.
            apply (@module_homo_plus _ _ _ [f2 v1|]).
    }
    pose (f_base := make_bilinear _ _ _ _ f3_bil).
    pose proof (tensor_product_universal _ _ f_base) as f_ex.
    apply ex_singleton in f_ex as [f f_in].
    cbn in f.
    unfold bilinear_from_set in f_in; cbn in f_in.
    clear f_base.
    exists f.
    split.
    -   pose (g1 c a b := a ⊗1_23 (b ⊗23 c)).
        assert (∀ c, bilinear (g1 c)) as g1_bil.
        {
            intros v.
            unfold g1.
            repeat split; intros.
            -   apply tensor_lscalar.
            -   rewrite (tensor_lscalar N O).
                rewrite tensor_rscalar.
                reflexivity.
            -   apply tensor_rdist.
            -   rewrite (tensor_rdist N O).
                rewrite tensor_ldist.
                reflexivity.
        }
        pose (g2_base c := make_bilinear _ _ _ _ (g1_bil c)).
        pose (g2 c := ex_singleton (tensor_product_universal _ _ (g2_base c))).
        cbn in g2.
        pose (g3 b a := [g2 a|] b).
        assert (bilinear g3) as g3_bil.
        {
            repeat split; intros.
            -   unfold g3.
                apply (@module_homo_scalar _ _ _ [g2 v2|]).
            -   unfold g3.
                unfold g2.
                destruct (ex_singleton _) as [gav gav_in].
                destruct (ex_singleton _) as [gv gv_in]; cbn.
                unfold bilinear_from_set in gav_in, gv_in.
                cbn in gav, gav_in, gv, gv_in.
                pose proof (tensor_sum _ _ v1) as [l v1_eq]; subst v1.
                induction l using ulist_induction.
                +   rewrite ulist_image_end, ulist_sum_end.
                    do 2 rewrite module_homo_zero.
                    rewrite scalar_ranni.
                    reflexivity.
                +   rewrite ulist_image_add, ulist_sum_add.
                    rewrite (@module_homo_plus _ _ _ gav).
                    rewrite (@module_homo_plus _ _ _ gv).
                    rewrite scalar_ldist.
                    rewrite <- IHl.
                    apply rplus.
                    destruct a0 as [a0 [u [v eq]]]; subst a0; cbn.
                    unfold tensor_mult; cbn.
                    rewrite gav_in, gv_in.
                    unfold g1.
                    rewrite (tensor_rscalar N O).
                    rewrite tensor_rscalar.
                    reflexivity.
            -   unfold g3.
                apply (@module_homo_plus _ _ _ [g2 v3|]).
            -   unfold g3.
                unfold g2.
                destruct (ex_singleton _) as [gv12 gv12_in].
                destruct (ex_singleton _) as [gv1 gv1_in].
                destruct (ex_singleton _) as [gv2 gv2_in].
                cbn.
                unfold bilinear_from_set in gv12_in, gv1_in, gv2_in.
                cbn in gv12, gv12_in, gv1, gv1_in, gv2, gv2_in.
                pose proof (tensor_sum _ _ v1) as [l v1_eq]; subst v1.
                induction l using ulist_induction.
                +   rewrite ulist_image_end, ulist_sum_end.
                    do 3 rewrite module_homo_zero.
                    rewrite plus_lid.
                    reflexivity.
                +   rewrite ulist_image_add, ulist_sum_add.
                    rewrite (@module_homo_plus _ _ _ gv12).
                    rewrite (@module_homo_plus _ _ _ gv1).
                    rewrite (@module_homo_plus _ _ _ gv2).
                    rewrite IHl; clear IHl.
                    do 2 rewrite plus_assoc.
                    apply rplus.
                    rewrite plus_comm.
                    rewrite (plus_comm (gv1 [a|])).
                    rewrite <- plus_assoc.
                    apply lplus.
                    destruct a as [a [u [v eq]]]; subst a; cbn.
                    unfold tensor_mult; rewrite gv12_in, gv1_in, gv2_in.
                    unfold g1.
                    rewrite (tensor_ldist N O).
                    apply tensor_ldist.
        }
        pose (g_base := make_bilinear _ _ _ _ g3_bil).
        pose proof (tensor_product_universal _ _ g_base) as g_ex.
        apply ex_singleton in g_ex as [g g_in].
        cbn in g.
        unfold bilinear_from_set in g_in; cbn in g_in.
        clear g_base.
        exists g.
        cbn.
        unfold module_homo_compose, module_homo_id; cbn.
        split; apply module_homomorphism_eq; cbn.
        +   intros x.
            pose proof (tensor_sum _ _ x) as [l1 x_eq]; subst x.
            induction l1 using ulist_induction.
            *   rewrite ulist_image_end, ulist_sum_end.
                do 2 rewrite module_homo_zero.
                reflexivity.
            *   rewrite ulist_image_add, ulist_sum_add.
                rewrite (@module_homo_plus _ _ _ g).
                rewrite (@module_homo_plus _ _ _ f).
                rewrite <- IHl1 at 2.
                apply rplus.
                destruct a as [a [u [v a_eq]]]; subst a; cbn.
                unfold tensor_mult at 1; rewrite g_in.
                unfold g3.
                unfold g2.
                destruct (ex_singleton _) as [h h_in]; cbn.
                unfold bilinear_from_set in h_in.
                pose proof (tensor_sum _ _ u) as [l2 u_eq]; subst u.
                induction l2 using ulist_induction.
                --  rewrite ulist_image_end, ulist_sum_end.
                    rewrite tensor_product_lanni.
                    do 2 rewrite module_homo_zero.
                    reflexivity.
                --  rewrite ulist_image_add, ulist_sum_add.
                    rewrite (@module_homo_plus _ _ _ h).
                    rewrite (@module_homo_plus _ _ _ f).
                    rewrite tensor_rdist.
                    rewrite IHl2.
                    apply rplus.
                    destruct a as [a [u' [v' eq]]]; subst a.
                    cbn.
                    unfold tensor_mult at 1; rewrite h_in.
                    unfold g2_base; cbn.
                    unfold g1.
                    unfold tensor_mult at 1 2; rewrite f_in.
                    unfold f3, f2.
                    destruct (ex_singleton _) as [h' h'_in]; cbn.
                    unfold bilinear_from_set in h'_in; cbn in h', h'_in.
                    rewrite h'_in.
                    unfold f1.
                    reflexivity.
        +   intros x.
            pose proof (tensor_sum _ _ x) as [l x_eq]; subst x.
            induction l using ulist_induction.
            *   rewrite ulist_image_end, ulist_sum_end.
                do 2 rewrite module_homo_zero.
                reflexivity.
            *   rewrite ulist_image_add, ulist_sum_add.
                rewrite (@module_homo_plus _ _ _ f).
                rewrite (@module_homo_plus _ _ _ g).
                rewrite <- IHl at 2.
                apply rplus.
                destruct a as [a [u [v a_eq]]]; subst a; cbn.
                unfold tensor_mult at 1; rewrite f_in.
                unfold f3, f2.
                destruct (ex_singleton _) as [h h_in]; cbn.
                unfold bilinear_from_set in h_in.
                pose proof (tensor_sum _ _ v) as [l2 v_eq]; subst v.
                induction l2 using ulist_induction.
                --  rewrite ulist_image_end, ulist_sum_end.
                    rewrite tensor_product_ranni.
                    do 2 rewrite module_homo_zero.
                    reflexivity.
                --  rewrite ulist_image_add, ulist_sum_add.
                    rewrite (@module_homo_plus _ _ _ h).
                    rewrite (@module_homo_plus _ _ _ g).
                    rewrite tensor_ldist.
                    rewrite IHl2.
                    apply rplus.
                    destruct a as [a [u' [v' eq]]]; subst a.
                    cbn.
                    unfold tensor_mult at 1; rewrite h_in.
                    unfold f2_base; cbn.
                    unfold f1.
                    unfold tensor_mult at 1 2; rewrite g_in.
                    unfold g3, g2.
                    destruct (ex_singleton _) as [h' h'_in]; cbn.
                    unfold bilinear_from_set in h'_in; cbn in h'_in.
                    rewrite h'_in.
                    unfold g1.
                    reflexivity.
    -   intros a b c.
        unfold tensor_mult at 1 2.
        rewrite f_in.
        unfold f3, f2.
        destruct (ex_singleton _) as [fa fa_in]; cbn.
        unfold bilinear_from_set in fa_in.
        rewrite fa_in.
        reflexivity.
Qed.

Definition tensor_product_assoc_homo := ex_val tensor_product_assoc.
Definition tensor_product_assoc_f := module_homo_f tensor_product_assoc_homo.
Let af := tensor_product_assoc_f.

Theorem tensor_product_assoc_eq :
    ∀ a b c, af (a ⊗1_23 (b ⊗23 c)) = (a ⊗12 b) ⊗12_3 c.
Proof.
    apply (ex_proof tensor_product_assoc).
Qed.

Theorem tensor_product_assoc_plus : ∀ a b, af (a + b) = af a + af b.
Proof.
    apply (@module_homo_plus _ _ _ (ex_val tensor_product_assoc)).
Qed.
Theorem tensor_product_assoc_scalar : ∀ a v, af (a · v) = a · af v.
Proof.
    apply (@module_homo_scalar _ _ _ (ex_val tensor_product_assoc)).
Qed.

Theorem tensor_product_assoc_iso : isomorphism tensor_product_assoc_homo.
Proof.
    apply (ex_proof tensor_product_assoc).
Qed.

Theorem tensor_product_assoc_bij : Bijective af.
Proof.
    pose proof (land (ex_proof tensor_product_assoc))
        as [[g g_plus g_scalar] [fg gf]].
    cbn in *.
    unfold module_homo_compose, module_homo_id in *; cbn in *.
    inversion fg as [fg']; clear fg.
    inversion gf as [gf']; clear gf.
    apply (inverse_ex_bijective af g); split.
    -   apply func_eq.
        exact fg'.
    -   apply func_eq.
        exact gf'.
Qed.

Definition tensor_product_assoc_inv_homo
    := ex_val (land (ex_proof tensor_product_assoc)).
Definition tensor_product_assoc_inv_f
    := module_homo_f tensor_product_assoc_inv_homo.

Let af' := tensor_product_assoc_inv_f.

Theorem tensor_product_assoc_inv_eq :
    ∀ a b c, af' ((a ⊗12 b) ⊗12_3 c) = a ⊗1_23 (b ⊗23 c).
Proof.
    intros a b c.
    unfold af', tensor_product_assoc_inv_f, tensor_product_assoc_inv_homo.
    rewrite_ex_val f [fg gf].
    destruct (ex_to_type _) as [g [g_iso g_eq]]; cbn in *.
    unfold module_homo_compose, module_homo_id in gf; cbn in gf.
    inversion gf as [gf']; clear gf.
    pose proof (func_eq _ _ gf') as gf; clear gf'; cbn in gf.
    rewrite <- gf.
    apply f_equal.
    rewrite g_eq.
    reflexivity.
Qed.

Theorem tensor_product_assoc_inv_plus : ∀ a b, af' (a + b) = af' a + af' b.
Proof.
    apply (@module_homo_plus _ _ _ tensor_product_assoc_inv_homo).
Qed.
Theorem tensor_product_assoc_inv_scalar : ∀ a v, af' (a · v) = a · af' v.
Proof.
    apply (@module_homo_scalar _ _ _ tensor_product_assoc_inv_homo).
Qed.

Theorem tensor_product_assoc_inv_iso : isomorphism tensor_product_assoc_inv_homo.
Proof.
    unfold af', tensor_product_assoc_inv_f, tensor_product_assoc_inv_homo.
    rewrite_ex_val f fg.
    destruct (ex_to_type _) as [g [g_iso g_eq]]; cbn in *.
    exists g.
    cbn.
    split; apply fg.
Qed.

Theorem tensor_product_assoc_inv_bij : Bijective af'.
Proof.
    pose proof tensor_product_assoc_inv_iso as [[g g_plus g_scalar] [fg gf]].
    unfold module_homo_compose, module_homo_id in *; cbn in *.
    inversion fg as [fg']; clear fg.
    inversion gf as [gf']; clear gf.
    apply (inverse_ex_bijective _ g); split.
    -   apply func_eq.
        exact fg'.
    -   apply func_eq.
        exact gf'.
Qed.
(* begin hide *)

End TensorProductIsomorphisms.
(* end hide *)


(* The spec and proof of the following rules are based on `The Ramifications  *)
(* of Sharing in Data Structures' by Aquinas Hobor and Jules Villard.         *)
(*    RAMIF_PLAIN.frame                                                       *)
(*    RAMIF_PLAIN.split                                                       *)
(* The following lemmas are found useful by Shengyi Wang, Qinxiang Cao and    *)
(* Aquinas Hobor in 2015 summer in Yale-NUS.                                  *)
(*    RAMIF_PLAIN.solve                                                       *)
(*    RAMIF_Q.reduce                                                          *)
(*    RAMIF_Q.solve                                                           *)
(*    RAMIF_Q.frame                                                           *)
(*    RAMIF_Q.split                                                           *)
(* The following lemmas are developed by Qinxiang Cao in 2015 in Princeton.   *)
(*    RAMIF_PLAIN.trans                                                       *)
(*    RAMIF_PLAIN.weak_ramif_spec                                             *)
(*    RAMIF_PLAIN.exp_right                                                   *)
(*    RAMIF_Q.trans                                                           *)
(*    RAMIF_Q.simple_trans                                                    *)
(*    RAMIF_Q.weak_ramif_spec                                                 *)
(*    RAMIF_Q.plain_spec                                                      *)
(*    RAMIF_Q.exp_right                                                       *)

Require Import msl.base.
Require Import msl.Coqlib2.
Require Import msl.simple_CCC.
Require Import msl.seplog.
Require Import msl.log_normalize.

Local Open Scope logic.

Lemma modus_ponens_wand' {A}{ND: NatDed A}{SL: SepLog A}:
                      forall P P' Q: A, P |-- P' ->  derives (sepcon P (wand P' Q)) Q.
Proof.
intros.
   eapply derives_trans; [apply sepcon_derives; [ | apply derives_refl] | apply modus_ponens_wand ].
  auto.
Qed.

Module RAMIF_PLAIN.
Section RAMIF_PLAIN.

Context {A : Type}.
Context {ND : NatDed A}.
Context {SL : SepLog A}.

Lemma solve: forall g l g' l' F, g |-- l * F -> F * l' |-- g' -> g |-- l * (l' -* g').
Proof.
  intros.
  apply derives_trans with (l * F); auto.
  apply sepcon_derives; auto.
  apply wand_sepcon_adjoint.
  auto.
Qed.

Lemma weak_ramif_spec: forall g l g' l', g |-- l * (l' -* g') -> g |-- l * TT.
Proof.
  intros.
  eapply derives_trans; [exact H |].
  apply sepcon_derives; auto.
  apply TT_right.
Qed.

Lemma trans: forall g m l g' m' l',
      g |-- m * (m' -* g') ->
      m |-- l * (l' -* m') ->
      g |-- l * (l' -* g').
Proof.
  intros.
  apply solve with ((l' -* m') * (m' -* g')).
  + eapply derives_trans; [exact H |].
    eapply derives_trans; [apply sepcon_derives; [exact H0 | apply derives_refl] |].
    rewrite sepcon_assoc; auto.
  + rewrite (sepcon_comm _ l'), <- sepcon_assoc.
    eapply derives_trans; [| apply modus_ponens_wand].
    apply sepcon_derives; [| apply derives_refl].
    apply modus_ponens_wand.
Qed.

Lemma trans':
   forall (m l g' m' l': A),
       m |-- l * (l' -* m') ->
       m * (m' -* g') |-- l * (l' -* g').
Proof.
  intros. eapply trans. apply derives_refl. auto.
Qed.

Lemma trans'':
   forall (p g' m' l': A),
       p |-- l' -* m' ->
       p * (m' -* g') |-- (l' -* g').
Proof.
  intros.
  rewrite -> wand_sepcon_adjoint.
  eapply derives_trans; [apply H | ]. clear H.
  rewrite <- wand_sepcon_adjoint.
  rewrite <- wand_sepcon_adjoint.
  pull_left l'. apply modus_ponens_wand'. apply modus_ponens_wand.
Qed.

Lemma split: forall g1 g2 l1 l2 g1' g2' l1' l2',
  g1 |-- l1 * (l1' -* g1') ->
  g2 |-- l2 * (l2' -* g2') ->
  g1 * g2 |-- (l1 * l2) * (l1' * l2' -* g1' * g2').
Proof.
  intros.
  apply solve with ((l1' -* g1') * (l2' -* g2')).
  + rewrite (sepcon_assoc l1), <- (sepcon_assoc l2), (sepcon_comm l2), (sepcon_assoc _ l2), <- (sepcon_assoc l1).
    apply sepcon_derives; auto.
  + eapply derives_trans; [apply sepcon_derives; [apply wand_sepcon_wand | apply derives_refl] |].
    rewrite sepcon_comm; apply modus_ponens_wand.
Qed.

(* Using split to prove frame will lead to a simpler proof. *)
(* But it requires a unitary separation logic.              *)
Lemma frame: forall g l g' l' F, g |-- l * (l' -* g') -> g * F |-- l * (l' -* g' * F).
Proof.
  intros.
  apply solve with ((l' -* g') * F).
  + rewrite <- sepcon_assoc.
    apply sepcon_derives; auto.
  + rewrite (sepcon_comm _ l'), <- sepcon_assoc.
    apply sepcon_derives; [apply modus_ponens_wand | auto].
Qed.

Lemma frame_post: forall g l g' l' F, g |-- l * (l' -* g') -> g |-- l * (l' * F -* g' * F).
Proof.
  intros.
  apply solve with (l' -* g').
  + auto.
  + rewrite <- sepcon_assoc.
    apply sepcon_derives; [rewrite sepcon_comm; apply modus_ponens_wand | auto].
Qed.

Lemma frame_pre: forall g l g' l' F, g |-- l * (l' -* g') -> g * F |-- (l * F) * (l' -* g').
Proof.
  intros.
  apply solve with (l' -* g').
  + rewrite (sepcon_comm l F), sepcon_assoc, (sepcon_comm F).
    apply sepcon_derives; auto.
  + rewrite sepcon_comm; apply modus_ponens_wand.
Qed.

Lemma exp_right: forall {T} (a: T) g l g' l',
  g |-- l * (l' -* g' a) ->
  g |-- l * (l' -* exp g').
Proof.
  intros.
  apply solve with (l' -* g' a); auto.
  apply wand_sepcon_adjoint.
  apply wand_derives; auto.
  apply (exp_right a); auto.
Qed.

End RAMIF_PLAIN.
End RAMIF_PLAIN.

Module RAMIF_Q.
Section RAMIF_Q.

Context {A : Type}.
Context {ND : NatDed A}.
Context {SL : SepLog A}.

Lemma reduce: forall {B} g l (g' l': B -> A),
  g |-- l * (allp (l' -* g')) ->
  g |-- l * (exp l' -* exp g').
Proof.
  intros.
  eapply derives_trans; [exact H |].
  apply sepcon_derives; [auto |].
  apply wand_sepcon_adjoint.
  rewrite exp_sepcon2.
  apply exp_left; intro x; apply (exp_right x).
  apply wand_sepcon_adjoint.
  apply (allp_left _ x).
  auto.
Qed.

Lemma solve: forall {B} g l g' l' F,
  g |-- l * F ->
  (forall x: B, F * l' x |-- g' x) ->
  g |-- l * (allp (l' -* g')).
Proof.
  intros.
  apply derives_trans with (l * F); auto.
  apply sepcon_derives; auto.
  apply allp_right; intro x.
  simpl;
  apply wand_sepcon_adjoint.
  apply H0.
Qed.

Lemma weak_ramif_spec: forall {B} g l (g' l': B -> A),
  g |-- l * allp (l' -* g') -> g |-- l * TT.
Proof.
  intros.
  eapply derives_trans; [exact H |].
  apply sepcon_derives; auto.
  apply TT_right.
Qed.

Lemma plain_spec: forall {B} g l g' l' (x: B),
  g |-- l * (allp (l' -* g')) ->
  g |-- l *  (l' x -* g' x).
Proof.
  intros.
  eapply derives_trans; [exact H |].
  apply sepcon_derives; [auto |].
  apply (allp_left _ x); auto.
Qed.

Lemma trans: forall {B BG BL} g m l g' mG' mL' l' (fG: B -> BG) (fL: B -> BL),
  (forall b, mL' (fL b) |-- mG' (fG b)) ->
  g |-- m * allp (mG' -* g') ->
  m |-- l * allp (l' -* mL') ->
  g |-- l * allp (Basics.compose l' fL -* Basics.compose g' fG).
Proof.
  intros.
  apply solve with (allp (l' -* mL') * allp (mG' -* g')); auto.
  + eapply derives_trans; [exact H0 |].
    eapply derives_trans; [apply sepcon_derives; [exact H1 | apply derives_refl] |].
    rewrite sepcon_assoc; auto.
  + intro b.
    rewrite sepcon_assoc.
    apply wand_sepcon_adjoint.
    apply (allp_left _ (fL b)).
    apply wand_sepcon_adjoint.
    rewrite sepcon_comm, sepcon_assoc, sepcon_comm.
    apply wand_sepcon_adjoint.
    apply derives_trans with (mG' (fG b)).
    - eapply derives_trans; [| apply H].
      simpl; apply modus_ponens_wand.
    - apply wand_sepcon_adjoint.
      rewrite sepcon_comm.
      apply wand_sepcon_adjoint.
      apply (allp_left _ (fG b)).
      auto.
Qed.

Lemma simple_trans: forall {B} g m l (g' m' l': B -> A),
  g |-- m * allp (m' -* g') ->
  m |-- l * allp (l' -* m') ->
  g |-- l * allp (l' -* g').
Proof.
  intros.
  eapply trans with (mL' := m') (mG' := m') (fL := id B) (fG := id B); eauto.
Qed.

Lemma trans'':
  forall {CS: ClassicalSep A}
     {B C: Type} (f: B->C) p l m g1 g2,
     g2 = g1 oo f ->
     p |-- allp (l -* m oo f) ->
     p * allp (m -* g1) |-- allp (l -* g2).
Proof.
   intros.
   subst g2.
   apply allp_right; intro x.
   simpl. rewrite <- wand_sepcon_adjoint.
   rewrite sepcon_assoc.
   eapply derives_trans; [apply sepcon_derives; [apply H0 | apply derives_refl] | ].
    rewrite -> wand_sepcon_adjoint.
  apply allp_left with x.
   rewrite <- wand_sepcon_adjoint.
   simpl.
   rewrite <- !sepcon_assoc.
   pull_left (l x).
   eapply derives_trans; [apply sepcon_derives; [ | apply derives_refl] | ].
   apply modus_ponens_wand.
   rewrite sepcon_comm.
   rewrite -> wand_sepcon_adjoint.
   apply allp_left with (f x). auto.
Qed.

Lemma split: forall {B} g1 g2 l1 l2 (g1' g2' l1' l2': B -> A),
  g1 |-- l1 * allp (l1' -* g1') ->
  g2 |-- l2 * allp (l2' -* g2') ->
  g1 * g2 |-- (l1 * l2) * allp (l1' * l2' -* g1' * g2').
Proof.
  intros.
  apply solve with (allp (l1' -* g1') * allp (l2' -* g2')).
  + rewrite (sepcon_assoc l1), <- (sepcon_assoc l2), (sepcon_comm l2), (sepcon_assoc _ l2), <- (sepcon_assoc l1).
    apply sepcon_derives; auto.
  + intros x.
    change ((l1' * l2') x) with (l1' x * l2' x).
    rewrite <- (sepcon_assoc _ (l1' x)), (sepcon_assoc _ _ (l1' x)), (sepcon_comm _ (l1' x)), <- (sepcon_assoc _ (l1' x)), (sepcon_assoc _ _ (l2' x)).
    apply sepcon_derives.
    - apply wand_sepcon_adjoint.
      apply (allp_left _ x); auto.
    - apply wand_sepcon_adjoint.
      apply (allp_left _ x).
      auto.
Qed.

(* Using split to prove frame will lead to a simpler proof. *)
(* But it requires a unitary separation logic.              *)
Lemma frame: forall {B} g l (g' l': B -> A) F,
  g |-- l * allp (l' -* g') ->
  g * F |-- l * allp (l' -* g' * Basics.const F).
Proof.
  intros.
  apply solve with (allp (l' -* g') * F).
  + rewrite <- sepcon_assoc.
    apply sepcon_derives; auto.
  + intros x; unfold Basics.const; simpl.
    rewrite (sepcon_comm _ (l' x)), <- sepcon_assoc.
    apply sepcon_derives; [| auto].
    rewrite sepcon_comm; apply wand_sepcon_adjoint.
    apply (allp_left _ x); auto.
Qed.

Lemma frame_post: forall {B} g l (g' l' F: B -> A),
  g |-- l * allp (l' -* g') ->
  g |-- l * allp (l' * F -* g' * F).
Proof.
  intros.
  apply solve with (allp (l' -* g')).
  + auto.
  + intros x; simpl.
    rewrite <- sepcon_assoc.
    apply sepcon_derives; [rewrite sepcon_comm | auto].
    rewrite sepcon_comm; apply wand_sepcon_adjoint.
    apply (allp_left _ x); auto.
Qed.

Lemma frame_pre: forall {B} g l (g' l': B -> A) F,
  g |-- l * allp (l' -* g') ->
  g * F |-- (l * F) * allp (l' -* g').
Proof.
  intros.
  apply solve with (allp (l' -* g')).
  + rewrite (sepcon_comm l F), sepcon_assoc, (sepcon_comm F).
    apply sepcon_derives; auto.
  + intros x.
    apply wand_sepcon_adjoint.
    apply (allp_left _ x); auto.
Qed.

Lemma exp_right: forall {T B} (a: B -> T) g l (g': T -> B -> A) (l': B -> A),
  g |-- l * allp (l' -* (fun b => g' (a b) b)) ->
  g |-- l * allp (l' -* exp g').
Proof.
  intros.
  apply solve with (allp (l' -* (fun b => g' (a b) b))); auto.
  intros.
  apply wand_sepcon_adjoint.
  apply (allp_left _ x).
  simpl.
  apply wand_derives; auto.
  apply (exp_right (a x)); auto.
Qed.

End RAMIF_Q.

Ltac formalize :=
  match goal with
  | |- @derives ?Pred _ ?g (?l * @allp ?Pred _ ?T ?Func) =>
      let g' := fresh "g'" in evar (g': T -> Pred);
      let l' := fresh "l'" in evar (l': T -> Pred);
      let x := fresh "x" in
      let H := fresh "H" in
      assert (Func = l' -* g') as H;
      [
        extensionality x; cbv beta;
        match goal with
        | |- ?L' -* exp ?G' = _ =>
             super_pattern L' x; super_pattern_in_func G' x
        | |- ?L' -* ?G' = _ =>
             super_pattern L' x; super_pattern G' x
        end;
        match goal with
        | |- ?L' _ -* exp (fun a => ?G' a _) = _ =>
             instantiate (1 := L') in (Value of l');
             instantiate (1 := exp G') in (Value of g')
        | |- ?L' _ -* ?G' _ = _ =>
             instantiate (1 := L') in (Value of l');
             instantiate (1 := G') in (Value of g')
        end;
        subst g' l';
        reflexivity
      | subst g' l'; rewrite H; clear H]
  end.

End RAMIF_Q.

Module RAMIF_Q'.
Section RAMIF_Q'.

Context {A : Type}.
Context {ND : NatDed A}.
Context {SL : SepLog A}.
Context {CoSL: CorableSepLog A}.

Lemma reduce: forall {B} g l p (g' l': B -> A),
  corable p ->
  g |-- l * (allp (p --> (l' -* g'))) ->
  g |-- l * (exp (p && l') -* exp (p && g')).
Proof.
  intros.
  eapply derives_trans; [exact H0 |].
  apply sepcon_derives; [auto |].
  apply wand_sepcon_adjoint.
  rewrite exp_sepcon2.
  apply exp_left; intro x; apply (exp_right x).
  apply wand_sepcon_adjoint.
  apply (allp_left _ x).
  simpl.
  apply wand_sepcon_adjoint.
  rewrite corable_sepcon_andp1 by auto.
  apply andp_right; [apply andp_left1; auto |].
  rewrite <- corable_andp_sepcon1 by auto.
  apply wand_sepcon_adjoint.
  apply modus_ponens.
Qed.

Lemma solve: forall {B} g l p g' l' F,
  corable p ->
  g |-- l * F ->
  (forall x: B, (p x) && (F * l' x) |-- g' x) ->
  g |-- l * (allp (p --> (l' -* g'))).
Proof.
  intros.
  apply derives_trans with (l * F); auto.
  apply sepcon_derives; auto.
  apply allp_right; intro x.
  simpl.
  apply imp_andp_adjoint.
  apply wand_sepcon_adjoint.
  rewrite corable_andp_sepcon2 by auto.
  auto.
Qed.

Lemma weak_ramif_spec: forall {B} g l p (g' l': B -> A),
  g |-- l * allp (p --> l' -* g') -> g |-- l * TT.
Proof.
  intros.
  eapply derives_trans; [exact H |].
  apply sepcon_derives; auto.
  apply TT_right.
Qed.

Lemma plain_spec: forall {B} g l p g' l' (x: B),
  corable p ->
  g |-- p x ->
  g |-- l * allp (p --> (l' -* g')) ->
  g |-- l * (l' x -* g' x).
Proof.
  intros.
  rewrite (add_andp _ _ H1).
  rewrite (add_andp _ _ H0).
  rewrite andp_assoc; apply andp_left2.
  rewrite <- corable_sepcon_andp1 by auto.
  apply sepcon_derives; [auto |].
  rewrite andp_comm; apply imp_andp_adjoint.
  apply (allp_left _ x); auto.
Qed.

Lemma trans: forall {B BG BL} g m l p pG pL g' mG' mL' l' (fG: B -> BG) (fL: B -> BL),
  corable p ->
  corable pL ->
  corable pG ->
  g |-- m * allp (pG --> (mG' -* g')) ->
  m |-- l * allp (pL --> (l' -* mL')) ->
  (forall b, p b |-- pL (fL b)) ->
  (forall b, p b && mL' (fL b) |-- pG (fG b) && mG' (fG b)) ->
  g |-- l * allp (p --> (Basics.compose l' fL -* Basics.compose g' fG)).
Proof.
  intros.
  apply solve with (allp (pL --> (l' -* mL')) * allp (pG --> (mG' -* g'))).
  + simpl; unfold Basics.compose.
    auto.
  + eapply derives_trans; [exact H2 |].
    eapply derives_trans; [apply sepcon_derives; [exact H3 | apply derives_refl] |].
    rewrite sepcon_assoc; auto.
  + intro b.
    unfold Basics.compose.
    rewrite <- !corable_andp_sepcon1 by auto.
    rewrite sepcon_assoc.
    apply wand_sepcon_adjoint.
    rewrite andp_comm; apply imp_andp_adjoint.
    apply (allp_left _ (fL b)); apply imp_andp_adjoint.
    apply wand_sepcon_adjoint.
    rewrite sepcon_comm, sepcon_assoc, sepcon_comm.
    apply wand_sepcon_adjoint.
    apply derives_trans with (pG (fG b) && mG' (fG b)).
    - apply derives_trans with (p b && mL' (fL b)); [| apply H5].
      rewrite corable_sepcon_andp2 by auto.
      apply andp_right; [apply andp_left1; auto |].
      rewrite <- corable_sepcon_andp1 by auto.
      rewrite sepcon_comm.
      apply wand_sepcon_adjoint.
      simpl; eapply derives_trans; [| apply modus_ponens].
      apply andp_derives; [apply H4 | apply derives_refl].
    - apply wand_sepcon_adjoint.
      rewrite sepcon_comm.
      apply wand_sepcon_adjoint.
      apply (allp_left _ (fG b)); simpl.
      apply wand_sepcon_adjoint.
      rewrite corable_sepcon_andp1, <- corable_andp_sepcon1 by auto.
      apply wand_sepcon_adjoint.
      apply modus_ponens.
Qed.

Lemma split: forall {B} g1 g2 l1 l2 (p g1' g2' l1' l2': B -> A),
  (forall x: B, corable (p x)) ->
  g1 |-- l1 * allp (p --> (l1' -* g1')) ->
  g2 |-- l2 * allp (p --> (l2' -* g2')) ->
  g1 * g2 |-- (l1 * l2) * allp (p --> (l1' * l2' -* g1' * g2')).
Proof.
  intros.
  apply solve with (allp (p --> (l1' -* g1')) * allp (p --> (l2' -* g2'))).
  + auto.
  + rewrite (sepcon_assoc l1), <- (sepcon_assoc l2), (sepcon_comm l2), (sepcon_assoc _ l2), <- (sepcon_assoc l1).
    apply sepcon_derives; auto.
  + intros x.
    change ((l1' * l2') x) with (l1' x * l2' x).
    rewrite <- (sepcon_assoc _ (l1' x)), (sepcon_assoc _ _ (l1' x)), (sepcon_comm _ (l1' x)), <- (sepcon_assoc _ (l1' x)), (sepcon_assoc _ _ (l2' x)).
    rewrite <- (andp_dup (p x)), andp_assoc.
    rewrite <- corable_sepcon_andp1, <- corable_andp_sepcon1 by auto.
    rewrite <- !corable_sepcon_andp1 by auto.
    apply sepcon_derives.
    - apply wand_sepcon_adjoint.
      apply (allp_left _ x).
      apply wand_sepcon_adjoint.
      rewrite corable_sepcon_andp1, <- corable_andp_sepcon1 by auto.
      (eapply derives_trans; [apply sepcon_derives; [simpl; intros; apply modus_ponens | apply derives_refl] |]).
      apply wand_sepcon_adjoint; apply derives_refl.
    - apply wand_sepcon_adjoint.
      apply (allp_left _ x).
      apply wand_sepcon_adjoint.
      rewrite corable_sepcon_andp1, <- corable_andp_sepcon1 by auto.
      (eapply derives_trans; [apply sepcon_derives; [simpl; intros; apply modus_ponens | apply derives_refl] |]).
      apply wand_sepcon_adjoint; apply derives_refl.
Qed.

(* Using split to prove frame will lead to a simpler proof. *)
(* But it requires a unitary separation logic.              *)
Lemma frame: forall {B} g l p g' l' F,
  (forall x: B, corable (p x)) ->
  g |-- l * allp (p --> (l' -* g')) ->
  g * F |-- l * allp (p --> (l' -* g' * Basics.const F)).
Proof.
  intros.
  apply solve with (allp (p --> (l' -* g')) * F).
  + auto.
  + rewrite <- sepcon_assoc.
    apply sepcon_derives; auto.
  + intros x; unfold Basics.const; simpl.
    rewrite <- !corable_andp_sepcon1 by auto.
    rewrite (sepcon_comm _ (l' x)), <- sepcon_assoc.
    apply sepcon_derives; [| auto].
    rewrite sepcon_comm; apply wand_sepcon_adjoint.
    rewrite andp_comm; apply imp_andp_adjoint; apply (allp_left _ x); apply imp_andp_adjoint.
    rewrite andp_comm; apply modus_ponens.
Qed.

Lemma frame_post: forall {B} g l (p g' l' F: B -> A),
  (forall x: B, corable (p x)) ->
  g |-- l * allp (p --> (l' -* g')) ->
  g |-- l * allp (p --> (l' * F -* g' * F)).
Proof.
  intros.
  apply solve with (allp (p --> (l' -* g'))).
  + auto.
  + auto.
  + intros x; simpl.
    rewrite <- !corable_andp_sepcon1 by auto.
    rewrite <- sepcon_assoc.
    apply sepcon_derives; [rewrite sepcon_comm | auto].
    rewrite sepcon_comm; apply wand_sepcon_adjoint.
    rewrite andp_comm; apply imp_andp_adjoint; apply (allp_left _ x); apply imp_andp_adjoint.
    rewrite andp_comm; apply modus_ponens.
Qed.

Lemma frame_pre: forall {B} g l (p g' l': B -> A) F,
  (forall x: B, corable (p x)) ->
  g |-- l * allp (p --> (l' -* g')) ->
  g * F |-- (l * F) * allp (p --> (l' -* g')).
Proof.
  intros.
  apply solve with (allp (p --> (l' -* g'))).
  + auto.
  + rewrite (sepcon_comm l F), sepcon_assoc, (sepcon_comm F).
    apply sepcon_derives; auto.
  + intros x; simpl.
    rewrite <- !corable_andp_sepcon1 by auto.
    apply wand_sepcon_adjoint.
    rewrite andp_comm; apply imp_andp_adjoint; apply (allp_left _ x); apply imp_andp_adjoint.
    rewrite andp_comm; apply modus_ponens.
Qed.

Lemma exp_right: forall {T B} (a: B -> T) p g l (g': T -> B -> A) (l': B -> A),
  corable p ->
  g |-- l * allp (p --> (l' -* (fun b => g' (a b) b))) ->
  g |-- l * allp (p --> (l' -* exp g')).
Proof.
  intros.
  apply solve with (allp (p --> (l' -* (fun b => g' (a b) b)))); auto.
  intros.
  rewrite <- corable_sepcon_andp1 by auto.
  apply wand_sepcon_adjoint.
  apply (allp_left _ x).
  simpl.
  apply wand_sepcon_adjoint.
  rewrite corable_sepcon_andp1 by auto.
  rewrite <- corable_andp_sepcon1 by auto.
  eapply derives_trans; [apply sepcon_derives; [apply modus_ponens | apply derives_refl] |].
  apply wand_sepcon_adjoint.
  apply wand_derives; auto.
  apply (exp_right (a x)); auto.
Qed.

End RAMIF_Q'.

Ltac formalize :=
  match goal with
  | |- @derives ?Pred _ ?g (?l * @allp ?Pred _ ?T ?Func) =>
      let p := fresh "p" in evar (p: T -> Pred);
      let g' := fresh "g'" in evar (g': T -> Pred);
      let l' := fresh "l'" in evar (l': T -> Pred);
      let x := fresh "x" in
      let H := fresh "H" in
      assert (Func = p --> (l' -* g'));
      [
        extensionality x; cbv beta;
        match goal with
        | |- ?P --> (?L' -* exp ?G') = _ =>
             super_pattern P x; super_pattern L' x; super_pattern_in_func G' x
        | |- ?P --> (?L' -* ?G') = _ =>
             super_pattern P x; super_pattern L' x; super_pattern G' x
        end;
        match goal with
        | |- ?P _ --> (?L' _ -* exp (fun a => ?G' a _)) = _ =>
             instantiate (1 := P) in (Value of p);
             instantiate (1 := L') in (Value of l');
             instantiate (1 := exp G') in (Value of g')
        | |- ?P _ --> (?L' _ -* ?G' _) = _ =>
             instantiate (1 := P) in (Value of p);
             instantiate (1 := L') in (Value of l');
             instantiate (1 := G') in (Value of g')
        end;
        subst p g' l';
        reflexivity
      | subst p g' l'; rewrite H; clear H]
  end.

End RAMIF_Q'.