Set Implicit Arguments.

From mathcomp Require Import all_ssreflect all_algebra all_field all_real_closed.
Local Open Scope ring_scope.
Import Num.Theory GRing.Theory.

Require Import quantum IMonad.
From Coq.Logic Require Import JMeq FunctionalExtensionality.

(* The Qbit type is represented here by a (qubit_vector_of 1) *)

(* error state *)
Inductive QIO (A: Type): nat -> nat -> Type :=
  QReturn: forall {i}, A -> QIO A i i
| MkQbit: forall {i o}, (qubit_vector_of 1) -> QIO A (S i) o -> QIO A i o
| ApplyU: forall {i o}, gate_of i -> QIO A i o -> QIO A i o
| Meas: forall {i o}, 'I_i -> (* qubit_vector_of i -> *) (bool -> QIO A i o) -> QIO A i o
| Error: forall {i o}, QIO A i o.

Program Fixpoint qio_bind {i o' o: nat} {A B}
  (z: QIO A i o') (f: A -> QIO B o' o): QIO B i o :=
  match z with
  | QReturn _ a => f a
  | MkQbit _ _ q g => MkQbit q (qio_bind g f)
  | ApplyU _ _ u g => ApplyU u (qio_bind g f)
  | Meas _ _ i g => Meas i (fun b => qio_bind (g b) f)
  | Error _ _ => Error B
  end.
Solve All Obligations with intros; symmetry; assumption.

Program Instance qio_monad:
  IMonad (fun (i: nat) (o: nat) A => QIO A i o) :=
{
  unit i A x := QReturn x;
  IMonad.bind i o' o A B z f := qio_bind z f
}.
Obligation 1.
  reflexivity.
Qed.
Obligation 2.
  intros; simpl; induction x; simpl; try f_equal; try apply functional_extensionality;
    assumption.
Qed.
Obligation 3.
  intros; simpl; induction x; simpl; try f_equal; try apply functional_extensionality;
    [ apply IHx | apply IHx | intros; apply H ].
Qed.

Definition prob_state (n: nat): Type :=
  (complex_stuff.R * qubit_vector_of n)%type.

Fixpoint flatten {A: Type} (l: list (list A)): list A :=
  match l with
  | nil => nil
  | h::t => h ++ flatten t
  end.

(* Require Import Vectors.Vector.
Module Import VectorNotations *)
Program Fixpoint evalQIO {n m: nat} {A: Type} (z: QIO A n m)
  (l: list (complex_stuff.R * qubit_vector_of n)):
  list (complex_stuff.R * qubit_vector_of m * A) :=
  match z with
  | QReturn _ a =>
      List.map (fun (x: complex_stuff.R * qubit_vector_of n) =>
        let (p, qs) := x in
        (p, (cast qs _), a)) l
  | MkQbit _ _ q g => evalQIO g
      (List.map (fun (x: complex_stuff.R * qubit_vector_of n) =>
        let (p, qs) := x in
        (p, (cast (combine q qs) _))
      ) l)
  | ApplyU _ _ u g => evalQIO g
      (List.map (fun (x: complex_stuff.R * qubit_vector_of n) =>
        let (p, qs) := x in
        (p, (apply u qs))
      ) l)
  | Meas _ _ i g => evalQIO (g false)
      (flatten (List.map (fun (x: complex_stuff.R * qubit_vector_of n) =>
        let (p, qs) := x in
        let (x0, x1) := measure_p i qs in
        let (p0, q0) := x0 in
        let (p1, q1) := x1 in
        [:: (p * p0, q0); (p * p1, q1)]
      ) l))
  | Error _ _ =>
     nil
  end.
Obligation 2.
  intros. auto.
Qed.
Solve All Obligations with intros; symmetry; assumption.


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Require Import ClassicalExtras.
Require Import MyNotation.
Require Import Setoid.
Require Import FunctionalExtensionality.
Require Import Setoid.

Require Import Galois.
Require Import LanguageModel.
Require Import TraceModel.
Require Import Properties.
Require Import ChainModel.
Require Import Def.
Require Import TraceCriterion.

Require Import PropExtensionality.
Definition prop_extensionality := propositional_extensionality.

Section Relation.

  Variable Source Target: Language.
  Variable compilation_chain : CompilationChain Source Target.

  Variable trace__S trace__T : Set.

  Local Definition prop__S := prop trace__S.
  Local Definition prop__T := prop trace__T.

  Variable Source_Semantics : Semantics Source trace__S.
  Variable Target_Semantics : Semantics Target trace__T.

  Local Definition sem__S := sem Source_Semantics.
  Local Definition beh__S := beh Source_Semantics.
  Local Definition sem__T := sem Target_Semantics.
  Local Definition beh__T := beh Target_Semantics.
  Local Definition prg__S := prg Source.
  Local Definition prg__T := prg Target.
  Local Definition sat__S := sat Source_Semantics.
  Local Definition sat__T := sat Target_Semantics.

  Local Definition cmp := compile_whole Source Target compilation_chain.

  Local Notation "W ↓" := (cmp W) (at level 50).

  (* Cheating relation *)
  Definition rel : trace__S -> trace__T -> Prop :=
    fun t__S t__T => exists W, sem__S W t__S /\ sem__T (W ↓) t__T.

  Local Definition adjunction := induced_connection rel.

  Local Definition τ' : prop__S -> prop__T := α adjunction.
  Local Definition σ' : prop__T -> prop__S := γ adjunction.

  Local Definition τTP := τTP compilation_chain
                              Source_Semantics Target_Semantics
                              τ'.

  Local Definition σTP := σTP compilation_chain
                              Source_Semantics Target_Semantics
                              σ'.

  Local Definition rel_TC := rel_TC compilation_chain
                                    Source_Semantics Target_Semantics
                                    rel.

  Theorem cmp_is_rel_TC : rel_TC.
  Proof.
    move => W t__T W_t.
    destruct (non_empty_sem Source_Semantics W) as [s W_s].
    exists s. split; auto. now exists W.
  Qed.

  Corollary cmp_is_τTP: τTP.
  Proof. setoid_rewrite <- rel_TC_τTP. exact cmp_is_rel_TC. Qed.

  Corollary cmp_is_σTP : σTP.
  Proof. setoid_rewrite <- rel_TC_σTP. exact cmp_is_rel_TC. Qed.

End Relation.


Require Import ZArith.
Require Import NAux.
Require Import PolSBase.
Require Import PolAux.
Require Import PolAuxList.
Require Import NPolS.
Require Import NPolF.
Require Import PolRBase.

Definition Nreplace_term_aux :=
  replace Z Zplus Zmult Z.opp 0%Z 1%Z is_Z1 is_Z0 is_Zpos is_Zdiv Z.div.

Ltac Nreplace_term term from to occ id :=
  let rfv := FV NCst Nplus Nmult Nminus Nopp term (@nil N) in
  let rfv1 := FV NCst Nplus Nmult Nminus Nopp from rfv in
  let rfv2 := FV NCst Nplus Nmult Nminus Nopp to rfv1 in
  let fv := Trev rfv2 in
  let expr := mkPolexpr Z NCst Nplus Nmult Nminus Nopp term fv in
  let expr_from := mkPolexpr Z NCst Nplus Nmult Nminus Nopp from fv in
  let expr_to := mkPolexpr Z NCst Nplus Nmult Nminus Nopp to fv in
  let re := (eval vm_compute in (Nreplace_term_aux expr expr_from expr_to occ)) in
  let term1 :=
      (eval
         unfold
         Nconvert_back, convert_back, pos_nth, jump,
       hd, tl in (Nconvert_back re fv))
  in
  let term2 := clean_zabs_N term1 in
  match id with
  | true => term2
  | false =>
    match eqterm term term1 with
    | false => term2
    end
  end .

Ltac Npol_is_compare term :=
  match term with
  | (_ < _)%N => constr:(true)
  | (_ > _)%N => constr:(true)
  | (_ <= _)%N => constr:(true)
  | (_ >= _)%N => constr:(true)
  | (?X = _)%N => match type of X with N => constr:(true) end
  | _ => constr:(false)
  end.

Ltac Npol_get_term dir term :=
  match term with
  | (?op ?X ?Y)%N => match dir with P.L => X | P.R => Y end
  | (?X = ?Y)%N => match dir with P.L => X | P.R => Y end
  | _ => fail 1 "Unknown term in Npol_get_term"
  end.

Ltac Npol_replace_term term1 term2 dir1 dir2 occ id :=
  let dir2opp := (eval compute in (P.pol_dir_opp dir2)) in
  let t1 := Npol_get_term dir2 term2 in
  let t2 :=
      match id with
      | true => t1
      | false => Npol_get_term dir2opp term2
      end
  in
  match term1 with
  | (?op ?X ?Y) =>
    match dir1 with
    | P.L => Nreplace_term X t1 t2 occ id
    | P.R => Nreplace_term Y t1 t2 occ id
    end
  | (?X = ?Y)%N =>
    match dir1 with
    | P.L => Nreplace_term X t1 t2 occ id
    | P.R => Nreplace_term Y t1 t2 occ id
    end
  end.

Ltac Npol_aux_dir term dir :=
  match term with
  | (_ < _)%N => dir
  | (_ > _)%N => dir
  | (_ <= _)%N => eval compute in (P.pol_dir_opp dir)
  | (_ >= _)%N => eval compute in (P.pol_dir_opp dir)
  end.

(* Do the replacement *)
Ltac Nreplace_tac_full term dir1 dir2 occ :=
  match term with
  | (?T1 = ?T2)%N =>
    (* We have here a substitution *)
    match goal with
    | |- ?G =>
      let t := Npol_replace_term G term dir1 dir2 occ false in
      match dir1 with
      | P.L =>
        (apply trans_equal with t)
        || (apply Neq_lt_trans_l with t)
        || (apply Neq_gt_trans_l with t)
        || (apply Neq_le_trans_l with t)
        || (apply Neq_ge_trans_l with t)
      | P.R =>
        (apply trans_equal_r with t)
        || (apply Neq_lt_trans_r with t)
        || (apply Neq_gt_trans_r with t)
        || (apply Neq_le_trans_r with t)
        || (apply Neq_ge_trans_r with t)
      end
    end
  | _ =>
    match goal with
    | |- (?X <= ?Y)%N =>
      let t := Npol_replace_term (X <= Y)%N term dir1 dir2 occ false in
      apply N.le_trans with t
    | |- (?X >= ?Y)%N =>
      let t := Npol_replace_term (X >= Y)%N term dir1 dir2 occ false in
      apply Nge_trans with t
    | |- ?G =>
      let t := Npol_replace_term G term dir1 dir2 occ false in
      match Npol_aux_dir term dir1 with
      | P.L => apply N.lt_le_trans with t || apply Ngt_le_trans with t
      | P.R => apply N.le_lt_trans with t || apply Nle_gt_trans with t
      end
    end
  end.

(* Make the term appears *)
Ltac Nreplace_tac_full_id term dir1 dir2 occ :=
  match goal with
  | |- ?G =>
    let t1 := Npol_replace_term G term dir1 dir2 occ true in
    match dir1 with
    | P.L =>
      (apply trans_equal with t1)
      || (apply Neq_lt_trans_l with t1)
      || (apply Neq_gt_trans_l with t1)
      || (apply Neq_le_trans_l with t1)
      || (apply Neq_ge_trans_l with t1)
    | P.R =>
      (apply trans_equal_r with t1)
      || (apply Neq_lt_trans_r with t1)
      || (apply Neq_gt_trans_r with t1)
      || (apply Neq_le_trans_r with t1)
      || (apply Neq_ge_trans_r with t1)
    end; [ring | idtac]
  end.

Ltac Npolrx term dir1 dir2 occ :=
  match Npol_is_compare term with
  | true =>
    Nreplace_tac_full_id term dir1 dir2 occ;
    [Nreplace_tac_full term dir1 dir2 occ]
  | false =>
    let t := type of term in
    match Npol_is_compare t with
    | true =>
      Nreplace_tac_full_id t dir1 dir2 occ;
      [Nreplace_tac_full t dir1 dir2 occ]
    end
  end.

Ltac Npolr term :=
  Npolrx term P.L P.L 1%Z
  || Npolrx term P.R P.L 1%Z
  || Npolrx term P.L P.R 1%Z
  || Npolrx term P.R P.R 1%Z.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^221 - 3
Base: 64
***)

Definition curve : CurveParameters :=
  {|
    sz := 4%nat;
    base := 64;
    bitwidth := 64;
    s := 2^221;
    c := [(1, 3)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


(** Solutions to "Elements of Set Theory" Chapter 6 **)
(** Coq coding by choukh, Oct 2020 **)

Require ZFC.Lib.Choice.
Require Import ZFC.Lib.WosetMin.
Require Import ZFC.Lib.ChoiceFacts.
Require Import ZFC.Lib.NatIsomorphism.
Require Import ZFC.Lib.IndexedFamilyUnion.
Require Export ZFC.Elements.EST6_4.
Import WosetMin.SimpleVer.

(* 所有集合的支配集不能构成一个集合 *)
Example ex6_15 : ¬∃ 𝒜, ∀ B, ∃A ∈ 𝒜, B ≼ A.
Proof with eauto.
  intros [𝒜 H].
  specialize H with (𝒫 ⋃𝒜) as [A [H1 H2]].
  apply union_dominate in H1.
  assert (𝒫 ⋃𝒜 ≼ ⋃𝒜) by (eapply dominate_trans; eauto).
  apply cardLe_iff in H. rewrite card_of_power in H.
  destruct (cardLt_power (|⋃𝒜|)) as [H3 H4]...
  apply H4. eapply cardLe_antisym...
Qed.

Example ex6_16_1 : ∀ A, A ≼ A ⟶ 2.
Proof with neauto; try congruence.
  intros.
  set (λ x y : set, match (ixm (x = y)) with
    | inl _ => Embed 0
    | inr _ => Embed 1
  end) as ℱ.
  set (Func A (A ⟶ 2) (λ x, Func A 2 (ℱ x))) as F.
  assert (HF: ∀x ∈ A, Func A 2 (ℱ x): A ⇒ 2). {
    intros x Hx. apply meta_function. intros y Hy.
    unfold ℱ. destruct (ixm (x = y))...
    apply suc_has_0; apply ω_inductive... apply suc_has_n.
  }
  exists F. apply meta_injection.
  - intros x Hx. apply SepI.
    + apply PowerAx. intros f Hf. apply SepE1 in Hf...
    + apply HF...
  - intros x1 H1 x2 H2 Heq.
    assert ((Func A 2 (ℱ x1))[x1] = (Func A 2 (ℱ x2))[x1]) by congruence.
    rewrite meta_func_ap, meta_func_ap in H...
    unfold ℱ in H. destruct (ixm (x1 = x1))...
    destruct (ixm (x2 = x1))... exfalso. eapply suc_neq_0...
Qed.

Example ex6_16_2 : ∀ A, A ≉ A ⟶ 2.
Proof with neauto; try congruence.
  intros A [F [[Hf Hs] [Hd Hr]]].
  set (Func A 2 (λ x, match (ixm (F[x][x] = 0)) with
    | inl _ => 1
    | inr _ => 0
  end)) as g.
  assert (Hgf: g: A ⇒ 2). {
    apply meta_function. intros x Hx.
    destruct (ixm (F[x][x] = 0)). apply suc_has_n.
    apply suc_has_0; apply ω_inductive...
  }
  assert (Hg: g ∈ A ⟶ 2). {
    apply SepI... apply PowerAx.
    intros p Hp. apply SepE1 in Hp...
  }
  rewrite <- Hr in Hg. apply ranE in Hg as [x Hp].
  apply domI in Hp as Hx. apply func_ap in Hp...
  assert (F[x][x] = g[x]) by congruence.
  unfold g in H. rewrite meta_func_ap in H...
  destruct (ixm (F[x][x] = 0))...
  rewrite e in H. eapply suc_neq_0...
Qed.

Example ex6_17_a : Embed 0 <𝐜 ℵ₀ ∧ 0 + ℵ₀ = ℵ₀ + ℵ₀.
Proof with nauto.
  split. apply cardLt_aleph0_if_finite...
  rewrite cardAdd_comm, cardAdd_0_r, cardAdd_aleph0_aleph0...
Qed.

Example ex6_17_b : Embed 1 <𝐜 2 ^ ℵ₀ ∧ 1 ⋅ 2 ^ ℵ₀ = 2 ^ ℵ₀ ⋅ 2 ^ ℵ₀.
Proof with nauto.
  split. eapply cardLe_lt_trans.
  apply cardLt_aleph0_if_finite... apply cardLt_power...
  rewrite cardMul_comm, cardMul_1_r, cardMul_expAleph0_expAleph0...
Qed.

Example ex6_17_c : Embed 1 <𝐜 Embed 2 ∧ 1 ^ 0 = 2 ^ 0.
Proof with nauto.
  split. apply fin_cardLt_iff_lt... apply suc_has_n...
  rewrite cardExp_0_r, cardExp_0_r...
Qed.

Example ex6_17_d : Embed 1 <𝐜 Embed 2 ∧ 0 ^ 1 = 0 ^ 2.
Proof with nauto.
  split. apply fin_cardLt_iff_lt... apply suc_has_n...
  rewrite cardExp_0_l, cardExp_0_l... apply suc_neq_0.
Qed.

(* ex6_18: see lib/Choice Theorem AC_III_iff_III' *)

(* ==不需要选择公理== *)
(* 有限个非空集合的笛卡尔积非空 *)
Example ex6_19 : ∀ I ℱ, finite I → (∀i ∈ I, ⦿ ℱ i) → ⦿ InfCPrd I ℱ.
Proof with eauto; try congruence.
  intros * [n [Hn Hqn]]. generalize dependent I.
  ω_induction n; intros I Hqn HneX.
  - apply eqnum_empty in Hqn. rewrite Hqn.
    exists ∅. apply SepI.
    + apply SepI. apply empty_in_all_power.
      apply injection_is_func. apply empty_injection.
    + intros i Hi. exfalso0.
  - apply set_eqnum_suc_nonempty in Hqn as HneI...
    destruct HneI as [j Hj]. apply split_one_element in Hj as HeqI.
    rewrite HeqI in Hqn. apply finite_set_remove_one_member in Hqn...
    specialize IH with (I - {j,}) as [f Hf]... {
      intros i Hi. apply HneX. apply SepE1 in Hi...
    }
    apply SepE in Hf as [Hf Hfi].
    apply arrow_iff in Hf as [Hf [Hd Hr]].
    pose proof (HneX _ Hj) as [xⱼ Hxj].
    assert (Hf': is_function (f ∪ {<j, xⱼ>,})). {
      apply bunion_is_func... apply single_pair_is_func.
      apply EmptyI. intros x Hx. apply BInterE in Hx as [H1 H2].
      rewrite dom_of_single_pair in H2.
      rewrite Hd in H1. apply SepE2 in H1...
    }
    assert (Hstar: ∀i ∈ I, (f ∪ {<j, xⱼ>,})[i] ∈ ℱ i). {
      intros i Hi. destruct (classic (i = j)).
      * subst. replace ((f ∪ {<j, xⱼ>,})[j]) with xⱼ...
        symmetry. apply func_ap... apply BUnionI2...
      * assert (Hi': i ∈ I - {j,}). { apply SepI... apply SingNI... }
        replace ((f ∪ {<j, xⱼ>,})[i]) with (f[i])...
        symmetry. apply func_ap... apply BUnionI1. apply func_correct...
    }
    exists (f ∪ {<j, xⱼ>,}). apply SepI.
    apply arrow_iff. split; [|split]...
    + ext Hx.
      * apply domE in Hx as [y Hp]. apply BUnionE in Hp as [].
        apply domI in H. rewrite Hd in H. apply SepE1 in H...
        apply SingE in H. apply op_iff in H as []; subst...
      * destruct (classic (x = j)).
        subst. eapply domI. apply BUnionI2...
        eapply domI. apply BUnionI1. apply func_correct...
        rewrite Hd. apply SepI... apply SingNI...
    + intros i Hi. apply UnionAx. exists (ℱ i). split.
      apply ReplAx. exists i. split... apply Hstar...
    + exact Hstar.
Qed.

(* ex6_20 see EST7_2 Lemma non_woset_ex_descending_chain *)
(* ex6_21 see lib/Choice Theorem AC_VI_to_AC_VII *)
(* ex6_22 see lib/Choice Theorem AC_I_iff_I' *)

Example ex6_23 : ∀ A F g h,
  is_function g → dom g = ω →
  (∀n ∈ ω, g[n] = F[A - h[n]]) → h[∅] = ∅ →
  (∀n ∈ ω, h[n⁺] = h[n] ∪ {F[A - h[n]],}) →
  ∀n ∈ ω, g⟦n⟧ = h[n].
Proof with eauto; try congruence.
  intros * Hfg Hdg Hrg Hh0 Hhn n Hn.
  ω_induction n.
  - ext Hx.
    + apply imgE in Hx as [k [Hk _]]. exfalso0.
    + rewrite Hh0 in Hx. exfalso0.
  - ext Hx.
    + apply imgE in Hx as [k [Hk Hp]]. rewrite Hhn...
      apply BUnionE in Hk as [].
      * apply BUnionI1. rewrite <- IH. eapply imgI...
      * apply BUnionI2. apply SingE in H. subst k.
        apply func_ap in Hp... subst x. rewrite <- Hrg...
    + rewrite Hhn in Hx... apply BUnionE in Hx as [].
      * rewrite <- IH in H. apply imgE in H as [k [Hk Hp]].
        eapply imgI. apply BUnionI1... apply Hp.
      * apply SingE in H. subst x. rewrite <- Hrg...
        eapply imgI. apply BUnionI2... apply func_correct...
Qed.

(* ex6_24 see EST6_4 CardInfSum CardInfProd *)

(** ex6_25 **)

(* 增长序列 *)
Definition incr_seq : (nat → set) → Prop := λ Q,
  ∀ n, Q n ⊆ Q (S n).

(* 若增长序列的元素下标有小于等于关系那么元素有包含关系 *)
Lemma incr_seq_index_le_impl_sub : ∀ Q, incr_seq Q →
  ∀ n m, n <= m → Q n ⊆ Q m.
Proof with auto.
  intros Q Hinc n m Hle.
  induction m.
  - apply Le.le_n_0_eq in Hle. subst...
  - apply PeanoNat.Nat.le_succ_r in Hle as []; [|subst]...
    eapply sub_trans. apply IHm... apply Hinc.
Qed.

Import ZFC.Lib.Choice.

(* ==需要选择公理== *)
Example ex6_25 : AC_III → ∀ Q A, incr_seq Q → A ⊆ ⋃ᵢ Q →
  (∀ B, infinite B → B ⊆ A → ∃ n, infinite (B ∩ Q n)) →
  ∃ n, A ⊆ Q n.
Proof with neauto; try congruence.
  intros AC3 * Hinc Hsuba Hinf.
  apply not_all_not_ex. intros Han.
  assert (Hnea: ∀ n, ⦿ (A - Q n)). {
    intros. apply EmptyNE. intros H.
    apply sub_iff_no_comp in H. eapply Han...
  }
  clear Han.
  pose proof (AC3 A) as [F [_ [_ Hch]]].
  set (λ n, F[A - Q n]) as g.
  set {g n | n ∊ ω} as B.
  assert (Hneb: ⦿ B). {
    exists (F[A - Q 0]). apply ReplAx.
    exists ∅. split... rewrite <- zero, proj_embed_id...
  }
  assert (Hgn1: ∀ n, g n ∈ A - Q n). { intros. apply Hch... }
  assert (Hgn2: ∀ n, ∃ m, g n ∈ Q m). {
    intros. specialize Hgn1 with n.
    apply SepE in Hgn1 as [Hgn _]. apply Hsuba in Hgn.
    apply nat_IFUnionE in Hgn as [m Hgm]. exists m...
  }
  assert (Hgn3: ∀ n, g n ∈ B). {
    intros. apply ReplAx. exists (Embed n). split.
    apply embed_ran. rewrite proj_embed_id...
  }
  assert (Hgn4: ∀ n, g n ∉ Q n). {
    intros. specialize Hgn1 with n.
    apply SepE2 in Hgn1...
  }
  specialize Hinf with B as [n Hinf].
  - intros Hfin.
    set (λ x, {n ∊ ω | x ∈ Q n}) as 𝒩.
    set (λ x, (Min Lt)[𝒩 x]) as f.
    assert (Hmin: ∀b ∈ B, ε_minimum (f b) (𝒩 b)). {
      intros b Hb. apply ω_min.
      apply ReplAx in Hb as [n [Hn Heqb]]. subst b.
      specialize Hgn2 with n as [m Hgn].
      - exists (Embed m). apply SepI.
        apply embed_ran. rewrite proj_embed_id...
      - intros x Hx. apply SepE1 in Hx...
    }
    apply (repl_finite f) in Hfin.
    apply finite_subset_of_ω_is_bounded in Hfin as [m [Hm Hmax]]; revgoals. {
      intros x Hx. apply ReplAx in Hx as [b [Hb Hfb]]. subst x.
      apply Hmin in Hb as [Hfb _]. apply SepE1 in Hfb...
    } {
      destruct Hneb as [b Hb]. exists (f b).
      apply ReplAx. exists b. split...
    }
    cut (B ⊆ Q m). {
      intros Hsub. apply (Hgn4 m). apply Hsub...
    }
    apply ReplAx in Hm as [b [Hb Heqm]].
    apply Hmin in Hb as [Hfb _]. apply SepE in Hfb as [Hfb _].
    assert (Hsub: B ⊆ ⋃{Q n | n ∊ m ⁺}). {
      intros x Hx. assert (Hx' := Hx).
      apply Hmin in Hx' as [Hfx Hsub].
      apply SepE in Hfx as [Hfx Hxq].
      apply UnionAx. exists (Q (f x)). split...
      apply ReplAx. exists (f x). split...
      apply lt_suc_iff_sub... apply Hmax.
      apply ReplAx. exists x. split...
    }
    eapply sub_trans. apply Hsub.
    intros x Hx. apply UnionAx in Hx as [q [Hq Hx]].
    apply ReplAx in Hq as [n [Hn Hq]]. subst q.
    assert (Hnw: n ∈ ω). {
      eapply ω_trans... apply ω_inductive...
    }
    apply BUnionE in Hn as [].
    + apply (incr_seq_index_le_impl_sub Q Hinc n)...
      apply le_isomorphic. repeat rewrite embed_proj_id...
      apply lt_iff_psub...
    + apply SingE in H...
  - intros x Hx. apply ReplAx in Hx as [n [Hn Hx]]. subst x.
    assert (Hsub: A - Q n ⊆ A) by auto. apply Hsub...
  - set {m ∊ ω | g m ∈ Q n} as M.
    set {g m | m ∊ M} as C.
    assert (Hsubm: M ⊆ ω). {
      intros x Hx. apply SepE1 in Hx...
    }
    assert (Heq: B ∩ Q n = C). {
      ext Hx.
      - apply BInterE in Hx as [H1 H2].
        apply ReplAx in H1 as [m [Hm Hgm]]. subst x.
        apply ReplAx. exists m. split... apply SepI...
      - apply ReplAx in Hx as [m [Hm Hgm]]. subst x.
        apply SepE in Hm as [_ Hgm]. apply BInterI...
    }
    assert (HinfM: infinite M). {
      intros Hfin. apply Hinf. rewrite Heq.
      apply (dominated_by_finite_is_finite _ M)...
      set (Func M C (λ x, g x)) as f.
      apply (domain_of_surjection_dominate_range ac1 _ _ f).
      apply meta_surjection.
      - intros x Hx. apply ReplAx. exists x. split...
      - intros y Hy. apply ReplAx in Hy as [x [Hx Heqy]].
        exists x. split...
    }
    pose proof (infinite_subset_of_ω_is_unbound M) as [_ Harc]...
    pose proof (embed_ran n) as Hnw.
    apply Harc in Hnw as [m [Hm Hnm]].
    apply SepE in Hm as [Hm Hgm].
    apply lt_iff_psub in Hnm as [Hnm _]...
    rewrite <- (embed_proj_id m) in Hnm...
    apply le_isomorphic in Hnm.
    apply (incr_seq_index_le_impl_sub Q Hinc) in Hnm.
    apply Hnm in Hgm. specialize Hgn1 with m.
    apply SepE2 in Hgn1...
Qed.


Require Import LL.FOLL.DyadicExc.Tactics.
Require Import LL.FOLL.Dyadic.Tactics.

Section LLAdequacy.
  Context `{OLS: OLSig}.

Theorem LL2N_to_LL3S n B L : LL2N n B L -> LL3S B L.
Proof with sauto.
  intros.
  revert dependent B.
  revert L.
  induction n;intros...
  + inversion H...
    rewrite H0...
    rewrite H0...
  + inversion H...
    all: try match goal with
      | H: Permutation ?L _ |- LL3 |-- ?B; ?L => rewrite H;sauto
     end.
    - LL3exist t.
    - LL3copy F.
 Qed.

   Theorem LL3N_to_LL2 n B L : LL3N n B L -> LL2S B L.
Proof with sauto.
  intros.
  revert dependent B.
  revert L.
  induction n;intros...
  + inversion H...
    LL2init A.
    LL2top M.
  + inversion H...
    LL2plus1 F G M.
    LL2plus2 F G M.
    LL2with F G M.
    LL2bot M.
    LL2par F G M.
    LL2tensor F G M N.
    LL2store F M.
    LL2exist t FX M.
    LL2forall FX M.
    LL2copy F.
    rewrite <- H1...
  Qed.

End LLAdequacy.


(**

 Ahrens, Lumsdaine, Voevodsky, 2015

  Contents:

    - Definition of a precategory with families
    - Proof that reindexing forms a pullback

  The definition is based on Pitts, *Nominal Presentations of the Cubical Sets
  Model of Type Theory*, Def. 3.1:
  http://www.cl.cam.ac.uk/~amp12/papers/nompcs/nompcs.pdf (page=9)
*)

Require Import UniMath.Foundations.All.

Require Import TypeTheory.Auxiliary.CategoryTheoryImports.

Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.categories.HSET.All.
Require Import UniMath.CategoryTheory.limits.pullbacks.
Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.Auxiliary.SetsAndPresheaves.

Local Open Scope precat.

(** * A "preview" of the definition *)

Module Preview.

Variable C : category.
Variable Ty Tm: [C^op, HSET]. (* functor C^op HSET. *)
Variable p : _ ⟦Tm, Ty⟧. (* needs to be written as mor in a precat *)

Variable comp : forall (Γ : C) (A : Ty $p Γ), C.
Variable pi : forall (Γ : C) (A : Ty $p Γ), comp Γ A --> Γ.
Variable q : forall (Γ : C) (A : Ty $p Γ), Tm $p (comp Γ A).

Definition yoTy (Γ : C)
  : Ty $p Γ ≃ _ ⟦(yoneda C Γ) , Ty ⟧.
Proof.
  apply invweq.
  apply yoneda_weq.
Defined.

Definition yoTm (Γ : C)
  : Tm $p Γ ≃ _ ⟦yoneda C Γ, Tm⟧.
Proof.
  apply invweq.
  apply yoneda_weq.
Defined.

Variable comp_comm :
  forall Γ (A : Ty $p Γ),
    yoTm _ (q Γ A) ;; p =
    #(yoneda _ ) (pi Γ A) ;; yoTy _ A.

Variable ispullback_comp_comm :
  forall Γ (A : Ty $p Γ),
    isPullback (comp_comm Γ A).

End Preview.

Section definition.

Variable C : category.

Definition tt_structure : UU :=
  ∑ TyTm : [C^op, HSET] × [C^op, HSET],
           _ ⟦pr2 TyTm, pr1 TyTm⟧.

Definition Ty (X : tt_structure) : [C^op, HSET] := pr1 (pr1 X).
Definition Tm (X : tt_structure) : [C^op, HSET] := pr2 (pr1 X).
Definition p (X : tt_structure) :  _ ⟦Tm X, Ty X⟧ := pr2 X.

Definition comp_structure (X : tt_structure) : UU :=
  forall Γ (A : Ty X $p Γ),
    ∑ (comp : C) (pi : _ ⟦comp, Γ⟧),
         Tm X $p comp.

Definition comp {X : tt_structure} (Y : comp_structure X) :
  forall (Γ : C) (A : Ty X $p Γ), C
  := fun Γ A => pr1 (Y Γ A).

Definition pi {X : tt_structure} (Y : comp_structure X) :
  forall (Γ : C) (A : Ty X $p Γ), comp _ Γ A --> Γ
  := fun Γ A => pr1 (pr2 (Y Γ A)).

Definition q {X : tt_structure} (Y : comp_structure X) :
  forall (Γ : C) (A : Ty X $p Γ), Tm X $p (comp Y Γ A)
  := fun Γ A => pr2 (pr2 (Y Γ A)).

Definition pullback_structure {X : tt_structure} (Y : comp_structure X) : UU
  := forall Γ (A : Ty X $p Γ),
       ∑ H :
          invmap (yoneda_weq C _ (Tm X)) (q Y Γ A) ;; p X
          =
          #(yoneda _ ) (pi Y Γ A) ;; invmap (yoneda_weq _ _ (Ty X)) A ,
         isPullback(C:=[(C^op)%Cat, SET]) H.

Definition comp_comm {X : tt_structure } {Y : comp_structure X} (Z : pullback_structure Y)
  : forall Γ (A : Ty X $p Γ),
      invmap (yoneda_weq _ _ (Tm X)) (q Y Γ A) ;; p X
          =
          #(yoneda _ ) (pi Y Γ A) ;; invmap (yoneda_weq _ _ (Ty X)) A
  := fun Γ A => pr1 (Z Γ A).

Definition is_Pullback_comp {X : tt_structure } {Y : comp_structure X} (Z : pullback_structure Y)
  : forall Γ (A : Ty X $p Γ),
      isPullback(C:=[(C^op)%Cat, SET]) (comp_comm Z _ _ )
  := fun Γ A => pr2 (Z Γ A).

Definition is_natural_CwF : UU
  := ∑ (X : tt_structure) (Y : comp_structure X), pullback_structure Y.

Coercion tt_structure_from_is_natural_CwF (X : is_natural_CwF) : tt_structure := pr1 X.
Coercion comp_structure_from_is_natural_CwF (X : is_natural_CwF) :
  comp_structure (tt_structure_from_is_natural_CwF X) := pr1 (pr2 X).
Coercion pullback_structure_from_is_natural_CwF (X : is_natural_CwF) :
  pullback_structure (comp_structure_from_is_natural_CwF X) := pr2 (pr2 X).

End definition.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div choice fintype.
Require Import bigop ssralg finset fingroup zmodp.
Require Import poly ssrnum.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope ring_scope.
Import GRing.

Reserved Notation "p <% q" (at level 70, no associativity).
Reserved Notation "p <=% q" (at level 70, no associativity).

(* Set Printing Width 30. *)

Module ord.

Section Formulas.

Variable T : Type.

Inductive formula : Type :=
| Bool of bool
| Equal of (term T) & (term T)
| Lt of (term T) & (term T)
| Le of (term T) & (term T)
| Unit of (term T)
| And of formula & formula
| Or of formula & formula
| Implies of formula & formula
| Not of formula
| Exists of nat & formula
| Forall of nat & formula.

End Formulas.

Fixpoint term_eq (T : eqType)(t1 t2 : term T) :=
  match t1, t2 with
    | Var n1, Var n2 => n1 == n2
    | Const r1, Const r2 => r1 == r2
    | NatConst n1, NatConst n2 => n1 == n2
    | Add r1 s1, Add r2 s2 => (term_eq r1 r2) && (term_eq s1 s2)
    | Opp r1, Opp r2 => term_eq r1 r2
    | NatMul r1 n1, NatMul r2 n2 => (term_eq r1 r2) && (n1 == n2)
    | Mul r1 s1, Mul r2 s2 => (term_eq r1 r2) && (term_eq s1 s2)
    | Inv r1, Inv r2 => term_eq r1 r2
    | Exp r1 n1, Exp r2 n2 => (term_eq r1 r2) && (n1 == n2)
    |_, _ => false
  end.

Lemma term_eqP (T : eqType) : Equality.axiom (@term_eq T).
Proof.
move=> t1 t2; apply: (iffP idP) => [|<-]; last first.
  by elim: t1 {t2} => //= t -> // n; rewrite eqxx.
elim: t1 t2.
- by move=> n1 /= [] // n2 /eqP ->.
- by move=> r1 /= [] // r2 /eqP ->.
- by move=> n1 /= [] // n2 /eqP ->.
- by move=> r1 hr1 r2 hr2 [] //= s1 s2 /andP [] /hr1 -> /hr2 ->.
- by move=> r1 hr1 [] //= s1 /hr1 ->.
- by move=> s1 hs1 n1 [] //= s2 n2 /andP [] /hs1 -> /eqP ->.
- by move=> r1 hr1 r2 hr2 [] //= s1 s2 /andP [] /hr1 -> /hr2 ->.
- by move=> r1 hr1 [] //= s1 /hr1 ->.
- by move=> s1 hs1 n1 [] //= s2 n2 /andP [] /hs1 -> /eqP ->.
Qed.

Canonical term_eqMixin (T : eqType) := EqMixin (@term_eqP T).
Canonical term_eqType (T : eqType) :=
   Eval hnf in EqType (term T) (@term_eqMixin T).

Implicit Arguments term_eqP [x y].
Prenex Implicits term_eq.

Bind Scope oterm_scope with term.
Bind Scope oterm_scope with formula.
Arguments Scope Add [_ oterm_scope oterm_scope].
Arguments Scope Opp [_ oterm_scope].
Arguments Scope NatMul [_ oterm_scope nat_scope].
Arguments Scope Mul [_ oterm_scope oterm_scope].
Arguments Scope Mul [_ oterm_scope oterm_scope].
Arguments Scope Inv [_ oterm_scope].
Arguments Scope Exp [_ oterm_scope nat_scope].
Arguments Scope Equal [_ oterm_scope oterm_scope].
Arguments Scope Unit [_ oterm_scope].
Arguments Scope And [_ oterm_scope oterm_scope].
Arguments Scope Or [_ oterm_scope oterm_scope].
Arguments Scope Implies [_ oterm_scope oterm_scope].
Arguments Scope Not [_ oterm_scope].
Arguments Scope Exists [_ nat_scope oterm_scope].
Arguments Scope Forall [_ nat_scope oterm_scope].

Implicit Arguments Bool [T].
Prenex Implicits Const Add Opp NatMul Mul Exp Bool Unit And Or Implies Not.
Prenex Implicits Exists Forall Lt.

Notation True := (Bool true).
Notation False := (Bool false).

Delimit Scope oterm_scope with oT.
Notation "''X_' i" := (Var _ i) : oterm_scope.
Notation "n %:R" := (NatConst _ n) : oterm_scope.
Notation "x %:T" := (Const x) : oterm_scope.
Notation "0" := 0%:R%oT : oterm_scope.
Notation "1" := 1%:R%oT : oterm_scope.
Infix "+" := Add : oterm_scope.
Notation "- t" := (Opp t) : oterm_scope.
Notation "t - u" := (Add t (- u)) : oterm_scope.
Infix "*" := Mul : oterm_scope.
Infix "*+" := NatMul : oterm_scope.
Notation "t ^-1" := (Inv t) : oterm_scope.
Notation "t / u" := (Mul t u^-1) : oterm_scope.
Infix "^+" := Exp : oterm_scope.
Notation "t ^- n" := (t^-1 ^+ n)%oT : oterm_scope.
Infix "==" := Equal : oterm_scope.
Infix "<%" := Lt : oterm_scope.
Infix "<=%" := Le : oterm_scope.
Infix "/\" := And : oterm_scope.
Infix "\/" := Or : oterm_scope.
Infix "==>" := Implies : oterm_scope.
Notation "~ f" := (Not f) : oterm_scope.
Notation "x != y" := (Not (x == y)) : oterm_scope.
Notation "''exists' ''X_' i , f" := (Exists i f) : oterm_scope.
Notation "''forall' ''X_' i , f" := (Forall i f) : oterm_scope.

Section Substitution.

Variable T : Type.

Fixpoint fsubst (f : formula T) (s : nat * term T) :=
  match f with
  | Bool _ => f
  | (t1 == t2) => (tsubst t1 s == tsubst t2 s)
  | (t1 <% t2) => (tsubst t1 s <% tsubst t2 s)
  | (t1 <=% t2) => (tsubst t1 s <=% tsubst t2 s)
  | (Unit t1) => Unit (tsubst t1 s)
  | (f1 /\ f2) => (fsubst f1 s /\ fsubst f2 s)
  | (f1 \/ f2) => (fsubst f1 s \/ fsubst f2 s)
  | (f1 ==> f2) => (fsubst f1 s ==> fsubst f2 s)
  | (~ f1) => (~ fsubst f1 s)
  | ('exists 'X_i, f1) => ('exists 'X_i, if i == s.1 then f1 else fsubst f1 s)
  | ('forall 'X_i, f1) => ('forall 'X_i, if i == s.1 then f1 else fsubst f1 s)
  end%oT.

End Substitution.

Section OrderedClause.

Inductive oclause (R : Type) : Type :=
  Oclause : seq (term R) -> seq (term R) -> seq (term R) -> seq (term R) -> oclause R.

Definition eq_of_oclause (R : Type)(x : oclause R) :=
  let: Oclause y _ _ _  := x in y.
Definition neq_of_oclause (R : Type)(x : oclause R) :=
  let: Oclause _ y _ _  := x in y.
Definition lt_of_oclause (R : Type) (x : oclause R) :=
  let: Oclause  _ _ y _  := x in y.
Definition le_of_oclause (R : Type) (x : oclause R) :=
  let: Oclause  _ _ _ y := x in y.

End OrderedClause.

Delimit Scope oclause_scope with OCLAUSE.
Open Scope oclause_scope.

Notation "p .1" := (@eq_of_oclause _ p)
  (at level 2, left associativity, format "p .1") : oclause_scope.
Notation "p .2" := (@neq_of_oclause _ p)
  (at level 2, left associativity, format "p .2") : oclause_scope.

Notation "p .3" := (@lt_of_oclause _ p)
  (at level 2, left associativity, format "p .3") : oclause_scope.
Notation "p .4" := (@le_of_oclause _ p)
  (at level 2, left associativity, format "p .4") : oclause_scope.

Definition oclause_eq (T : eqType)(t1 t2 : oclause T) :=
  let: Oclause eq_l1 neq_l1 lt_l1 leq_l1 := t1 in
  let: Oclause eq_l2 neq_l2 lt_l2 leq_l2 := t2 in
    [&& eq_l1 == eq_l2, neq_l1 == neq_l2, lt_l1 == lt_l2 & leq_l1 == leq_l2].

Lemma oclause_eqP (T : eqType) : Equality.axiom (@oclause_eq T).
Proof.
move=> t1 t2; apply: (iffP idP) => [|<-] /= ; last first.
  by rewrite /oclause_eq; case: t1=> l1 l2 l3 l4; rewrite !eqxx.
case: t1 => [l1 l2 l3 l4]; case: t2 => m1 m2 m3 m4 /=; case/and4P.
by move/eqP=> -> /eqP -> /eqP -> /eqP ->.
Qed.

Canonical oclause_eqMixin (T : eqType) := EqMixin (@oclause_eqP T).
Canonical oclause_eqType (T : eqType) :=
   Eval hnf in EqType (oclause T) (@oclause_eqMixin T).

Implicit Arguments oclause_eqP [x y].
Prenex Implicits oclause_eq.

Section EvalTerm.

Variable R : realDomainType.

(* Evaluation of a reified formula *)

Fixpoint holds (e : seq R) (f : ord.formula R) {struct f} : Prop :=
  match f with
  | Bool b => b
  | (t1 == t2)%oT => eval e t1 = eval e t2
  | (t1 <% t2)%oT => eval e t1 < eval e t2
  | (t1 <=% t2)%oT => eval e t1 <= eval e t2
  | Unit t1 => eval e t1 \in unit
  | (f1 /\ f2)%oT => holds e f1 /\ holds e f2
  | (f1 \/ f2)%oT => holds e f1 \/ holds e f2
  | (f1 ==> f2)%oT => holds e f1 -> holds e f2
  | (~ f1)%oT => ~ holds e f1
  | ('exists 'X_i, f1)%oT => exists x, holds (set_nth 0 e i x) f1
  | ('forall 'X_i, f1)%oT => forall x, holds (set_nth 0 e i x) f1
  end.

(* Extensionality of formula evaluation *)
Lemma eq_holds e e' f : same_env e e' -> holds e f -> holds e' f.
Proof.
pose sv := set_nth (0 : R).
have eq_i i v e1 e2: same_env e1 e2 -> same_env (sv e1 i v) (sv e2 i v).
  by move=> eq_e j; rewrite !nth_set_nth /= eq_e.
elim: f e e' => //=.
- by move=> t1 t2 e e' eq_e; rewrite !(eq_eval _ eq_e).
- by move=> t1 t2 e e' eq_e; rewrite !(eq_eval _ eq_e).
- by move=> t1 t2 e e' eq_e; rewrite !(eq_eval _ eq_e).
- by move=> t e e' eq_e; rewrite (eq_eval _ eq_e).
- by move=> f1 IH1 f2 IH2 e e' eq_e; move/IH2: (eq_e); move/IH1: eq_e; tauto.
- by move=> f1 IH1 f2 IH2 e e' eq_e; move/IH2: (eq_e); move/IH1: eq_e; tauto.
- by move=> f1 IH1 f2 IH2 e e' eq_e f12; move/IH1: (same_env_sym eq_e); eauto.
- by move=> f1 IH1 e e'; move/same_env_sym; move/IH1; tauto.
- by move=> i f1 IH1 e e'; move/(eq_i i)=> eq_e [x f_ex]; exists x; eauto.
by move=> i f1 IH1 e e'; move/(eq_i i); eauto.
Qed.

(* Evaluation and substitution by a constant *)
Lemma holds_fsubst e f i v :
  holds e (fsubst f (i, v%:T)%T) <-> holds (set_nth 0 e i v) f.
Proof.
elim: f e => //=; do [
  by move=> *; rewrite !eval_tsubst
| move=> f1 IHf1 f2 IHf2 e; move: (IHf1 e) (IHf2 e); tauto
| move=> f IHf e; move: (IHf e); tauto
| move=> j f IHf e].
- case eq_ji: (j == i); first rewrite (eqP eq_ji).
    by split=> [] [x f_x]; exists x; rewrite set_set_nth eqxx in f_x *.
  split=> [] [x f_x]; exists x; move: f_x; rewrite set_set_nth eq_sym eq_ji;
     have:= IHf (set_nth 0 e j x); tauto.
case eq_ji: (j == i); first rewrite (eqP eq_ji).
  by split=> [] f_ x; move: (f_ x); rewrite set_set_nth eqxx.
split=> [] f_ x; move: (IHf (set_nth 0 e j x)) (f_ x);
  by rewrite set_set_nth eq_sym eq_ji; tauto.
Qed.

(* Boolean test selecting formulas in the theory of rings *)
Fixpoint rformula (f : formula R) :=
  match f with
  | Bool _ => true
  | t1 == t2 => rterm t1 && rterm t2
  | t1 <% t2 => rterm t1 && rterm t2
  | t1 <=% t2 => rterm t1 && rterm t2
  | Unit t1 => false
  | (f1 /\ f2) | (f1 \/ f2) | (f1 ==> f2) => rformula f1 && rformula f2
  | (~ f1) | ('exists 'X__, f1) | ('forall 'X__, f1) => rformula f1
  end%oT.

(* An oformula stating that t1 is equal to 0 in the ring theory. *)
Definition eq0_rform t1 :=
  let m := @ub_var R t1 in
  let: (t1', r1) := to_rterm t1 [::] m in
  let fix loop r i := match r with
  | [::] => t1' == 0
  | t :: r' =>
    let f := ('X_i * t == 1 /\ t * 'X_i == 1) in
     'forall 'X_i, (f \/ 'X_i == t /\ ~ ('exists 'X_i,  f)) ==> loop r' i.+1
  end%oT
  in loop r1 m.

(* An oformula stating that t1 is less than 0 in the equational ring theory.
Definition leq0_rform t1 :=
  let m := @ub_var R t1 in
  let: (t1', r1) := to_rterm t1 [::] m in
  let fix loop r i := match r with
  | [::] => 'exists 'X_m.+1, t1' == 'X_m.+1 * 'X_m.+1
  | t :: r' =>
    let f := ('X_i * t == 1 /\ t * 'X_i == 1) in
     'forall 'X_i, (f \/ 'X_i == t /\ ~ ('exists 'X_i,  f)) ==> loop r' i.+1
  end%oT
  in loop r1 m.
*)
Definition leq0_rform t1 :=
  let m := @ub_var R t1 in
  let: (t1', r1) := to_rterm t1 [::] m in
  let fix loop r i := match r with
  | [::] => t1' <=% 0
  | t :: r' =>
    let f := ('X_i * t == 1 /\ t * 'X_i == 1) in
     'forall 'X_i, (f \/ 'X_i == t /\ ~ ('exists 'X_i,  f)) ==> loop r' i.+1
  end%oT
  in loop r1 m.

(* Definition lt0_rform t1 := *)
(*   let m := @ub_var R t1 in *)
(*   let: (t1', r1) := to_rterm t1 [::] m in *)
(*   let fix loop r i := match r with *)
(*   | [::] => 'exists 'X_m.+1, (t1' == 'X_m.+1 * 'X_m.+1 /\ ~ ('X_m.+1 == 0)) *)
(*   | t :: r' => *)
(*     let f := ('X_i * t == 1 /\ t * 'X_i == 1) in *)
(*      'forall 'X_i, (f \/ 'X_i == t /\ ~ ('exists 'X_i,  f)) ==> loop r' i.+1 *)
(*   end%oT *)
(*   in loop r1 m. *)

Definition lt0_rform t1 :=
  let m := @ub_var R t1 in
  let: (t1', r1) := to_rterm t1 [::] m in
  let fix loop r i := match r with
  | [::] => t1' <% 0
  | t :: r' =>
    let f := ('X_i * t == 1 /\ t * 'X_i == 1) in
     'forall 'X_i, (f \/ 'X_i == t /\ ~ ('exists 'X_i,  f)) ==> loop r' i.+1
  end%oT
  in loop r1 m.

(* Transformation of a formula in the theory of rings with units into an *)

(* equivalent formula in the sub-theory of rings.                        *)
Fixpoint to_rform f :=
  match f with
  | Bool b => f
  | t1 == t2 => eq0_rform (t1 - t2)
  | t1 <% t2 => lt0_rform (t1 - t2)
  | t1 <=% t2 => leq0_rform (t1 - t2)
  | Unit t1 => eq0_rform (t1 * t1^-1 - 1)
  | f1 /\ f2 => to_rform f1 /\ to_rform f2
  | f1 \/ f2 =>  to_rform f1 \/ to_rform f2
  | f1 ==> f2 => to_rform f1 ==> to_rform f2
  | ~ f1 => ~ to_rform f1
  | ('exists 'X_i, f1) => 'exists 'X_i, to_rform f1
  | ('forall 'X_i, f1) => 'forall 'X_i, to_rform f1
  end%oT.

(* The transformation gives a ring formula. *)
(* the last part of the proof consists in 3 cases that are exactly the same.
   how to factorize ? *)
Lemma to_rform_rformula f : rformula (to_rform f).
Proof.
suffices [h1 h2 h3]:
  [/\ forall t1, rformula (eq0_rform t1),
      forall t1, rformula (lt0_rform t1) &
      forall t1, rformula (leq0_rform t1)].
  by elim: f => //= => f1 ->.
split=> t1.
- rewrite /eq0_rform; move: (ub_var t1) => m.
  set tr := _ m.
  suffices: all (@rterm R) (tr.1 :: tr.2)%PAIR.
    case: tr => {t1} t1 r /= /andP[t1_r].
    by elim: r m => [|t r IHr] m; rewrite /= ?andbT // => /andP[->]; apply: IHr.
  have: all (@rterm R) [::] by [].
  rewrite {}/tr; elim: t1 [::] => //=.
  + move=> t1 IHt1 t2 IHt2 r.
  move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /= /andP[t1_r].
  move/IHt2; case: to_rterm => {t2 r IHt2} t2 r /= /andP[t2_r].
  by rewrite t1_r t2_r.
  + by move=> t1 IHt1 r /IHt1; case: to_rterm.
  + by move=> t1 IHt1 n r /IHt1; case: to_rterm.
  + move=> t1 IHt1 t2 IHt2 r.
  move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /= /andP[t1_r].
  move/IHt2; case: to_rterm => {t2 r IHt2} t2 r /= /andP[t2_r].
  by rewrite t1_r t2_r.
  + move=> t1 IHt1 r.
  by move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /=; rewrite all_rcons.
  + by move=> t1 IHt1 n r /IHt1; case: to_rterm.
- rewrite /lt0_rform; move: (ub_var t1) => m; set tr := _ m.
  suffices: all (@rterm R) (tr.1 :: tr.2)%PAIR.
    case: tr => {t1} t1 r /= /andP[t1_r].
    by elim: r m => [|t r IHr] m; rewrite /= ?andbT // => /andP[->]; apply: IHr.
  have: all (@rterm R) [::] by [].
  rewrite {}/tr; elim: t1 [::] => //=.
  + move=> t1 IHt1 t2 IHt2 r.
  move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /= /andP[t1_r].
  move/IHt2; case: to_rterm => {t2 r IHt2} t2 r /= /andP[t2_r].
  by rewrite t1_r t2_r.
  + by move=> t1 IHt1 r /IHt1; case: to_rterm.
  + by move=> t1 IHt1 n r /IHt1; case: to_rterm.
  + move=> t1 IHt1 t2 IHt2 r.
  move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /= /andP[t1_r].
  move/IHt2; case: to_rterm => {t2 r IHt2} t2 r /= /andP[t2_r].
  by rewrite t1_r t2_r.
  + move=> t1 IHt1 r.
  by move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /=; rewrite all_rcons.
  + by move=> t1 IHt1 n r /IHt1; case: to_rterm.
- rewrite /leq0_rform; move: (ub_var t1) => m; set tr := _ m.
  suffices: all (@rterm R) (tr.1 :: tr.2)%PAIR.
    case: tr => {t1} t1 r /= /andP[t1_r].
    by elim: r m => [|t r IHr] m; rewrite /= ?andbT // => /andP[->]; apply: IHr.
  have: all (@rterm R) [::] by [].
  rewrite {}/tr; elim: t1 [::] => //=.
  + move=> t1 IHt1 t2 IHt2 r.
  move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /= /andP[t1_r].
  move/IHt2; case: to_rterm => {t2 r IHt2} t2 r /= /andP[t2_r].
  by rewrite t1_r t2_r.
  + by move=> t1 IHt1 r /IHt1; case: to_rterm.
  + by move=> t1 IHt1 n r /IHt1; case: to_rterm.
  + move=> t1 IHt1 t2 IHt2 r.
  move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /= /andP[t1_r].
  move/IHt2; case: to_rterm => {t2 r IHt2} t2 r /= /andP[t2_r].
  by rewrite t1_r t2_r.
  + move=> t1 IHt1 r.
  by move/IHt1; case: to_rterm => {t1 r IHt1} t1 r /=; rewrite all_rcons.
  + by move=> t1 IHt1 n r /IHt1; case: to_rterm.
Qed.

Import Num.Theory.

(* Correctness of the transformation. *)
Lemma to_rformP e f : holds e (to_rform f) <-> holds e f.
Proof.
suffices{e f} [equal0_equiv lt0_equiv le0_equiv]:
  [/\ forall e t1 t2, holds e (eq0_rform (t1 - t2)) <-> (eval e t1 == eval e t2),
    forall e t1 t2, holds e (lt0_rform (t1 - t2)) <-> (eval e t1 < eval e t2) &
      forall e t1 t2, holds e (leq0_rform (t1 - t2)) <-> (eval e t1 <= eval e t2)].
- elim: f e => /=; try tauto.
  + move=> t1 t2 e.
    by split; [move/equal0_equiv/eqP | move/eqP/equal0_equiv].
  + by move=> t1 t2 e; split; move/lt0_equiv.
  + by move=> t1 t2 e; split; move/le0_equiv.
  + by move=> t1 e; rewrite unitrE; apply: equal0_equiv.
  + by move=> f1 IHf1 f2 IHf2 e; move: (IHf1 e) (IHf2 e); tauto.
  + by move=> f1 IHf1 f2 IHf2 e; move: (IHf1 e) (IHf2 e); tauto.
  + by move=> f1 IHf1 f2 IHf2 e; move: (IHf1 e) (IHf2 e); tauto.
  + by move=> f1 IHf1 e; move: (IHf1 e); tauto.
  + by move=> n f1 IHf1 e; split=> [] [x] /IHf1; exists x.
  + by move=> n f1 IHf1 e; split=> Hx x; apply/IHf1.
suffices h e t1 t2 :
  [/\ holds e (eq0_rform (t1 - t2)) <-> (eval e t1 == eval e t2),
    holds e (lt0_rform (t1 - t2)) <-> (eval e t1 < eval e t2) &
    holds e (leq0_rform (t1 - t2)) <-> (eval e t1 <= eval e t2)].
  by split => e t1 t2; case: (h e t1 t2).
rewrite -{1}(add0r (eval e t2)) -(can2_eq (subrK _) (addrK _)).
rewrite -subr_lt0 -subr_le0 -/(eval e (t1 - t2)); move: {t1 t2}(t1 - t2)%T => t.
have sub_var_tsubst s t0: (s.1%PAIR >= ub_var t0)%N -> tsubst t0 s = t0.
  elim: t0 {t} => //=.
  - by move=> n; case: ltngtP.
  - by move=> t1 IHt1 t2 IHt2; rewrite geq_max => /andP[/IHt1-> /IHt2->].
  - by move=> t1 IHt1 /IHt1->.
  - by move=> t1 IHt1 n /IHt1->.
  - by move=> t1 IHt1 t2 IHt2; rewrite geq_max => /andP[/IHt1-> /IHt2->].
  - by move=> t1 IHt1 /IHt1->.
  - by move=> t1 IHt1 n /IHt1->.
pose fix rsub t' m r : term R :=
  if r is u :: r' then tsubst (rsub t' m.+1 r') (m, u^-1)%T else t'.
pose fix ub_sub m r : Prop :=
  if r is u :: r' then (ub_var u <= m)%N /\ ub_sub m.+1 r' else true.
suffices{t} rsub_to_r t r0 m: (m >= ub_var t)%N -> ub_sub _ m r0 ->
  let: (t', r) := to_rterm t r0 m in
  [/\ take (size r0) r = r0,
      ub_var t' <= m + size r, ub_sub _ m r & rsub t' m r = t]%N.
- have:= rsub_to_r t [::] _ (leqnn _); rewrite /eq0_rform /lt0_rform /leq0_rform.
  case: (to_rterm _ _ _) => [t1' r1] /= [//| _ _ ub_r1 def_t].
  rewrite -{2 4 6}def_t {def_t}.
  elim: r1 (ub_var t) e ub_r1 => [|u r1 IHr1] m e /= => [_|[ub_u ub_r1]].
    by split => //; split=> /eqP.
  rewrite eval_tsubst /=; set y := eval e u; split; split => //= t_h0.
  + case: (IHr1 m.+1 (set_nth 0 e m y^-1) ub_r1) => h _ _; apply/h.
    apply: t_h0.
    rewrite nth_set_nth /= eqxx -(eval_tsubst e u (m, Const _)).
    rewrite sub_var_tsubst //= -/y.
    case Uy: (y \in unit); [left | right]; first by rewrite mulVr ?divrr.
    split=> [|[z]]; first by rewrite invr_out ?Uy.
    rewrite nth_set_nth /= eqxx.
    rewrite -!(eval_tsubst _ _ (m, Const _)) !sub_var_tsubst // -/y => yz1.
    by case/unitrP: Uy; exists z.
  + move=> x def_x.
    case: (IHr1 m.+1 (set_nth 0 e m x) ub_r1) => h _ _. apply/h.
    suff ->: x = y^-1 by []; move: def_x.
    rewrite nth_set_nth /= eqxx -(eval_tsubst e u (m, Const _)).
    rewrite sub_var_tsubst //= -/y; case=> [[xy1 yx1] | [xy nUy]].
      by rewrite -[y^-1]mul1r -[1]xy1 mulrK //; apply/unitrP; exists x.
    rewrite invr_out //; apply/unitrP=> [[z yz1]]; case: nUy; exists z.
    rewrite nth_set_nth /= eqxx -!(eval_tsubst _ _ (m, _%:T)%T).
    by rewrite !sub_var_tsubst.
  + case: (IHr1 m.+1 (set_nth 0 e m y^-1) ub_r1) =>  _ h _. apply/h.
    apply: t_h0.
    rewrite nth_set_nth /= eqxx -(eval_tsubst e u (m, Const _)).
    rewrite sub_var_tsubst //= -/y.
    case Uy: (y \in unit); [left | right]; first by rewrite mulVr ?divrr.
    split=> [|[z]]; first by rewrite invr_out ?Uy.
    rewrite nth_set_nth /= eqxx.
    rewrite -!(eval_tsubst _ _ (m, Const _)) !sub_var_tsubst // -/y => yz1.
    by case/unitrP: Uy; exists z.
  + move=> x def_x.
    case: (IHr1 m.+1 (set_nth 0 e m x) ub_r1) => _ h _. apply/h.
    suff ->: x = y^-1 by []; move: def_x.
    rewrite nth_set_nth /= eqxx -(eval_tsubst e u (m, Const _)).
    rewrite sub_var_tsubst //= -/y; case=> [[xy1 yx1] | [xy nUy]].
      by rewrite -[y^-1]mul1r -[1]xy1 mulrK //; apply/unitrP; exists x.
    rewrite invr_out //; apply/unitrP=> [[z yz1]]; case: nUy; exists z.
    rewrite nth_set_nth /= eqxx -!(eval_tsubst _ _ (m, _%:T)%T).
    by rewrite !sub_var_tsubst.
  + case: (IHr1 m.+1 (set_nth 0 e m y^-1) ub_r1) =>  _ _ h. apply/h.
    apply: t_h0.
    rewrite nth_set_nth /= eqxx -(eval_tsubst e u (m, Const _)).
    rewrite sub_var_tsubst //= -/y.
    case Uy: (y \in unit); [left | right]; first by rewrite mulVr ?divrr.
    split=> [|[z]]; first by rewrite invr_out ?Uy.
    rewrite nth_set_nth /= eqxx.
    rewrite -!(eval_tsubst _ _ (m, Const _)) !sub_var_tsubst // -/y => yz1.
    by case/unitrP: Uy; exists z.
  + move=> x def_x.
    case: (IHr1 m.+1 (set_nth 0 e m x) ub_r1) => _ _ h. apply/h.
    suff ->: x = y^-1 by []; move: def_x.
    rewrite nth_set_nth /= eqxx -(eval_tsubst e u (m, Const _)).
    rewrite sub_var_tsubst //= -/y; case=> [[xy1 yx1] | [xy nUy]].
      by rewrite -[y^-1]mul1r -[1]xy1 mulrK //; apply/unitrP; exists x.
    rewrite invr_out //; apply/unitrP=> [[z yz1]]; case: nUy; exists z.
    rewrite nth_set_nth /= eqxx -!(eval_tsubst _ _ (m, _%:T)%T).
    by rewrite !sub_var_tsubst.
have rsub_id r t0 n: (ub_var t0 <= n)%N -> rsub t0 n r = t0.
  by elim: r n => //= t1 r IHr n let0n; rewrite IHr ?sub_var_tsubst ?leqW.
have rsub_acc r s t1 m1:
  (ub_var t1 <= m1 + size r)%N -> rsub t1 m1 (r ++ s) = rsub t1 m1 r.
  elim: r t1 m1 => [|t1 r IHr] t2 m1 /=; first by rewrite addn0; apply: rsub_id.
  by move=> letmr; rewrite IHr ?addSnnS.
elim: t r0 m => /=; try do [
  by move=> n r m hlt hub; rewrite take_size (ltn_addr _ hlt) rsub_id
| by move=> n r m hlt hub; rewrite leq0n take_size rsub_id
| move=> t1 IHt1 t2 IHt2 r m; rewrite geq_max; case/andP=> hub1 hub2 hmr;
  case: to_rterm {IHt1 hub1 hmr}(IHt1 r m hub1 hmr) => t1' r1;
  case=> htake1 hub1' hsub1 <-;
  case: to_rterm {IHt2 hub2 hsub1}(IHt2 r1 m hub2 hsub1) => t2' r2 /=;
  rewrite geq_max; case=> htake2 -> hsub2 /= <-;
  rewrite -{1 2}(cat_take_drop (size r1) r2) htake2; set r3 := drop _ _;
  rewrite size_cat addnA (leq_trans _ (leq_addr _ _)) //;
  split=> {hsub2}//;
   first by [rewrite takel_cat // -htake1 size_take geq_minr];
  rewrite -(rsub_acc r1 r3 t1') {hub1'}// -{htake1}htake2 {r3}cat_take_drop;
  by elim: r2 m => //= u r2 IHr2 m; rewrite IHr2
| do [ move=> t1 IHt1 r m; do 2!move/IHt1=> {IHt1}IHt1
     | move=> t1 IHt1 n r m; do 2!move/IHt1=> {IHt1}IHt1];
  case: to_rterm IHt1 => t1' r1 [-> -> hsub1 <-]; split=> {hsub1}//;
  by elim: r1 m => //= u r1 IHr1 m; rewrite IHr1].
move=> t1 IH r m letm /IH {IH} /(_ letm) {letm}.
case: to_rterm => t1' r1 /= [def_r ub_t1' ub_r1 <-].
rewrite size_rcons addnS leqnn -{1}cats1 takel_cat ?def_r; last first.
  by rewrite -def_r size_take geq_minr.
elim: r1 m ub_r1 ub_t1' {def_r} => /= [|u r1 IHr1] m => [_|[->]].
  by rewrite addn0 eqxx.
by rewrite -addSnnS => /IHr1 IH /IH[_ _ ub_r1 ->].
Qed.

(* The above proof is ugly but is in fact copypaste *)

(* Boolean test selecting formulas which describe a constructible set, *)
(* i.e. formulas without quantifiers.                                  *)

(* The quantifier elimination check. *)
Fixpoint qf_form (f : formula R) :=
  match f with
  | Bool _ | _ == _ | Unit _ | Lt _ _ | Le _ _ => true
  | f1 /\ f2 | f1 \/ f2 | f1 ==> f2 => qf_form f1 && qf_form f2
  | ~ f1 => qf_form f1
  | _ => false
  end%oT.

(* Boolean holds predicate for quantifier free formulas *)
Definition qf_eval e := fix loop (f : formula R) : bool :=
  match f with
  | Bool b => b
  | t1 == t2 => (eval e t1 == eval e t2)%bool
  | t1 <% t2 => (eval e t1 < eval e t2)%bool
  | t1 <=% t2 => (eval e t1 <= eval e t2)%bool
  | Unit t1 => eval e t1 \in unit
  | f1 /\ f2 => loop f1 && loop f2
  | f1 \/ f2 => loop f1 || loop f2
  | f1 ==> f2 => (loop f1 ==> loop f2)%bool
  | ~ f1 => ~~ loop f1
  |_ => false
  end%oT.

(* qf_eval is equivalent to holds *)
Lemma qf_evalP e f : qf_form f -> reflect (holds e f) (qf_eval e f).
Proof.
elim: f => //=; try by move=> *; apply: idP.
- by move=> t1 t2 _; apply: eqP.
- move=> f1 IHf1 f2 IHf2 /= /andP[/IHf1[] f1T]; last by right; case.
  by case/IHf2; [left | right; case].
- move=> f1 IHf1 f2 IHf2 /= /andP[/IHf1[] f1F]; first by do 2 left.
  by case/IHf2; [left; right | right; case].
- move=> f1 IHf1 f2 IHf2 /= /andP[/IHf1[] f1T]; last by left.
  by case/IHf2; [left | right; move/(_ f1T)].
by move=> f1 IHf1 /IHf1[]; [right | left].
Qed.

(* Quantifier-free formula are normalized into DNF. A DNF is *)
(* represented by the type seq (seq (term R) * seq (term R)), where we *)
(* separate positive and negative literals *)

(* DNF preserving conjunction *)

Definition and_odnf (bcs1 bcs2 : seq (oclause R)) :=
  \big[cat/nil]_(bc1 <- bcs1)
     map (fun bc2 : oclause R =>
       (Oclause (bc1.1 ++ bc2.1) (bc1.2 ++ bc2.2) (bc1.3 ++ bc2.3) (bc1.4 ++ bc2.4)))%OCLAUSE bcs2.

(* Computes a DNF from a qf ring formula *)
Fixpoint qf_to_odnf (f : formula R) (neg : bool) {struct f} : seq (oclause R) :=
  match f with
  | Bool b => if b (+) neg then [:: (Oclause [::] [::] [::] [::])] else [::]
  | t1 == t2 =>
    [:: if neg then (Oclause [::] [:: t1 - t2] [::] [::]) else (Oclause [:: t1 - t2] [::] [::] [::])]
  | t1 <% t2 =>
    [:: if neg then (Oclause [::] [::] [::] [:: t1 - t2]) else (Oclause [::] [::] [:: t2 - t1] [::])]
  | t1 <=% t2 =>
    [:: if neg then (Oclause [::] [::] [:: t1 - t2] [::]) else (Oclause [::] [::] [::] [:: t2 - t1])]
  | f1 /\ f2 => (if neg then cat else and_odnf) [rec f1, neg] [rec f2, neg]
  | f1 \/ f2 => (if neg then and_odnf else cat) [rec f1, neg] [rec f2, neg]
  | f1 ==> f2 => (if neg then and_odnf else cat) [rec f1, ~~ neg] [rec f2, neg]
  | ~ f1 => [rec f1, ~~ neg]
  | _ =>  if neg then  [:: (Oclause [::] [::] [::] [::])] else [::]
  end%oT where "[ 'rec' f , neg ]" := (qf_to_odnf f neg).

(* Conversely, transforms a DNF into a formula *)
Definition odnf_to_oform :=
  let pos_lit t := And (t == 0)%oT in let neg_lit t := And (t != 0)%oT in
  let lt_lit t :=  And (0 <% t)%oT in let le_lit t := And (0 <=% t)%oT in
  let ocls (bc : oclause R) :=
    Or
    (foldr pos_lit True bc.1 /\ foldr neg_lit True bc.2 /\
     foldr lt_lit True bc.3 /\ foldr le_lit True bc.4) in
  foldr ocls False.

(* Catenation of dnf is the Or of formulas *)
Lemma cat_dnfP e bcs1 bcs2 :
  qf_eval e (odnf_to_oform (bcs1 ++ bcs2))
    = qf_eval e (odnf_to_oform bcs1 \/ odnf_to_oform bcs2).
Proof.
by elim: bcs1 => //= bc1 bcs1 IH1; rewrite -orbA; congr orb; rewrite IH1.
Qed.

(* and_dnf is the And of formulas *)
Lemma and_odnfP e bcs1 bcs2 :
  qf_eval e (odnf_to_oform (and_odnf bcs1 bcs2))
   = qf_eval e (odnf_to_oform bcs1 /\ odnf_to_oform bcs2).
Proof.
elim: bcs1 => [|bc1 bcs1 IH1] /=; first by rewrite /and_odnf big_nil.
rewrite /and_odnf big_cons -/(and_odnf bcs1 bcs2) cat_dnfP  /=.
rewrite {}IH1 /= andb_orl; congr orb.
elim: bcs2 bc1 {bcs1} => [|bc2 bcs2 IH] bc1 /=; first by rewrite andbF.
rewrite {}IH /= andb_orr; congr orb => {bcs2}.
suffices aux (l1 l2 : seq (term R)) g : let redg := foldr (And \o g) True in
  qf_eval e (redg (l1 ++ l2)) = qf_eval e (redg l1 /\ redg l2)%oT.
+ rewrite !aux /= !andbA; congr (_ && _); rewrite -!andbA; congr (_ && _).
  rewrite -andbCA; congr (_ && _); bool_congr; rewrite andbCA; bool_congr.
  by rewrite andbA andbC !andbA.
by elim: l1 => [| t1 l1 IHl1] //=; rewrite -andbA IHl1.
Qed.

Lemma qf_to_dnfP e :
  let qev f b := qf_eval e (odnf_to_oform (qf_to_odnf f b)) in
  forall f, qf_form f && rformula f -> qev f false = qf_eval e f.
Proof.
move=> qev; have qevT f: qev f true = ~~ qev f false.
  rewrite {}/qev; elim: f => //=; do [by case | move=> f1 IH1 f2 IH2 | ].
  - by move=> t1 t2; rewrite !andbT !orbF.
  - by move=> t1 t2; rewrite !andbT !orbF; rewrite !subr_gte0 -lerNgt.
  - by move=> t1 t2; rewrite !andbT !orbF; rewrite !subr_gte0 -ltrNge.
  - by rewrite and_odnfP cat_dnfP negb_and -IH1 -IH2.
  - by rewrite and_odnfP cat_dnfP negb_or -IH1 -IH2.
  - by rewrite and_odnfP cat_dnfP /= negb_or IH1 -IH2 negbK.
  by move=> t1 ->; rewrite negbK.
rewrite /qev; elim=> //=; first by case.
- by move=> t1 t2 _; rewrite subr_eq0 !andbT orbF.
- by move=> t1 t2 _; rewrite orbF !andbT subr_gte0.
- by move=> t1 t2 _; rewrite orbF !andbT subr_gte0.
- move=> f1 IH1 f2 IH2; rewrite andbCA -andbA andbCA andbA; case/andP.
  by rewrite and_odnfP /= => /IH1-> /IH2->.
- move=> f1 IH1 f2 IH2; rewrite andbCA -andbA andbCA andbA; case/andP.
  by rewrite cat_dnfP /= => /IH1-> => /IH2->.
- move=> f1 IH1 f2 IH2; rewrite andbCA -andbA andbCA andbA; case/andP.
  by rewrite cat_dnfP /= [qf_eval _ _]qevT -implybE => /IH1 <- /IH2->.
by move=> f1 IH1 /IH1 <-; rewrite -qevT.
Qed.

Lemma dnf_to_form_qf bcs : qf_form (odnf_to_oform bcs).
Proof.
elim: bcs => //= [[clT clF] clLt clLe ? ->] /=; elim: clT => //=.
by rewrite andbT; elim: clF; elim: clLt => //; elim: clLe.
Qed.

Definition dnf_rterm (cl : oclause R) :=
  [&& all (@rterm R) cl.1, all (@rterm R) cl.2,
  all (@rterm R) cl.3 & all (@rterm R) cl.4].

Lemma qf_to_dnf_rterm f b : rformula f -> all dnf_rterm (qf_to_odnf f b).
Proof.
set ok := all dnf_rterm.
have cat_ok bcs1 bcs2: ok bcs1 -> ok bcs2 -> ok (bcs1 ++ bcs2).
  by move=> ok1 ok2; rewrite [ok _]all_cat; apply/andP.
have and_ok bcs1 bcs2: ok bcs1 -> ok bcs2 -> ok (and_odnf bcs1 bcs2).
  rewrite /and_odnf unlock; elim: bcs1 => //= cl1 bcs1 IH1; rewrite -andbA.
  case/and3P=> ok11 ok12 ok1 ok2; rewrite cat_ok ?{}IH1 {bcs1 ok1}//.
  elim: bcs2 ok2 => //= cl2 bcs2 IH2 /andP[ok2 /IH2->].
  by rewrite /dnf_rterm /= !all_cat andbT ok11; case/and3P: ok12=> -> -> ->.
elim: f b => //=; try by [move=> _ ? ? [] | move=> ? ? ? ? [] /= /andP[]; auto].
- by do 2!case.
- by rewrite /dnf_rterm => ? ? [] /= ->.
- by rewrite /dnf_rterm => ? ? [] /=; rewrite andbC !andbT.
- by rewrite /dnf_rterm => ? ? [] /=; rewrite andbC !andbT.
by auto.
Qed.

Lemma dnf_to_rform bcs : rformula (odnf_to_oform bcs) = all dnf_rterm bcs.
Proof.
elim: bcs => //= [[cl1 cl2 cl3 cl4] bcs ->]; rewrite {2}/dnf_rterm /=; congr (_ && _).
congr andb; first by elim: cl1 => //= t cl ->; rewrite andbT.
congr andb; first by elim: cl2 => //= t cl ->; rewrite andbT.
congr andb; first by elim: cl3 => //= t cl ->.
by elim: cl4 => //= t cl ->.
Qed.

Implicit Type f : formula R.

Fixpoint leq_elim_aux (eq_l lt_l le_l : seq (term R)) :=
  match le_l with
    [::] => [:: (eq_l, lt_l)]
    |le1 :: le_l' =>
  let res := leq_elim_aux eq_l lt_l le_l' in
  let as_eq := map (fun x => (le1 :: x.1%PAIR, x.2%PAIR)) res in
  let as_lt := map (fun x => (x.1%PAIR, le1 :: x.2%PAIR)) res in
    as_eq ++ as_lt
  end.

Definition oclause_leq_elim oc : seq (oclause R) :=
  let: Oclause eq_l neq_l lt_l le_l := oc in
    map (fun x => Oclause x.1%PAIR neq_l x.2%PAIR [::])
    (leq_elim_aux eq_l lt_l le_l).

Definition terms_of_oclause (oc : oclause R) :=
  let: Oclause eq_l neq_l lt_l le_l := oc in
    eq_l ++ neq_l ++ lt_l ++ le_l.

Lemma terms_of_leq_elim oc1 oc2:
  oc2 \in (oclause_leq_elim oc1) ->
  (terms_of_oclause oc2) =i (terms_of_oclause oc1).
case: oc1 => eq1 neq1 lt1 leq1 /=.
elim: leq1 eq1 lt1 oc2 => [|t1 leq1 ih] eq1 lt1 [eq2 neq2 lt2 leq2] /=.
  by rewrite inE; case/eqP=> -> -> -> -> ?.
rewrite map_cat /= mem_cat -!map_comp; set f := fun _ => _.
rewrite -/f in ih; case/orP.
  case/mapP=> [[y1 y2]] yin ye.
  move: (ih eq1 lt1 (f (y1, y2))); rewrite mem_map //; last first.
    by move=> [u1 u2] [v1 v2]; rewrite /f /=; case=> -> ->.
  move/(_ yin); move: ye; rewrite /f /=; case=> -> -> -> -> /= h.
  move=> u; rewrite in_cons (h u) !mem_cat in_cons.
  by rewrite orbC !orbA; set x := _ || (u \in lt1); rewrite orbAC.
case/mapP=> [[y1 y2]] yin ye.
move: (ih eq1 lt1 (f (y1, y2))); rewrite mem_map //; last first.
  by move=> [u1 u2] [v1 v2]; rewrite /f /=; case=> -> ->.
move/(_ yin); move: ye; rewrite /f /=; case=> -> -> -> -> /= h u.
rewrite !mem_cat !in_cons orbA orbCA -!orbA; move: (h u); rewrite !mem_cat=> ->.
by rewrite orbC !orbA; set x := _ || (u \in lt1); rewrite orbAC.
Qed.

Lemma odnf_to_oform_cat e c d : holds e (odnf_to_oform (c ++ d))
              <-> holds e ((odnf_to_oform c) \/ (odnf_to_oform d))%oT.
Proof.
elim: c d => [| tc c ihc] d /=; first by split => // hd; [right | case: hd].
rewrite ihc /=; split.
  case; first by case=> ?; case => ?; case => ? ?; left; left.
  case; first by move=> ?; left; right.
  by move=> ?; right.
case; last by move=> ?; right; right.
case;  last by move=> ?; right; left.
by do 3!case=> ?; move=> ?; left.
Qed.

Lemma oclause_leq_elimP oc e :
  holds e (odnf_to_oform [:: oc])  <->
  holds e (odnf_to_oform (oclause_leq_elim oc)).
Proof.
case: oc => eq_l neq_l lt_l le_l; rewrite /oclause_leq_elim.
elim: le_l eq_l neq_l lt_l => [|t le_l ih] eq_l neq_l lt_l //=.
move: (ih eq_l neq_l lt_l) => /= {ih}.
set x1 := foldr _ _ _; set x2 := foldr _ _ _; set x3 := foldr _ _ _.
set x4 := foldr _ _ _ => h.
have -> : (holds e x1 /\ holds e x2 /\ holds e x3 /\ 0%:R <= eval e t /\
            holds e x4 \/ false) <->
          (0%:R <= eval e t) /\ (holds e x1 /\ holds e x2 /\ holds e x3 /\
            holds e x4 \/ false).
  split; first by case=> //; do 4! (case => ?); move=> ?; split => //; left.
  by case=> ?; case => //; do 3! (case=> ?); move=> ?; left.
rewrite h {h} /= !map_cat /= -!map_comp.
set s1 := [seq _ | _ <- _]; set s2 := [seq _ | _ <- _].
set s3 := [seq _ | _ <- _]. rewrite odnf_to_oform_cat.
suff {x1 x2 x3 x4} /= -> :
  holds e (odnf_to_oform s2) <-> eval e t == 0%:R /\ holds e (odnf_to_oform s1).
  suff /= -> :
    holds e (odnf_to_oform s3) <-> 0%:R < eval e t /\ holds e (odnf_to_oform s1).
    rewrite ler_eqVlt eq_sym; split; first by case; case/orP=> -> ?; [left|right].
    by case; [case=> -> ? /= |case=> ->; rewrite orbT].
  rewrite /s1 /s3.
  elim: (leq_elim_aux eq_l lt_l le_l) => /= [| t1 l ih]; first by split=> // [[]].
  rewrite /= ih; split.
    case; last by case=> -> ?; split=> //; right.
    by do 2!case=> ?; case; case=> -> ? _; split => //; auto.
  by case=> ->; case; [do 3!case=> ?; move=> _; left | right].
rewrite /s2 /s1.
elim: (leq_elim_aux eq_l lt_l le_l) => /= [| t1 l ih]; first by split=> // [[]].
rewrite /= ih; split.
  case; last by case=> -> ?; split=> //; right.
  by case; case=> /eqP ? ?; do 2! case=> ?; move=> _; split=>//; left.
case=> /eqP ?; case; first by do 3!case=> ?; move=> _; left.
by right; split=> //; apply/eqP.
Qed.

Fixpoint neq_elim_aux (lt_l neq_l : seq (term R)) :=
  match neq_l with
    [::] => [:: lt_l]
    |neq1 :: neq_l' =>
  let res := neq_elim_aux lt_l neq_l' in
  let as_pos := map (fun x => neq1 :: x) res in
  let as_neg := map (fun x => Opp neq1 :: x) res in
    as_pos ++ as_neg
  end.

Definition oclause_neq_elim oc : seq (oclause R) :=
  let: Oclause eq_l neq_l lt_l le_l := oc in
    map (fun x => Oclause eq_l [::] x le_l) (neq_elim_aux lt_l neq_l).

Lemma terms_of_neq_elim oc1 oc2:
  oc2 \in (oclause_neq_elim oc1) ->
  {subset (terms_of_oclause oc2) <= (terms_of_oclause oc1) ++ (map Opp oc1.2)}.
Proof.
case: oc1 => eq1 neq1 lt1 leq1 /=.
elim: neq1 lt1 oc2 => [|t1 neq1 ih] lt1 [eq2 neq2 lt2 leq2] /=.
  by rewrite inE; case/eqP=> -> -> -> ->; rewrite !cats0 !cat0s.
rewrite map_cat /= mem_cat -!map_comp; set f := fun _ => _.
rewrite -/f in ih; case/orP.
  case/mapP=> y yin ye.
  move: (ih lt1 (f y)); rewrite mem_map //; last first.
    by move=> u v; rewrite /f /=; case.
  move/(_ yin); move: ye; rewrite /f /=; case=> -> -> -> -> /= h.
  move=> u. rewrite !mem_cat !in_cons orbAC orbC mem_cat -!orbA.
  case/orP; first by move->; rewrite !orbT.
  rewrite !orbA [_ || (_ \in eq1)]orbC; move: (h u); rewrite !mem_cat=> hu.
  by move/hu; do 2! (case/orP; last by move->; rewrite !orbT); move->.
case/mapP=> y yin ye.
move: (ih lt1 (f y)); rewrite mem_map //; last first.
  by move=> u v; rewrite /f /=; case.
move/(_ yin); move: ye; rewrite /f /=; case=> -> -> -> -> /= h.
move=> u; rewrite !mem_cat !in_cons orbAC orbC mem_cat -!orbA.
case/orP; first by move->; rewrite !orbT.
rewrite !orbA [_ || (_ \in eq1)]orbC; move: (h u); rewrite !mem_cat=> hu.
by move/hu; do 2! (case/orP; last by move->; rewrite !orbT); move->.
Qed.

Lemma oclause_neq_elimP oc e :
  holds e (odnf_to_oform [:: oc])  <->
  holds e (odnf_to_oform (oclause_neq_elim oc)).
Proof.
case: oc => eq_l neq_l lt_l le_l; rewrite /oclause_neq_elim.
elim: neq_l lt_l => [|t neq_l ih] lt_l //=.
move: (ih lt_l) => /= {ih}.
set x1 := foldr _ _ _; set x2 := foldr _ _ _; set x3 := foldr _ _ _.
set x4 := foldr _ _ _ => h /=.
have -> : holds e x1 /\
   (eval e t <> 0%:R /\
    holds e x2) /\
   holds e x3 /\ holds e x4 \/
   false <->
          (eval e t <> 0%:R) /\ (holds e x1 /\ holds e x2 /\ holds e x3 /\
            holds e x4 \/ false).
  split; case => //.
  - by case=> ?; case; case=> ? ? [] ? ?; split=> //; left.
  - by move=> ?; case => //; do 3! case => ?; move=> ?; left.
rewrite h {h} /= !map_cat /= -!map_comp.
set s1 := [seq _ | _ <- _]; set s2 := [seq _ | _ <- _].
set s3 := [seq _ | _ <- _]; rewrite odnf_to_oform_cat.
suff {x1 x2 x3 x4} /= -> :
  holds e (odnf_to_oform s2) <-> 0%:R < eval e t/\ holds e (odnf_to_oform s1).
  suff /= -> :
    holds e (odnf_to_oform s3) <-> 0%:R < - eval e t /\ holds e (odnf_to_oform s1).
    rewrite oppr_gt0; split.
      by case; move/eqP; rewrite neqr_lt; case/orP=> -> h1; [right | left].
    by case; case=> h ?; split=> //; apply/eqP; rewrite neqr_lt h ?orbT.
  rewrite /s1 /s3.
  elim: (neq_elim_aux lt_l neq_l) => /= [| t1 l ih] /=; first by split => //; case.
  set y1 := foldr _ _ _; set y2 := foldr _ _ _; set y3 := foldr _ _ _.
  rewrite ih; split.
    case; first by case=> ?; case=> _; case; case=> -> ? ?; split=> //; left.
    by case=> ? ?; split=> //; right.
  by case=> ->; case; [case=> ?; case=> _; case=> ? ?; left| move=> ? ; right].
rewrite /s1 /s2.
elim: (neq_elim_aux lt_l neq_l) => /= [| t1 l ih] /=; first by split => //; case.
set y1 := foldr _ _ _; set y2 := foldr _ _ _; set y3 := foldr _ _ _.
rewrite ih; split.
  case; first by case=> ? [] _ [] [] ? ? ?; split=> //; left.
  by case=> ? ?; split=> //; right.
case=> ? []; last by right.
by case=> ? [] _ [] ? ?; left.
Qed.

Definition oclause_neq_leq_elim oc :=
  flatten (map oclause_neq_elim (oclause_leq_elim oc)).

Lemma terms_of_neq_leq_elim oc1 oc2:
  oc2 \in (oclause_neq_leq_elim oc1) ->
  {subset (terms_of_oclause oc2) <= (terms_of_oclause oc1) ++ map Opp oc1.2}.
Proof.
rewrite /oclause_neq_leq_elim /flatten; rewrite foldr_map.
suff : forall oc3,
  oc3 \in (oclause_leq_elim oc1) ->
  (terms_of_oclause oc3 =i terms_of_oclause oc1) /\ oc3.2 = oc1.2.
  elim: (oclause_leq_elim oc1) => [| t l ih] //= h1.
  rewrite mem_cat; case/orP.
  - move/terms_of_neq_elim=> h u; move/(h u); rewrite !mem_cat.
    by case: (h1 t (mem_head _ _)); move/(_ u)=> -> ->.
  - by move=> h; apply: (ih _ h) => ? loc3; apply: h1; rewrite in_cons loc3 orbT.
move=> {oc2} oc3 hoc3; split; first exact: terms_of_leq_elim.
case: oc3 hoc3=> eq2 neq2 lt2 leq2 /=; case: oc1=> eq1 neq1 lt1 leq1 /=.
elim: leq1 => [| t1 le1 ih] //=; first by rewrite inE; case/eqP=> _ ->.
rewrite map_cat mem_cat; move: ih.
elim: (leq_elim_aux eq1 lt1 le1) => [| t2 l2 ih2] //=; rewrite !in_cons.
move=> h1; case/orP=> /=.
  case/orP; first by case/eqP.
  by move=> h2; apply: ih2; rewrite ?h2 //; move=> h3; apply: h1; rewrite h3 orbT.
case/orP; first by case/eqP.
move=> h3; apply: ih2; last by rewrite h3 orbT.
by move=> h2; apply: h1; rewrite h2 orbT.
Qed.

Lemma oclause_neq_leq_elimP oc e :
  holds e (odnf_to_oform [:: oc])  <->
  holds e (odnf_to_oform (oclause_neq_leq_elim oc)).
Proof.
rewrite /oclause_neq_leq_elim.
rewrite oclause_leq_elimP; elim: (oclause_leq_elim oc) => [| t l ih] //=.
rewrite odnf_to_oform_cat /= ih -oclause_neq_elimP /=.
suff -> : forall A, A \/ false <-> A by [].
by intuition.
Qed.

Definition oclause_to_w oc :=
  let s := oclause_neq_leq_elim oc in
    map (fun x => let: Oclause eq_l neq_l lt_l leq_l := x in (eq_l, lt_l)) s.

Definition w_to_oclause (t : seq (term R) * seq (term R)) :=
  Oclause t.1%PAIR [::] t.2%PAIR [::].

Lemma oclause_leq_elim4 bc oc : oc \in (oclause_leq_elim bc) -> oc.4 == [::].
Proof.
case: bc => bc1 bc2 bc3 bc4; elim: bc4 bc1 bc3 oc => [|t bc4 ih] bc1 bc3 /= oc.
  by rewrite inE; move/eqP; case: oc => ? ? ? oc4 /=; case=> _ _ _ /eqP.
rewrite map_cat; move: (ih bc1 bc3 oc) => /= {ih}.
elim: (leq_elim_aux bc1 bc3 bc4) => [| t2 l2 ih2] //= ih1.
rewrite in_cons; case/orP.
  by move/eqP; case: oc {ih1 ih2} => ? ? ? ? [] /= _ _ _ /eqP.
rewrite mem_cat; case/orP=> [hoc1|].
  apply: ih2; first by move=> hoc2; apply: ih1; rewrite in_cons hoc2 orbT.
  by rewrite mem_cat hoc1.
rewrite in_cons; case/orP=> [| hoc1].
  by move/eqP; case: {ih1 ih2} oc=> ? ? ? ?  [] /= _ _ _ /eqP.
apply: ih2; first by move=> hoc2; apply: ih1; rewrite in_cons hoc2 orbT.
by rewrite mem_cat hoc1 orbT.
Qed.

Lemma oclause_neq_elim2 bc oc :
  oc \in (oclause_neq_elim bc) -> (oc.2 == [::]) && (oc.4 == bc.4).
Proof.
case: bc => bc1 bc2 bc3 bc4; elim: bc2 bc4 oc => [|t bc2 /= ih] bc4 /= oc.
  by rewrite inE; move/eqP; case: oc => ? ? ? oc4 /=; case=> _ /eqP -> _ /eqP.
rewrite map_cat; move: (ih bc4 oc) => /= {ih}.
elim: (neq_elim_aux bc3 bc2) => [| t2 l2 ih2] //= ih1.
rewrite in_cons; case/orP.
  by move/eqP; case: oc {ih1 ih2} => ? ? ? ? [] /= _ -> _ ->; rewrite !eqxx.
rewrite mem_cat; case/orP=> [hoc1|].
  apply: ih2; first by move=> hoc2; apply: ih1; rewrite in_cons hoc2 orbT.
  by rewrite mem_cat hoc1.
rewrite in_cons; case/orP=> [| hoc1].
  by move/eqP; case: {ih1 ih2} oc=> ? ? ? ?  [] /= _ ->  _ ->; rewrite !eqxx.
apply: ih2; first by move=> hoc2; apply: ih1; rewrite in_cons hoc2 orbT.
by rewrite mem_cat hoc1 orbT.
Qed.

Lemma oclause_to_wP e bc :
  holds e (odnf_to_oform (oclause_neq_leq_elim bc)) <->
  holds e (odnf_to_oform (map w_to_oclause (oclause_to_w bc))).
Proof.
rewrite /oclause_to_w /oclause_neq_leq_elim.
move: (@oclause_leq_elim4 bc).
elim: (oclause_leq_elim bc) => [| t1 l1 ih1] //= h4.
rewrite !map_cat !odnf_to_oform_cat.
rewrite -[holds e (_ \/ _)]/(holds e _ \/ holds e _).
suff <- : (oclause_neq_elim t1) = map w_to_oclause
           [seq (let: Oclause eq_l _  lt_l _ := x in (eq_l, lt_l))
              | x <- oclause_neq_elim t1].
  by rewrite ih1 //; move=> oc hoc; apply: h4; rewrite in_cons hoc orbT.
have : forall oc, oc \in (oclause_neq_elim t1) -> oc.2 = [::] /\ oc.4 = [::].
  move=> oc hoc; move/oclause_neq_elim2: (hoc); case/andP=> /eqP -> /eqP ->.
  by move/eqP: (h4 _ (mem_head _ _))->.
elim: (oclause_neq_elim t1) => [| [teq1 tneq1 tleq1 tlt1] l2 ih2] h24 //=.
rewrite /w_to_oclause /=; move: (h24 _ (mem_head _ _ ))=> /= [] -> ->.
by congr (_ :: _); apply: ih2 => oc hoc; apply: h24; rewrite in_cons hoc orbT.
Qed.

Variable wproj : nat -> (seq (term R) * seq (term R)) -> formula R.

Definition proj (n : nat)(oc : oclause R) :=
  foldr Or False (map (wproj n) (oclause_to_w oc)).

Hypothesis wf_QE_wproj : forall i bc (bc_i := wproj i bc),
  dnf_rterm (w_to_oclause bc) -> qf_form bc_i && rformula bc_i.

Lemma dnf_rterm_subproof bc : dnf_rterm bc ->
  all (dnf_rterm \o w_to_oclause) (oclause_to_w bc).
Proof.
case: bc => leq lneql llt lle; rewrite /dnf_rterm /=; case/and4P=> req rneq rlt rle.
rewrite /oclause_to_w /= !all_map.
apply/allP => [] [oc_eq oc_neq oc_le oc_lt] hoc; rewrite /dnf_rterm /= andbT.
rewrite -all_cat; apply/allP=> u hu; move/terms_of_neq_leq_elim: hoc => /=.
move/(_ u); rewrite !mem_cat.
have {hu} hu : [|| u \in oc_eq, u \in oc_neq, u \in oc_le | u \in oc_lt].
  by move: hu; rewrite mem_cat; case/orP=> ->; rewrite ?orbT.
move/(_ hu); case/orP; last first.
  move: rneq.
  have <- : (all (@rterm R) (map Opp lneql)) = all (@rterm R) lneql.
    by elim: lneql => [| t l] //= ->.
  by move/allP; apply.
case/orP; first by apply: (allP req).
case/orP; first by apply: (allP rneq).
case/orP; first by apply: (allP rlt).
exact: (allP rle).
Qed.

Lemma wf_QE_proj i : forall bc (bc_i := proj i bc),
  dnf_rterm bc -> qf_form bc_i && rformula bc_i.
Proof.
case=> leq lneql llt lle /= hdnf; move: (hdnf).
rewrite /dnf_rterm /=; case/and4P=> req rneq rlt rle; rewrite /proj; apply/andP.
move: (dnf_rterm_subproof hdnf).
elim: (oclause_to_w _ ) => //= [a t] ih /andP [h1 h2].
by case: (ih h2)=> -> ->; case/andP: (wf_QE_wproj i h1) => -> ->.
Qed.

Hypothesis valid_QE_wproj :
  forall i bc (bc' := w_to_oclause bc)
    (ex_i_bc := ('exists 'X_i, odnf_to_oform [:: bc'])%oT) e,
  dnf_rterm bc' ->
  reflect (holds e ex_i_bc) (qf_eval e (wproj i bc)).

Lemma valid_QE_proj e i : forall bc (bc_i := proj i bc)
  (ex_i_bc := ('exists 'X_i, odnf_to_oform [:: bc])%oT),
  dnf_rterm bc -> reflect (holds e ex_i_bc) (qf_eval e (proj i bc)).
Proof.
move=> bc; rewrite /dnf_rterm => hdnf; rewrite /proj; apply: (equivP idP).
have -> : holds e ('exists 'X_i, odnf_to_oform [:: bc]) <->
          (exists x : R, holds (set_nth 0 e i x)
            (odnf_to_oform (oclause_neq_leq_elim bc))).
  split; case=> x h; exists x; first by rewrite -oclause_neq_leq_elimP.
  by rewrite oclause_neq_leq_elimP.
have -> :
  (exists x : R,
    holds (set_nth 0 e i x) (odnf_to_oform (oclause_neq_leq_elim bc))) <->
  (exists x : R,
    holds (set_nth 0 e i x) (odnf_to_oform (map w_to_oclause (oclause_to_w bc)))).
  by split; case=> x; move/oclause_to_wP=> h; exists x.
move: (dnf_rterm_subproof hdnf).
rewrite /oclause_to_w; elim: (oclause_neq_leq_elim bc) => /= [|a l ih].
  by split=> //; case.
case/andP=> h1 h2; have {ih h2} ih := (ih h2); split.
- case/orP.
    move/(valid_QE_wproj i e h1)=> /= [x /=] [] // [] h2 [] _ [] h3 _; exists x.
    by left.
  by case/ih => x h; exists x; right.
- case=> x [] /=.
  + case=> h2 [] _ h3; apply/orP; left; apply/valid_QE_wproj => //=.
    by exists x; left.
  + by move=> hx; apply/orP; right; apply/ih; exists x.
Qed.

Let elim_aux f n := foldr Or False (map (proj n) (qf_to_odnf f false)).

Fixpoint quantifier_elim f :=
  match f with
  | f1 /\ f2 => (quantifier_elim f1) /\ (quantifier_elim f2)
  | f1 \/ f2 => (quantifier_elim f1) \/ (quantifier_elim f2)
  | f1 ==> f2 => (~ quantifier_elim f1) \/ (quantifier_elim f2)
  | ~ f => ~ quantifier_elim f
  | ('exists 'X_n, f) => elim_aux (quantifier_elim f) n
  | ('forall 'X_n, f) => ~ elim_aux (~ quantifier_elim f) n
  | _ => f
  end%oT.

Lemma quantifier_elim_wf f :
  let qf := quantifier_elim f in rformula f -> qf_form qf && rformula qf.
Proof.
suffices aux_wf f0 n : let qf := elim_aux f0 n in
  rformula f0 -> qf_form qf && rformula qf.
- by elim: f => //=; do ?[  move=> f1 IH1 f2 IH2;
                     case/andP=> rf1 rf2;
                     case/andP:(IH1 rf1)=> -> ->;
                     case/andP:(IH2 rf2)=> -> -> //
                  |  move=> n f1 IH rf1;
                     case/andP: (IH rf1)=> qff rf;
                     rewrite aux_wf ].
rewrite /elim_aux => rf.
suffices or_wf fs : let ofs := foldr Or False fs in
  all qf_form fs && all rformula fs -> qf_form ofs && rformula ofs.
- apply: or_wf.
  suffices map_proj_wf bcs: let mbcs := map (proj n) bcs in
    all dnf_rterm bcs -> all qf_form mbcs && all rformula mbcs.
    by apply: map_proj_wf; apply: qf_to_dnf_rterm.
  elim: bcs => [|bc bcs ihb] bcsr //= /andP[rbc rbcs].
  by rewrite andbAC andbA wf_QE_proj //= andbC ihb.
elim: fs => //= g gs ihg; rewrite -andbA => /and4P[-> qgs -> rgs] /=.
by apply: ihg; rewrite qgs rgs.
Qed.

Lemma quantifier_elim_rformP e f :
  rformula f -> reflect (holds e f) (qf_eval e (quantifier_elim f)).
Proof.
pose rc e n f := exists x, qf_eval (set_nth 0 e n x) f.
have auxP f0 e0 n0: qf_form f0 && rformula f0 ->
  reflect (rc e0 n0 f0) (qf_eval e0 (elim_aux f0 n0)).
+ rewrite /elim_aux => cf; set bcs := qf_to_odnf f0 false.
  apply: (@iffP (rc e0 n0 (odnf_to_oform bcs))); last first.
  - by case=> x; rewrite -qf_to_dnfP //; exists x.
  - by case=> x; rewrite qf_to_dnfP //; exists x.
  have: all dnf_rterm bcs by case/andP: cf => _; apply: qf_to_dnf_rterm.
  elim: {f0 cf}bcs => [|bc bcs IHbcs] /=; first by right; case.
  case/andP=> r_bc /IHbcs {IHbcs}bcsP.
  have f_qf := dnf_to_form_qf [:: bc].
  case: valid_QE_proj => //= [ex_x|no_x].
    left; case: ex_x => x /(qf_evalP _ f_qf); rewrite /= orbF => bc_x.
    by exists x; rewrite /= bc_x.
  apply: (iffP bcsP) => [[x bcs_x] | [x]] /=.
    by exists x; rewrite /= bcs_x orbT.
  case/orP => [bc_x|]; last by exists x.
  by case: no_x; exists x; apply/(qf_evalP _ f_qf); rewrite /= bc_x.
elim: f e => //.
- by move=> b e _; apply: idP.
- by move=> t1 t2 e _; apply: eqP.
- by move=> t1 t2 e _; apply: idP.
- by move=> t1 t2 e _; apply: idP.
- move=> f1 IH1 f2 IH2 e /= /andP[/IH1[] f1e]; last by right; case.
  by case/IH2; [left | right; case].
- move=> f1 IH1 f2 IH2 e /= /andP[/IH1[] f1e]; first by do 2!left.
  by case/IH2; [left; right | right; case].
- move=> f1 IH1 f2 IH2 e /= /andP[/IH1[] f1e]; last by left.
  by case/IH2; [left | right; move/(_ f1e)].
- by move=> f IHf e /= /IHf[]; [right | left].
- move=> n f IHf e /= rf; have rqf := quantifier_elim_wf rf.
  by apply: (iffP (auxP _ _ _ rqf)) => [] [x]; exists x; apply/IHf.
move=> n f IHf e /= rf; have rqf := quantifier_elim_wf rf.
case: auxP => // [f_x|no_x]; first by right=> no_x; case: f_x => x /IHf[].
by left=> x; apply/IHf=> //; apply/idPn=> f_x; case: no_x; exists x.
Qed.

Definition proj_sat e f := qf_eval e (quantifier_elim (to_rform f)).

Lemma proj_satP :   forall e f, reflect (holds e f) (proj_sat e f).
Proof.
move=> e f; have fP := quantifier_elim_rformP e (to_rform_rformula f).
by apply: (iffP fP); move/to_rformP.
Qed.

End EvalTerm.

End ord.


Require Export Task.driver_requires.
Import ListNotations.
Import FloatIO.
Import DScopeNotations.
Open Scope D_scope.

(* Inductive type used to name state variables. *)
Inductive stateVar : Set :=
| SvT
| SvX
| SvXD
| SvXDD
| SvCOEFF_OF_REST
| SvGRAVITY
| SvT_STOP
| SvDT
| SvDT_MAX
| SvDT_MIN
| SvDT_PRINT.

Lemma state_var_eq: forall (r1 r2: stateVar), {r1 = r2} + {r1 <> r2}.
Proof. decide equality. Defined.
Global Opaque state_var_eq.

Definition svIndex (sv: stateVar) : positive :=
  match sv with
  | SvT => 1
  | SvX => 2
  | SvXD => 3
  | SvXDD => 4
  | SvCOEFF_OF_REST => 5
  | SvGRAVITY => 6
  | SvT_STOP => 7
  | SvDT => 8
  | SvDT_MAX => 9
  | SvDT_MIN => 10
  | SvDT_PRINT => 11
  end.

Definition svStrList :=
  [
    (SvT, "T");
    (SvX, "X");
    (SvXD, "XD");
    (SvXDD, "XDD");
    (SvCOEFF_OF_REST, "COEFF_OF_REST");
    (SvGRAVITY, "GRAVITY");
    (SvT_STOP, "T_STOP");
    (SvDT, "DT");
    (SvDT_MAX, "DT_MAX");
    (SvDT_MIN, "DT_MIN");
    (SvDT_PRINT, "DT_PRINT")
  ]%positive.

Definition model_default_values (_: unit) :=
  [
    (SvT,             "0.0"#D);
    (SvX,             "10.0"#D);
    (SvXD,            "0.0"#D);
    (SvXDD,           "0.0"#D);
    (SvCOEFF_OF_REST, "0.80"#D);
    (SvGRAVITY,       "9.88"#D);
    (SvT_STOP,        "10.0"#D);
    (SvDT,            "0.01"#D);
    (SvDT_MAX,        "0.005"#D);
    (SvDT_MIN,        "0.001"#D);
    (SvDT_PRINT,      "0.01"#D)
  ].

Definition modelOutputs : list stateVar := [SvT; SvX; SvXD].

Definition modelPairs : list (stateVar * stateVar) :=
  [(SvX, SvXD); (SvXD, SvXDD)].


Require Import CoqCompile.CpsK.
Require Import List.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.Lists.
Require Import Bool ZArith.

Set Implicit Arguments.
Set Strict Implicit.

Import CPSK.

  (** returns the function name f if [fun x => e] is a simple eta expansion of the form
     [fun x => f x]. *)
  Definition match_eta (k':cont) (x:var) (e:exp) : option op :=
    match e with
      | App_e op1 (k::nil) ((Var_o y)::nil) =>
        if eq_dec y x && eq_dec k k' then Some op1 else None
      | _ => None
    end.

  Fixpoint eq_vars_ops (xs:list var) (vs:list op) : bool :=
    match xs, vs with
      | nil, nil => true
      | x::xs, (Var_o y)::vs => eq_dec x y && eq_vars_ops xs vs
      | _, _ => false
    end.

  (** similar to the above, but for the general case of [fun (x1,...,xn) => e] being an
     eta-expansion of [fun (x1,...,xn) => f(x1,...,xn)]. *)
  Definition match_etas (ks : list cont) (xs:list var) (e:exp) : option op :=
    match e with
      | App_e op1 k ys =>
        if eq_dec k ks && eq_vars_ops xs ys then Some op1 else None
      | _ => None
    end.

  (** Let-bind [xi] to [#i v] for the expression [e].  This is used in the compilation
      of pattern matching below. *)
  Fixpoint bind_proj(v:op)(xs:list var)(offset:Z)(e:exp) : exp :=
    match xs with
      | nil => e
      | x::xs => Let_e (Prim_d x Proj_p ((Int_o offset)::v::nil)) (bind_proj v xs (1+offset) e)
    end.

Section free.
  Variable v : var + cont.

  Definition free_in_var (o : var) : bool :=
    match v with
      | inl v => eq_dec v o
      | _ => false
    end.

  Definition defined_by (d : decl) : bool :=
    match v with
      | inl v =>
        match d with
          | Op_d v' _ => eq_dec v v'
          | Prim_d v' _ _ => eq_dec v v'
          | Fn_d v' _ _ _ => eq_dec v v'
          | Bind_d a b _ _ => eq_dec a v || eq_dec b v
        end
      | inr _ => false
    end.

  Definition free_in_op (o : op) : bool :=
    match v with
      | inl v =>
        match o with
          | Var_o v' => eq_dec v v'
          | Int_o _ => false
          | Con_o _ => false
          | InitWorld_o => false
        end
      | _ => false
    end.

  Definition free_in_k (c : cont) : bool :=
    match v with
      | inl _ => false
      | inr x => eq_dec x c
    end.

  Fixpoint free_in_exp (e : exp) : bool :=
    match e with
      | App_e f ks xs =>
        free_in_op f || anyb free_in_k ks || allb free_in_op xs
      | AppK_e k xs =>
        free_in_k k || allb free_in_op xs
      | Let_e ds e =>
        if defined_by ds then false
          else if free_in_decl ds then true else free_in_exp e
      | LetK_e ks e =>
        if anyb (fun x => let '(k,_,_) := x in free_in_k k) ks then false
        else free_in_exp e || anyb (fun x => let '(_, vs, e) := x in
          (if anyb free_in_var vs then false else free_in_exp e)) ks
      | Letrec_e ds e =>
        if anyb defined_by ds then false
        else if anyb free_in_decl ds then true else free_in_exp e
      | Switch_e o br def =>
        if free_in_op o then
          if allb (fun x => free_in_exp (snd x)) br
            then match def with
                   | None => true
                   | Some e => free_in_exp e
                 end
            else
              false
          else
            false
      | Halt_e o1 o2 =>
        orb (free_in_op o1) (free_in_op o2)
    end
  with free_in_decl (d : decl) : bool :=
    match d with
      | Op_d _ o => free_in_op o
      | Prim_d _ _ vs => anyb free_in_op vs
      | Bind_d _ _ _ vs => anyb free_in_op vs
      | Fn_d _ ks vs e =>
        if anyb free_in_k ks || anyb free_in_var vs then false
          else free_in_exp e
    end.
End free.

Section free_vars.
  (** list is suboptimal here **)
  Require Import ExtLib.Structures.Monads.
  Require Import ExtLib.Structures.Folds.
  Require Import ExtLib.Structures.Reducible.
  Require Import ExtLib.Structures.Monoid.
  Require Import ExtLib.Structures.Sets.
  Require Import ExtLib.Data.Monads.IdentityMonad.
  Require Import ExtLib.Data.Monads.WriterMonad.
  Section with_sets.
    Variable s : Type.
    Context {DSet_s : DSet s (@eq (var + cont))}.

  Section monadic.
    Variable m : Type -> Type.
    Context {Monad_m : Monad m}.
    Context {Writer_m : MonadWriter (Monoid_set_union (R := @eq (var + cont))) m}.

    Definition free_vars_op (o : op) : m unit :=
      match o with
        | Var_o v => tell (singleton (inl v))
        | _ => ret tt
      end.

    Definition free_vars_k (k : cont) : m unit :=
      tell (singleton (inr k)).

    Import MonadNotation.
    Local Open Scope monad_scope.

    (** remove elements of v **)
    Definition filter_vars (v : list var) : s -> s :=
      filter (fun x => negb (anyb (fun y => eq_dec x (inl y)) v)).

    Definition filter_conts (v : list cont) : s -> s :=
      filter (fun x => negb (anyb (fun y => eq_dec x (inr y)) v)).

    Fixpoint free_vars_exp' (e : exp) : m unit :=
      match e with
        | App_e f ks xs =>
          free_vars_op f ;;
          iterM free_vars_k ks ;;
          iterM free_vars_op xs
        | AppK_e k xs =>
          free_vars_k k ;;
          iterM free_vars_op xs
        | LetK_e ks e =>
          censor (filter_conts (map (fun x => let '(k,_,_) := x in k) ks))
            (iterM (fun x => let '(k,xs,e) := x in
              censor (filter_vars xs) (free_vars_exp' e)) ks ;;
             free_vars_exp' e)
        | Halt_e o1 o2 =>
          free_vars_op o1 ;;
          free_vars_op o2
        | Let_e ds e =>
          free_vars_decl' false ds ;;
          censor (filter (fun x => negb (defined_by x ds))) (free_vars_exp' e)
        | Letrec_e ds e =>
          censor (filter (fun x => negb (anyb (defined_by x) ds)))
                 (iterM (free_vars_decl' true) ds ;; free_vars_exp' e)
        | Switch_e o arms def =>
          free_vars_op o ;;
          mapM (fun x => free_vars_exp' (snd x)) arms ;;
          match def with
            | None => ret tt
            | Some e => free_vars_exp' e
          end
      end
    with free_vars_decl' (rec : bool) (d : decl) : m unit :=
      match d with
        | Op_d v o =>
          if rec then
            censor (filter (fun x => negb (eq_dec (inl v) x))) (free_vars_op o)
          else
            free_vars_op o
        | Prim_d v p os =>
          if rec then
            censor (filter (fun x => negb (eq_dec (inl v) x))) (mapM free_vars_op os) ;; ret tt
          else
            iterM free_vars_op os
        | Bind_d x w m os =>
          iterM free_vars_op os
        | Fn_d v ks xs e =>
          censor (filter (fun x => negb (orb (anyb (fun v => eq_dec x (inl v)) xs) (anyb (fun v => eq_dec x (inr v)) ks))))
            (if rec then
              censor (filter (fun x => negb (eq_dec (inl v) x))) (free_vars_exp' e)
             else
              free_vars_exp' e)
      end.
  End monadic.

  Definition free_vars_exp (e : exp) : s :=
    unIdent (execWriterT (free_vars_exp' e)).

  Definition free_vars_decl (r : bool) (d : decl) : s :=
    unIdent (execWriterT (free_vars_decl' r d)).

  Definition free_vars_cont (k : cont) (xs : list var) (e : exp) : s :=
    unIdent (execWriterT (censor (filter_vars xs) (free_vars_exp' e))).

  End with_sets.

End free_vars.

Section tuples_fun.
  Require Import ExtLib.Data.Map.FMapAList.
  Require Import ExtLib.Data.Set.ListSet.

  Fixpoint tuples_arity_exp' (e:exp) (dom:alist var nat) : alist var nat :=
    match e with
      | App_e o ks os => dom
      | Let_e d e =>
        let dom' := tuples_arity_decl' d dom in
        tuples_arity_exp' e dom'
      | Letrec_e ds e =>
        let dom' := List.fold_left (fun acc d => tuples_arity_decl' d acc) ds dom in
        tuples_arity_exp' e dom'
      | Switch_e o arms def =>
        let init := match def with
                      | Some e => tuples_arity_exp' e dom
                      | None => dom
                    end in
        List.fold_left (fun acc x => let '(p,e) := x in tuples_arity_exp' e acc) arms init
      | Halt_e o1 o2 => dom
      | AppK_e k os => dom
      | LetK_e kves e =>
        let dom' := List.fold_left (fun acc x => let '(k, xs, e) := x in
          tuples_arity_exp' e acc) kves dom in
        tuples_arity_exp' e dom'
    end
  with tuples_arity_decl' (d:decl) (dom:alist var nat) : alist var nat :=
    match d with
      | Op_d x o => dom
      | Prim_d x p os => match p with
                          | MkTuple_p => Maps.add x (length os) dom
                          | _ => dom
                        end
      | Fn_d v ks xs e => tuples_arity_exp' e dom
      | Bind_d x w m os => dom
    end.

  Definition tuples_arity_exp (e:exp) : alist var nat :=
    tuples_arity_exp' e Maps.empty.

  Definition tuples_arity_decl (d:decl) : alist var nat :=
    tuples_arity_decl' d Maps.empty.

  Definition tuples_in_exp (e:exp) : lset (@eq var) :=
    Maps.keys _ _ (tuples_arity_exp e).

  Definition tuples_in_decl (d:decl) : lset (@eq var) :=
    Maps.keys _ _ (tuples_arity_decl d).

End tuples_fun.


Require Import Primitives Layer1 BlockAllocator.Definitions.
Require Import Omega FunctionalExtensionality.

Lemma delete_eq:
  forall A AEQ V (m: @mem A AEQ V) a,
    delete m a a = None.
Proof.
  intros; unfold delete; simpl.
  destruct (AEQ a a); intuition.
Qed.

Lemma delete_ne:
  forall A AEQ V (m: @mem A AEQ V) a a',
    a <> a' ->
    delete m a a' = m a'.
Proof.
  intros; unfold delete; simpl.
  destruct (AEQ a' a); subst; intuition.
Qed.

Lemma star_split:
    forall (AT : Type) (AEQ : EqDec AT) (V : Type)
      (p q : @pred AT AEQ V) (m : @mem AT AEQ V),
      (p * q)%pred m ->
      (exists m1 m2, mem_disjoint m1 m2 /\ p m1 /\ q m2 /\ mem_union m1 m2 = m)%type.
  Proof.
    intros; unfold sep_star in *; rewrite sep_star_is in *;
      destruct H; cleanup; eauto.
    do 2 eexists; intuition eauto.
  Qed.

Lemma upd_eq':
  forall (A V : Type) (AEQ : EqDec A) (m : mem) (a : A) (v : V),
    @upd _ _ AEQ m a v a = Some v.
Proof.
  intros; apply upd_eq; eauto.
Qed.

Lemma ptsto_bits'_app_split:
  forall l1 l2 n dh,
    ptsto_bits' dh (l1++l2) n =p=>
    (ptsto_bits' dh l1 n * ptsto_bits' dh l2 (n + length l1))%pred.
Proof.
  unfold ptsto_bits; induction l1;
    simpl; intros; eauto.
  rewrite Nat.add_0_r; cancel.
  rewrite IHl1; cancel.
  rewrite Nat.add_succ_r; eauto.
Qed.

Lemma ptsto_bits'_app_merge:
  forall l1 l2 n dh,
    (ptsto_bits' dh l1 n * ptsto_bits' dh l2 (n + length l1))%pred =p=>
     ptsto_bits' dh (l1++l2) n.
Proof.
  unfold ptsto_bits; induction l1;
    simpl; intros; eauto.
  rewrite Nat.add_0_r; cancel.
  rewrite <- IHl1; cancel.
  rewrite Nat.add_succ_r; eauto.
Qed.

Lemma ptsto_bits'_inbound:
  forall l n dh a F d,
    a < length l + n ->
    a >= n ->
    (F * ptsto_bits' dh l n)%pred d ->
    (exists vs, d (S a) = Some vs /\
           (nth (a - n) l 0 = 0 -> dh a = None) /\
           (nth (a - n) l 0 = 1 -> dh a = Some (fst vs)) /\
           (nth (a - n) l 0 < 2))%type.
Proof.
   eapply (rev_ind
             (fun l =>
                forall (n : nat) (dh : disk value) (a : nat) (F : pred) (d : mem),
  a < length l + n ->
  a >= n ->
  (F ✶ ptsto_bits' dh l n) d ->
  exists vs : set value,
    (d (S a) = Some vs /\
     (nth (a - n) l 0 = 0 -> dh a = None) /\
     (nth (a - n) l 0 = 1 -> dh a = Some (fst vs)) /\
     (nth (a - n) l 0 < 2))%type
));
     simpl; intros.
   omega.

   rewrite app_length in *; simpl in *.
   rewrite ptsto_bits'_app_split in *; simpl in *.
   destruct (addr_dec a (n + length l)); subst.
   - rewrite minus_plus.
     rewrite app_nth2; try omega.
     rewrite Nat.sub_diag; simpl.
     destruct_lifts.
     eexists; split.
     eapply ptsto_valid; pred_apply; cancel.
     intuition; subst;
       destruct_lifts; eauto.
     destruct x; eauto.
     destruct x; eauto.
     destruct_lifts; tauto.
   - destruct_lifts.
     rewrite app_nth1; try omega.
     eapply H; eauto.
     omega.
     pred_apply' H2; cancel.
Qed.

Lemma septract_sep_star_extract :
  forall AT AEQ V (p q: @pred AT AEQ V),
    q =p=> (exists F, F * p) ->
    q =p=> (p --* q) * p.
Proof.
  intros.
  intros m Hm.
  eapply_fresh H in Hm.
  destruct_lift Hx.
  apply star_split in H0; cleanup.

  unfold sep_star; rewrite sep_star_is.
  unfold sep_star_impl.
  unfold septract.
  do 2 eexists; intuition.
  eexists; intuition eauto.
Qed.

Lemma septract_sep_star_extract' :
  forall AT AEQ V (p q: @pred AT AEQ V) m,
    (exists F, F * p)%pred m ->
    q m ->
    ((p --* q) * p)%pred m.
Proof.
  intros.
  destruct_lift H.
  apply star_split in H; cleanup.

  unfold sep_star; rewrite sep_star_is.
  unfold sep_star_impl.
  unfold septract.
  do 2 eexists; intuition.
  eexists; intuition eauto.
Qed.

Lemma septract_sep_star_merge :
  forall AT AEQ V (p q: @pred AT AEQ V),
    (forall m m', p m -> p m' -> m = m') ->
    (p --* q) * p =p=> q.
Proof.
  unfold septract; intros.
  intros m Hm.
  apply star_split in Hm; cleanup.
  erewrite (H x0); eauto.
Qed.

Lemma septract_exists_extract :
  forall T AT AEQ V (p: @pred AT AEQ V) (q: T ->  @pred AT AEQ V),
    (p --* exists a, q a) =p=> exists a, (p --* q a).
Proof.
  unfold septract; intros.
  intros m Hm; cleanup.
  destruct_lift H1.
  eexists; eauto.
Qed.

Lemma septract_double_merge :
  forall AT AEQ V (p q r: @pred AT AEQ V),
    r --* (p --* q) =p=> (r * p) --* q.
Proof.
  unfold septract; intros.
  intros m Hm; cleanup.
  exists (mem_union x x0); intuition.
  apply mem_disjoint_assoc_1; eauto.
  unfold sep_star; rewrite sep_star_is.
  unfold sep_star_impl.
  do 2 eexists; intuition.
  eapply mem_disjoint_union; eauto.
  rewrite <- mem_union_assoc; eauto.
Qed.

Lemma septract_double_split :
  forall AT AEQ V (p q r: @pred AT AEQ V),
    (r * p) --* q =p=> r --* (p --* q).
Proof.
  unfold septract; intros.
  intros m Hm; cleanup.
  apply star_split in H0; cleanup.
  exists x0; intuition eauto.
  eapply mem_disjoint_union; eauto.
  apply mem_disjoint_comm; eauto.
  apply mem_disjoint_assoc_1; eauto.
  apply mem_disjoint_comm; eauto.
  exists x1; intuition eauto.
  apply mem_disjoint_assoc_2; eauto.
  rewrite mem_union_assoc; eauto.
  eapply mem_disjoint_union; eauto.
  apply mem_disjoint_comm; eauto.
  apply mem_disjoint_assoc_1; eauto.
  apply mem_disjoint_comm; eauto.
  apply mem_disjoint_assoc_2; eauto.
Qed.

Lemma ptsto_bits'_extract:
  forall l n dh a,
    a < length l + n ->
    a >= n ->
    ptsto_bits' dh l n =p=> exists vs, (((S a |-> vs) --* ptsto_bits' dh l n) * (S a |-> vs)).
Proof.
  intros.
  intros m Hm.
  edestruct ptsto_bits'_inbound; eauto.
  pred_apply' Hm; eassign dh; cancel.
  cleanup.
  exists x.

  eapply septract_sep_star_extract' in Hm; eauto.
  exists (diskIs (mem_except m (S a))).
  eapply diskIs_extract' in H1.
  assert (A: diskIs m m).
  unfold diskIs; eauto.
  apply H1 in A; eauto.
Qed.

Lemma ptsto_bits'_merge:
  forall l n dh a vs,
    ((S a |-> vs) --* ptsto_bits' dh l n) * (S a |-> vs) =p=> ptsto_bits' dh l n.
Proof.
  intros.
  unfold septract; intros.
  intros m Hm.
  apply star_split in Hm; cleanup.
  destruct_lift H3.
  eapply ptsto_complete in H3; eauto; subst; eauto.
Qed.

Lemma rep_merge:
  forall dh a vs,
    ((a |-> vs) --* rep dh) * (a |-> vs) =p=> rep dh.
Proof.
  intros.
  unfold septract; intros.
  intros m Hm.
  apply star_split in Hm; cleanup.
  destruct_lift H3.
  eapply ptsto_complete in H3; eauto; subst; eauto.
Qed.

Lemma rep_extract:
  forall dh a,
    dh a <> None ->
    rep dh =p=> exists vs, (((S a |-> vs) --* rep dh) * (S a |-> vs)).
Proof.
  intros.
  unfold rep, ptsto_bits.
  norml.
  unfold stars; simpl.
  erewrite ptsto_bits'_extract with (a:= a).
  norm.
  intros m Hm.
  eapply septract_sep_star_extract'.
  pred_apply; cancel.
  pred_apply; cancel.
  rewrite sep_star_comm.
  erewrite ptsto_bits'_merge; eauto.
  eauto.
  destruct (value_to_bits bitmap); simpl.
  inversion valid.
  rewrite H0.
  rewrite Nat.add_0_r.
  destruct (lt_dec a block_size); eauto; intuition.
  exfalso; apply H; apply H2; omega.
  omega.
Qed.

Lemma rep_extract_block_size:
  forall dh a,
    a < block_size ->
    rep dh =p=> exists vs, (((S a |-> vs) --* rep dh) * (S a |-> vs)).
Proof.
  intros.
  unfold rep, ptsto_bits.
  norml.
  unfold stars; simpl.
  erewrite ptsto_bits'_extract with (a:= a).
  norm.
  intros m Hm.
  eapply septract_sep_star_extract'.
  pred_apply; cancel.
  pred_apply; cancel.
  rewrite sep_star_comm.
  erewrite ptsto_bits'_merge; eauto.
  eauto.
  destruct (value_to_bits bitmap); simpl.
  inversion valid.
  rewrite H0.
  rewrite Nat.add_0_r; eauto.
  omega.
Qed.

Lemma rep_extract_block_size_double:
  forall dh a v,
    a < block_size ->
    (0 |-> v --* rep dh) =p=> exists vs, (((0 |-> v * S a |-> vs) --* rep dh) * (S a |-> vs)).
Proof. Admitted. (*
  intros.
  unfold rep, ptsto_bits.
  norml.
  unfold stars; simpl.
  intros m Hm.
  unfold septract in Hm; simpl in *; cleanup.
  destruct_lift Hm; cleanup.
  destruct_lift H2.
  erewrite ptsto_bits'_extract with (a:= a) in H2.
  destruct_lift H2.
  exists (dummy1_cur, dummy1_old).
  rewrite <- septract_double_merge.
  unfold sep_star; rewrite sep_star_is.
  unfold sep_star_impl.
  unfold septract in *; cleanup.
  eapply ptsto_complete in H8; eauto; cleanup.
  do 2 eexists; intuition.
  shelve.
  shelve.
  eexists; intuition.
  shelve.
  exists x, x1; intuition eauto.
  shelve.

  do 2 eexists; intuition.
  eexists; exists empty_mem; intuition.
  shelve.
  apply mem_disjoint_comm; apply mem_disjoint_empty_mem.
  exists x0, (mem_union x2 x1); intuition eauto.
  shelve.
  apply emp_star.
  apply sep_star_lift_apply'; eauto.
  apply emp_empty_mem.
  eauto.
  destruct (value_to_bits dummy); simpl.
  inversion valid.
  rewrite H7.
  rewrite Nat.add_0_r; eauto.
  omega.
  Unshelve.
  apply x2.
Admitted.
 *)

Lemma rep_extract_bitmap:
  forall dh,
    rep dh =p=> exists vs, (((0 |-> vs) --* rep dh) * (0 |-> vs)).
Proof.
  intros.
  unfold rep, ptsto_bits.
  norml.
  unfold stars; simpl.
  norm.
  intros m Hm.
  eapply septract_sep_star_extract'.
  pred_apply; cancel.
  pred_apply; cancel.
  eauto.
Qed.

Lemma rep_eq:
  forall d s1 s2 F F',
    (F * rep s1)%pred d ->
    (F' * rep s2)%pred d ->
    s1 = s2.
Proof.
  intros.
  extensionality k.
  unfold rep in *; simpl in *.

  destruct_lift H; destruct_lift H0.
  assert_fresh (d 0 = Some (dummy,dummy0)).
  eapply ptsto_valid'; pred_apply' H; cancel.
  assert_fresh (d 0 = Some (dummy1,dummy2)).
  eapply ptsto_valid'; pred_apply' H0; cancel.
  cleanup.

  destruct (lt_dec k block_size).

  unfold ptsto_bits in *.
  eapply (@ptsto_bits'_inbound _ _ _ k) in H; try omega; cleanup.
  eapply (@ptsto_bits'_inbound _ _ _ k) in H0; try omega; cleanup.
  rewrite Nat.sub_0_r in *.

  destruct_fresh (nth k (bits (value_to_bits dummy1)) 0).
  rewrite H1, H6; eauto.
  destruct n; try omega.
  rewrite H2, H7; eauto.
  destruct (value_to_bits dummy1); simpl in *.
  unfold valid_bitlist in *; cleanup.
  omega.
  destruct (value_to_bits dummy1); simpl in *.
  unfold valid_bitlist in *; cleanup.
  omega.
  erewrite H4, H5; eauto; omega.
Qed.

Lemma ptsto_bits'_update_oob:
  forall l n dh a v,
    a >= length l + n ->
    ptsto_bits' dh l n ⇨⇨ ptsto_bits' (upd dh a v) l n.
Proof.
  eapply (rev_ind
    (fun l =>
       forall n dh a v,
    a >= length l + n ->
    ptsto_bits' dh l n ⇨⇨ ptsto_bits' (upd dh a v) l n));
    simpl in *; intros.
  cancel.
  rewrite app_length in *; simpl in *.
  rewrite ptsto_bits'_app_split; simpl in *.
  rewrite <- ptsto_bits'_app_merge; simpl.
  rewrite <- H; try omega.
  cancel.
  rewrite upd_ne; eauto.
  omega.
Qed.

 Lemma ptsto_bits'_update_apply:
   forall l n a v vs dh m F,
     a < length l + n ->
     a >= n ->
     m (S a) = Some vs ->
     (F * ptsto_bits' dh l n)%pred m ->
     (F * ptsto_bits' (upd dh a v) (updN l (a - n) 1) n)%pred (upd m (S a) (v, fst vs::snd vs)).
 Proof.
   eapply (rev_ind
    (fun l =>
       forall n a v vs dh m F,
         a < length l + n ->
         a >= n ->
         m (S a) = Some vs ->
         (F * ptsto_bits' dh l n)%pred m ->
         (F * ptsto_bits' (upd dh a v) (updN l (a - n) 1) n)%pred (upd m (S a) (v, fst vs::snd vs))));
     simpl in *; intros.
   omega.
   rewrite app_length in *; simpl in *.
   rewrite ptsto_bits'_app_split in H3; simpl in *.
   destruct (addr_dec a (length l + n)); subst.
   -
     rewrite Nat.add_sub.
     rewrite updN_app_tail; simpl.
     rewrite <- ptsto_bits'_app_merge; simpl.
     destruct_lift H3.
     eapply pimpl_apply.
     2: rewrite Nat.add_comm;
       eapply ptsto_upd;
       pred_apply; cancel.
     cancel.
     erewrite <- ptsto_bits'_update_oob.
     cancel.
     destruct x; cancel.
     destruct x; cancel.
     eauto.
     rewrite Nat.add_comm, upd_eq'; eauto.
   -
     rewrite updN_app1; try omega.
     rewrite <- ptsto_bits'_app_merge.
     simpl.
     rewrite updN_length.
     eapply pimpl_apply.
     2: {
       eapply H; eauto.
       omega.
       eassign dh;
         eassign (F
        ✶  ((exists vs : value * list value,
                 S (n + length l) |-> vs
                 ✶ match x with
                   | 0 => ⟦⟦ dh (n + length l) = None ⟧⟧
                   | 1 => ⟦⟦ dh (n + length l) = Some (fst vs) ⟧⟧
                   | S (S _) => ⟦⟦ False ⟧⟧
                   end) ✶ emp)).
       pred_apply; cancel.
     }
     rewrite upd_ne; try omega.
     cancel.
 Qed.

 Lemma ptsto_bits'_update_septract:
   forall l n a v vs dh,
     a < length l + n ->
     a >= n ->
     S a |-> vs --* ptsto_bits' dh l n =p=>
     S a |-> (v, fst vs::snd vs) --* ptsto_bits' (upd dh a v) (updN l (a - n) 1) n.
 Proof.

   intros.
   unfold septract, pimpl; intros.
   cleanup.

   unfold emp in *; simpl in *.
   assert (A: x (S a) = Some vs).
   eapply ptsto_valid'.
   pred_apply' H2; cancel.
   exists (upd x (S a) (v, fst vs :: snd vs)).
   intuition.
   apply mem_disjoint_comm.
   eapply mem_disjoint_upd; eauto.
   apply mem_disjoint_comm; eauto.
   eapply emp_star.
   eapply ptsto_upd'; pred_apply; cancel.
   rewrite mem_union_comm.
   rewrite mem_union_upd.
   apply emp_star.
   eapply ptsto_bits'_update_apply; eauto.

   apply mem_disjoint_comm in H1.
   eapply mem_union_addr in A; eauto.
   rewrite mem_union_comm; eauto.
   pred_apply; cancel.
   apply mem_disjoint_comm in H1; eauto.
   apply mem_disjoint_comm.
   eapply mem_disjoint_upd; eauto.
   apply mem_disjoint_comm; eauto.
 Qed.

 Lemma ptsto_bits'_update:
   forall l n a v vs dh,
     a < length l + n ->
     a >= n ->
      S a |-> vs --* ptsto_bits' dh l n
  ✶ S a |-> (v, fst vs :: snd vs)
  ⇨⇨ ptsto_bits' (upd dh a v)
  (updN l (a-n) 1) n.
 Proof.
   intros.
   rewrite ptsto_bits'_update_septract; eauto.
   rewrite ptsto_bits'_merge; eauto.
 Qed.