(*****************************************************************************************)
(*****************************************************************************************)
(*This file gives the SN proof after embedding the theory*)
(*There are two main steps to prove SN :*)
(*1. Soundness of the first order theory*)
(*2. New proof of the conversion rule*)
(*To prove 2, just need to prove eq_foterm can be embedded in eq_typ*)
(*****************************************************************************************)
(*****************************************************************************************)

Require Export GenLemmas.
Require Import AbsTheoryIntp.
Import AbsTheorySyn AbsTheorySem.

(*SN for the abstract theory*)
Module Abs_SN_Theory (Msyn : TheorySyn) (Msem : TheorySem) (Mintp : TheoryIntp Msyn Msem).

Import Msyn Msem Mintp.
Import MAI MSI.

Lemma intp_sound : forall hyp P, deriv hyp P ->
  exists p, typ ((intp_hyp hyp)) p (intp_fofml P).
induction 1; simpl.
(*hyp*)
 exists (Ref n); red; simpl; intros. unfold val_ok in H1.
 rewrite <- lift_intp_lift_fml. apply H1. apply intp_hyp_nth_fml; trivial.

(*ax_intro*)
 apply intp_ax; trivial.

(*true_intro*)
 apply True_symb_intro.

(*false_elim*)
 destruct IHderiv. exists (App x (intp_fofml f)).
 apply False_symb_elim; [|apply intp_fofml_prop]; trivial.

(*neg_intro*)
 destruct IHderiv as (p, IH). exists p.
 apply Neg_intro; trivial.

(*neg_elim*)
 destruct IHderiv. exists x.
 apply Neg_elim; trivial.

(*conj_intro*)
 destruct IHderiv1 as (x, IH1).
 destruct IHderiv2 as (x', IH2).
 apply Conj_intro with (u:=x) (v:=x'); [apply intp_fofml_prop; apply deriv_well_typed
   |apply intp_fofml_prop; apply deriv_well_typed|split]; trivial.

(*conj_elim1*)
 destruct IHderiv as (t, IH). apply deriv_well_typed in H. simpl in IH.
 apply Conj_elim1 with (B:=(intp_fofml f2)) (t:=t);
   [apply intp_fofml_prop|apply intp_fofml_prop|trivial];
   unfold wf_fml, fv_fml in H |- *; simpl in H |- *; intros; apply H;
     rewrite in_app_iff; [left|right]; trivial.

(*conj_elim2*)
 destruct IHderiv as (t, IH). apply deriv_well_typed in H.
 apply Conj_elim2 with (A:=(intp_fofml f1)) (t:=t);
   [apply intp_fofml_prop|apply intp_fofml_prop|trivial];
   unfold wf_fml, fv_fml in H |- *; simpl in H; intros; apply H;
     rewrite in_app_iff; [left|right]; trivial.

(*disj_intro1*)
 destruct IHderiv.
 apply Disj_intro1 with (t:=x); [apply intp_fofml_prop; apply deriv_well_typed
   |apply intp_fofml_prop|]; trivial.

(*disj_intro2*)
 destruct IHderiv.
 apply Disj_intro2 with (t:=x); [apply intp_fofml_prop
   |apply intp_fofml_prop; apply deriv_well_typed|]; trivial.

(*disj_elim*)
 destruct IHderiv1, IHderiv2, IHderiv3. simpl in H3, H4.
 apply deriv_well_typed in H. apply deriv_well_typed in H0.
 apply wf_weakening in H0.
 apply Disj_elim with (t:=x) (t1:=x0) (t2:=x1) (A:=intp_fofml f1) (B:=intp_fofml f2);
   [apply intp_fofml_prop|apply intp_fofml_prop|apply intp_fofml_prop
     | |rewrite lift_intp_lift_fml|rewrite lift_intp_lift_fml]; trivial;
   unfold wf_fml, fv_fml in H |- *; intros; apply H; simpl;
     rewrite in_app_iff; [left|right]; trivial.

(*impl_intro*)
 destruct IHderiv as (p, IH). simpl in IH.
 rewrite <- lift_intp_lift_fml in IH.
 exists (Abs (intp_fofml f1) p).
 apply Impl_intro; [apply intp_fofml_prop|destruct f2; simpl; discriminate|]; trivial.

(*impl_elim*)
 destruct IHderiv1, IHderiv2. exists (App x x0).
 apply Impl_elim with (A:=intp_fofml f1); trivial; [destruct f1 | destruct f2];
   simpl; discriminate.

(*fall_intro*)
 destruct IHderiv. simpl in H0. exists ((Abs sort x)).
 apply Fall_intro; trivial.
  replace (sort :: intp_hyp hyp) with (intp_hyp (None :: hyp)); trivial.
  apply intp_fofml_prop. apply deriv_well_typed; trivial.

(*fall_elim*)
 destruct IHderiv. exists (App x (intp_foterm u)).
 rewrite <- subst_intp_subst_fml.
 apply Fall_elim; [| |apply intp_foterm_sort]; trivial.
  replace (sort :: intp_hyp hyp) with (intp_hyp (None :: hyp)); trivial.
  apply intp_fofml_prop. apply deriv_well_typed in H0.
  unfold wf_fml, fv_fml in H0 |- *; intros.
  destruct n; simpl; trivial.
   apply H0. apply in_S_fv_fml; trivial.

(*exst_intro*)
 destruct IHderiv. apply intp_foterm_sort in H.
 rewrite <- subst_intp_subst_fml in H1.
 apply Exst_intro with (a:=(intp_foterm N)) (p:=x); trivial.
  replace (sort :: intp_hyp hyp) with (intp_hyp (None :: hyp)); trivial.
  apply intp_fofml_prop. apply deriv_well_typed in H0.
  unfold wf_fml, fv_fml in H0 |- *; intros.
  destruct n; simpl; trivial.
   apply H0. unfold fv_fml, subst_fml in H2 |- *.
   apply (in_fv_fml_subst _ n N 0 0); trivial.

(*exst_elim*)
 destruct IHderiv1, IHderiv2.
 rewrite <- lift_intp_lift_fml in H2. simpl in H2.
 unfold lift_fml in H0; rewrite lift_fml_split in H0.
 fold (lift_fml f1 1) in H0. fold (lift_fml (lift_fml f1 1) 1) in H0.
 apply deriv_well_typed in H0.
 do 2 apply wf_weakening in H0.
 apply Exst_elim with (t1:=x) (t2:=x0) (A:=intp_fofml f); trivial;
   [replace (sort :: intp_hyp hyp) with (intp_hyp (None :: hyp)) by trivial|];
   apply intp_fofml_prop; trivial.
  apply deriv_well_typed in H. unfold wf_fml, fv_fml in H |- *; intros.
  destruct n; simpl; trivial.
   apply H; apply in_S_fv_fml; trivial.
Qed.

Lemma SN_T : forall e x y,
  (exists hyp a b s,
    x = Sub (intp_foterm a) s /\
    y = Sub (intp_foterm b) s /\
    wf_clsd_env (intp_hyp hyp) /\
    typ_sub e s (intp_hyp hyp) /\
    deriv hyp (eq_foterm a b)) ->
  eq_typ e x y.
intros e x y Hyp.
destruct Hyp as (hyp, (a, (b, (s, (Hx, (Hy, (Hclsd, (He, Hderiv)))))))).
(*a and b are well typed in theory syntax*)
specialize deriv_well_typed with (1:=Hderiv); intro Hwf.
assert (wf_term hyp a /\ wf_term hyp b) as Hwfab.
 unfold wf_fml, fv_fml in Hwf; simpl in Hwf.
 unfold wf_term; split; intros; apply Hwf; rewrite in_app_iff; [left|right]; trivial.

destruct Hwfab as (Hwfa, Hwfb); clear Hwf.
(*Therefore they have type sort in semantic*)
apply intp_foterm_sort in Hwfa.
apply intp_foterm_sort in Hwfb.

(*EQ_term (intp_term a) (intp_term b) can be proved*)
specialize intp_sound with (1:=Hderiv); clear Hderiv; intro HEQ.
destruct HEQ as (p, HEQ); simpl in HEQ.

(*EQ_term can be embedded in eq_typ*)
apply EQ_term_elim in HEQ; [|exact Hclsd|exact Hwfa|exact Hwfb].

(*eq_typ relation maintains after variable recocation*)
subst x y.
apply typ_sub_eq_typ with (3:=He);
  [apply intp_foterm_not_kind|apply intp_foterm_not_kind|exact HEQ].
Qed.

End Abs_SN_Theory.


(* * FOL Reductions *)

From Undecidability.DiophantineConstraints Require Import H10C.
From Undecidability.DiophantineConstraints.Util Require Import H10UPC_facts.
From Undecidability.FOL Require Import Syntax.Facts Deduction.FullNDFacts Semantics.Tarski.FullSoundness Semantics.Tarski.FullFacts Syntax.BinSig.
From Undecidability.Shared Require Import Dec.
From Undecidability.Shared.Libs.PSL Require Import Numbers.
From Coq Require Import Arith Lia List.
Require Import Undecidability.Synthetic.Definitions Undecidability.Synthetic.Undecidability.

(* ** Validity *)

(*
Idea: The relation (###) has the following properties:#
#
#
#n ~ p: n is left component of p#
#
#
#p ~ n: p is right component of p#
#
#
#p ~ p: the special relationship of H10UPC#
#
#
#n ~ m: n = m. Special case n=0, m=1: #
#
          The instance h10 of H10UPC is a yes-instance. #
#
          This is to facilitate Friedman translation#
#
*)

Set Default Proof Using "Type".
Set Default Goal Selector "!".

(* Some utils for iteration *)
Section Utils.

  Lemma it_shift (X:Type) (f:X->X) v n : it f (S n) v = it f n (f v).
  Proof.
  induction n as [|n IH].
  - easy.
  - cbn. f_equal. apply IH.
  Qed.

End Utils.
(* The validity reduction.
    We assume a list h10 for which we build a formula.
 *)

Section validity.

  Context {h10 : list h10upc}.
  Existing Instance falsity_on.
  Definition Pr (t t':term) := (@atom _ sig_binary _ _ tt (Vector.cons _ t _ (Vector.cons _ t' _ (Vector.nil _)))).

  (* #$#k is a number *)
  Definition N k := Pr $k $k.
  (* #$#k is a pair *)
  Definition P' k := ¬ (N k).
  (* If #$#k is a pair ($l,$r), where $l, $r are numbers, then t. *)
  Definition P k l r:= P' k ∧ N l ∧ N r ∧ Pr $l $k ∧ Pr $k $r.
  (* The pairs #$#pl = (#$#a,#$#b), #$#pr = (#$#c,#$#d) are in relation *)
  Definition rel pl pr a b c d := P pl a b ∧ P pr c d ∧ Pr $pl $pr.
  (* There exist  pairs relating (#$#a,#$#b) to (#$#c,#$#d) *)
  Definition erel a b c d := ∃ ∃ rel 0 1 (2+a) (2+b) (2+c) (2+d).
  (* Axiom 1 - zero is a number *)
  Definition F_zero := N 0.
  (* Axiom 2 - we can build (left) successors: for each pair (a,0) we have a pair (S a, 0) *)
  Definition F_succ_left := ∀ N 0 → ∃ ∃ ∃ P 2 3 4 ∧ P 0 1 4 ∧ Pr $2 $0.
  (* Axiom 3 - we can build right successors: (x,y)###(a,b) -> (x,S y)###(S a,S (b+y)) *)
  Definition F_succ_right := ∀ ∀ ∀ ∀ ∀ ∀ ∀           (* 0 x 1 y 2 a 3 b 4 c 5 y' 6 a' 7 zero-const*)
                             erel 0 1 2 3 →         (* (x,y) # (a,b) *)
                            (erel 3 1 4 3 →         (* (b,y) # (c,b) *)
                            (erel 1 7 5 7 →       (* (y,0) # (y',0) *)
                            (erel 2 7 6 7 →       (* (a,0) # (a',0) *)
                            (erel 0 5 6 4))))     (* (x,y') # (a',c) *).
  (* Generate n all quantifiers around i *)
  Definition emplace_exists (n:nat) (i:form) := it (fun k => ∃ k) n i.

  (* Translate our formula, one relation at a time *)
  Definition translate_single (h:h10upc) (nv:nat) :=
          match h with ((a,b),(c,d)) =>
            erel a b c d end.
  (* Translate an entire instance of H10UPC, assuming a proper context *)
  Fixpoint translate_rec (t:form) (nv:nat) (l:list h10upc) :=
          match l with nil => t
                     | l::lr => translate_single l nv ∧ translate_rec t nv lr end.
  (* Actually translate the instance of H10UPC, by creating a proper context *)
  Definition translate_constraints (x:list h10upc) :=
    let nv := S (highest_var_list x)
    in (emplace_exists nv (translate_rec (¬ ⊥) (S nv) x)).

  (* The actual reduction instance. If h10 is a yes-instance of H10UPC, this formula is valid and vice-versa
      The 3 variables are the zero constant and two arbitrary values which define the atomic predicate for
      Friedman translation. *)
  Definition F := ∀ F_zero → F_succ_left → F_succ_right → translate_constraints h10.
  (* We now define our standard model. *)
  Section InverseTransport.
    (* An element of the standard model is either a number or a pair. *)
    Inductive dom : Type := Num : nat -> dom | Pair : nat  -> nat -> dom.
    (* The interpretation of our single binary relation *)
    Definition dom_rel (a : dom) (b:dom) : Prop := match (a,b) with
    | (Num n1, Num n2) => n1 = n2
    | (Num n1, Pair x2 _) => n1 = x2
    | (Pair _ y1, Num n2) => n2 = y1
    | (Pair x1 y1, Pair x2 y2) => h10upc_sem_direct ((x1, y1), (x2, y2))
    end.

    Global Instance IB : interp (dom).
    Proof using h10.
      split; intros [] v.
      exact (dom_rel (Vector.hd v) (Vector.hd (Vector.tl v))).
    Defined.

    Definition rho_canon (rho : nat -> dom) := rho 0 = Num 0.

    Lemma IB_F_zero rho : rho_canon rho -> rho ⊨ F_zero.
    Proof.
      intros H0. cbn. now rewrite !H0.
    Qed.

    Lemma IB_N_e rho i n : rho i = n -> rho ⊨ N i -> {m:nat | Num m = n}.
    Proof.
    intros Hrho H. destruct n as [m|a b].
    * now exists m.
    * exfalso. cbn in H. rewrite Hrho in H. apply (@h10_rel_irref (a,b) H).
    Qed.

    Lemma IB_N_i rho i n : rho i = Num n -> (rho) ⊨ N i.
    Proof. cbn. intros ->. now destruct n as [|n'] eqn:Heq.
    Qed.
    Opaque N.

    Lemma IB_P'_e rho i n : rho i = n -> rho ⊨ P' i -> {a:nat & {b:nat & n = Pair a b}}.
    Proof.
    intros Hrho H. destruct n as [m|a b].
    * exfalso. unfold P' in H. eapply H, IB_N_i, Hrho.
    * now exists a, b.
    Qed.

    Lemma IB_P'_i rho i a b : rho i = (Pair a b) -> rho ⊨ P' i.
    Proof.
    unfold P'. intros Hrho H. destruct (@IB_N_e rho i (Pair a b)).
    1-2:easy. congruence.
    Qed.
    Opaque P'.

    Lemma IB_P_e rho p l r ip il ir :
        rho ip = p -> rho il = l -> rho ir = r
     -> rho ⊨ P ip il ir -> {a:nat & {b:nat & p = Pair a b /\ l = Num a /\ r = Num b}}.
    Proof.
    intros Hp Hl Hr [[[[(a&b&->)%(IB_P'_e Hp) (nl&<-)%(IB_N_e Hl)] (nr&<-)%(IB_N_e Hr)] HP4] HP5].
    exists a, b; repeat split.
    - cbn in HP4. rewrite Hl,Hp in HP4. now rewrite HP4.
    - cbn in HP5. rewrite Hr,Hp in HP5. now rewrite HP5.
    Qed.

    Lemma IB_P_i rho ip il ir l r : rho ip = Pair l r -> rho il = Num l -> rho ir = Num r -> rho ⊨ P ip il ir.
    Proof.
    cbn. intros Hp Hl Hr. rewrite !Hp, !Hl, !Hr. repeat split.
    - eapply IB_P'_i. exact Hp.
    - eapply IB_N_i. exact Hl.
    - eapply IB_N_i. exact Hr.
    Qed.
    Opaque P.

    (* We show our model fulfills axiom 1 *)

    Lemma IB_F_succ_left rho : rho_canon rho -> rho ⊨ F_succ_left.
    Proof.
      intros H0. unfold F_succ_left. intros n [m Hnm]%(IB_N_e (n:=n)). 2:easy.
      exists (Pair m 0), (Num (S m)), (Pair (S m) 0). cbn. split. 2:lia. split.
      - eapply IB_P_i; cbn; try reflexivity. 1: congruence. apply H0.
      - eapply IB_P_i; cbn; try reflexivity. apply H0.
    Qed.

    (* We show we can extract constraints from our model *)

    Lemma IB_rel_e rho ipl ipr ia ib ic id : rho ⊨ rel ipl ipr ia ib ic id
                -> {a&{b&{c&{d|rho ipl=Pair a b
                            /\ rho ipr=Pair c d
                            /\ rho ia=Num a
                            /\ rho ib=Num b
                            /\ rho ic=Num c
                            /\ rho id=Num d
                            /\ h10upc_sem_direct ((a,b),(c,d))}}}}.
    Proof.
    intros [[H1 H2] H3]. eapply IB_P_e in H1, H2. 2-7: reflexivity.
    destruct H1 as (a&b&Hpl&Ha&Hb), H2 as (c&d&Hpr&Hc&Hd).
    exists a, b, c, d; repeat split; try easy.
    all: cbn in H3; rewrite Hpl, Hpr in H3; lia.
    Qed.

    Lemma IB_rel_i rho ipl ipr ia ib ic id a b c d :
               rho ipl=Pair a b
            -> rho ipr=Pair c d
            -> rho ia=Num a
            -> rho ib=Num b
            -> rho ic=Num c
            -> rho id=Num d
            -> h10upc_sem_direct ((a,b),(c,d))
            -> rho ⊨ rel ipl ipr ia ib ic id.
    Proof.
    intros Hpl Hpr Ha Hb Hc Hd Habcd. split. 1:split.
    - eapply IB_P_i; eauto.
    - eapply IB_P_i; eauto.
    - cbn. rewrite Hpl, Hpr. apply Habcd.
    Qed.
    Opaque rel.

    Lemma IB_erel_e rho ia ib ic id : rho ⊨ erel ia ib ic id
                -> exists a b c d, rho ia=Num a
                                /\ rho ib=Num b
                                /\ rho ic=Num c
                                /\ rho id=Num d
                                /\ h10upc_sem_direct ((a,b),(c,d)).
    Proof.
    intros [pl [pr H]]. eapply IB_rel_e in H. destruct H as (a&b&c&d&Hpl&Hpr&Ha&Hb&Hc&Hd&Habcd1&Habcd2).
    exists a, b, c, d; now repeat split.
    Qed.

    Lemma IB_erel_i rho ia ib ic id a b c d :
               rho ia=Num a
            -> rho ib=Num b
            -> rho ic=Num c
            -> rho id=Num d
            -> h10upc_sem_direct ((a,b),(c,d))
            -> rho ⊨ erel ia ib ic id.
    Proof.
    intros Ha Hb Hc Hd Habcd. exists (Pair c d), (Pair a b). eapply IB_rel_i. 1-2: reflexivity. all: easy.
    Qed.
    Opaque erel.

    Ltac set_eq a b := assert (a = b) as -> by congruence.

    (* We show our model fulfills axiom 2 *)

    Lemma IB_F_succ_right rho : rho_canon rho -> rho ⊨ F_succ_right.
    Proof.
      intros H0. unfold F_succ_right. intros a' y' c b a y x Hr1 Hr2 Hr3 Hr4.
      eapply IB_erel_e in Hr1, Hr2, Hr3, Hr4.
      cbn in Hr1,Hr2,Hr3,Hr4.
      destruct Hr1 as (x_1&y_1&a_1&b_1&He11&He12&He13&He14&Hr1').
      destruct Hr2 as (b_2&y_2&c_1&b_3&He21&He22&He23&He24&Hr2').
      destruct Hr3 as (y_3&v0_1&y'_1&v0_2&He31&He32&He33&He34&Hr3').
      destruct Hr4 as (a_2&v0_3&a'_1&v0_4&He41&He42&He43&He44&Hr4').
      rewrite H0 in He32,He34,He42,He44.
      set_eq v0_1 0. set_eq v0_2 0. set_eq v0_3 0. set_eq v0_4 0.
      set_eq a_2 a_1. set_eq b_2 b_1. set_eq b_3 b_1. set_eq y_2 y_1. set_eq y_3 y_1.
      eapply IB_erel_i; cbn. 1-4:eauto. lia.
    Qed.

    (* We show we can encode constraints into our model *)

    (* rho_descr_phi describes that rho is defined by the solution to h10 *)
    Definition rho_descr_phi rho (φ:nat->nat) n :=
         forall k, k < n -> match rho k with Num n => n = (φ k) | _ => True end.
    Lemma IB_single_constr rho φ (n:nat) (h:h10upc) : rho_descr_phi rho φ n
                                           -> highest_var h < n
                                           -> rho ⊨ translate_single h (S n)
                                           -> h10upc_sem φ h.
    Proof.
      intros Hrhophi Hmaxhall.
      destruct h as [[a b][c d]]. unfold translate_single. cbn in Hmaxhall.
      intros (na&nb&nc&nd&Ha&Hb&Hc&Hd&Habcd)%IB_erel_e.
      unfold h10upc_sem.
      pose proof (Hrhophi a (ltac:(lia))) as Hpa. rewrite Ha in Hpa.
      pose proof (Hrhophi b (ltac:(lia))) as Hpb. rewrite Hb in Hpb.
      pose proof (Hrhophi c (ltac:(lia))) as Hpc. rewrite Hc in Hpc.
      pose proof (Hrhophi d (ltac:(lia))) as Hpd. rewrite Hd in Hpd.
      now rewrite <- Hpa, <- Hpb, <- Hpc, <- Hpd.
    Qed.
    (* Helper for working with nested quantifiers *)

    Lemma IB_emplace_exists rho n i :
        rho ⊨ emplace_exists n i
        -> (exists f, (fun k => if k <? n then f (k) else rho (k-n)) ⊨ i).
    Proof.
      unfold emplace_exists. intros H.
      induction n as [|n IH] in rho,H|-*.
      - cbn. exists (fun _ => Num 0). eapply (sat_ext IB (rho:=rho) (xi:=fun k => rho(k-0))).
        2: easy.
        intros x. now rewrite Nat.sub_0_r.
      - cbn in H. destruct H as (d&Hd).
        specialize (IH (d.:rho) Hd). destruct IH as [f Hf].
        exists (fun kk => if kk =? n then d else f kk).
        eapply (sat_ext IB (xi:=fun k => if k <? n then f k else (d .: rho) (k - n))).
        2: easy.
        intros x.
        destruct (Nat.eq_dec x n) as [Hxn|Hnxn].
        + destruct (Nat.ltb_ge x n) as [_ Hlt]. rewrite Hlt. 2:lia. clear Hlt.
          destruct (Nat.ltb_lt x (S n)) as [_ Hlt]. rewrite Hlt. 2:lia. clear Hlt. cbn.
          assert (x-n=0) as ->. 1: lia. cbn. destruct (Nat.eqb_eq x n) as [_ HH]. now rewrite HH.
        + destruct (x <? n) eqn:Hneq.
          * destruct (Nat.ltb_lt x n) as [Hlt _]. apply Hlt in Hneq. clear Hlt.
            destruct (Nat.ltb_lt x (S n)) as [_ Hlt]. rewrite Hlt. 2:lia. clear Hlt.
            cbn. destruct (Nat.eqb_neq x n) as [_ HH]. rewrite HH. 1: easy. lia.
          * destruct (Nat.ltb_ge x n) as [Hlt _]. apply Hlt in Hneq. clear Hlt.
            destruct (Nat.ltb_ge x (S n)) as [_ Hlt]. rewrite Hlt. 2:lia. clear Hlt.
            assert (x-n=S(x-S n)) as ->. 1:lia. easy.
    Qed.
    Opaque emplace_exists.

    (* Final utility lemma: translate the entire list of constraints *)
    Lemma IB_translate_rec rho phi f e hv : rho_descr_phi rho phi hv
                            -> highest_var_list e < hv
                            -> rho ⊨ translate_rec f (S hv) e
                            -> (forall c, In c e -> h10upc_sem phi c) /\ rho ⊨ f.
    Proof.
    intros Hrhophi Hhv H.
    induction e as [|eh er IH] in H,Hhv|-*.
    - split. 1: intros c []. easy.
    - cbn. cbn in H, Hhv. destruct IH as [IH1 IH2]. 1:lia. 1:apply H.
      split. 2:easy. intros c [->|Her].
      + eapply (IB_single_constr Hrhophi). 1:lia. apply H.
      + now apply IH1.
    Qed.
    (* We can now extract the constraints from our translate_constraints function*)

    Lemma IB_aux_transport rho : rho 0 = Num 0
                              -> rho ⊨ translate_constraints h10
                              -> H10UPC_SAT h10.
    Proof.
      intros Hrho0.
      pose ((S (highest_var_list h10))) as h10vars.
      unfold translate_constraints. fold h10vars. intros H.
      apply IB_emplace_exists in H. destruct H as [f Hf].
      pose (fun n => match (f n) with (Num k) => k | _ => 0 end) as phi.
      exists phi.
      unshelve eapply (IB_translate_rec (e:=h10) (hv:=h10vars) (phi:= phi) _ _ Hf).
      - intros x HH. destruct (Nat.ltb_lt x h10vars) as [_ Hr]. rewrite Hr. 2:easy.
        unfold phi. now destruct (f x).
      - lia.
    Qed.

    (* To conclude, we can wrap the axioms around it.*)
    Lemma IB_fulfills rho : rho ⊨ F -> H10UPC_SAT h10.
    Proof.
      intros H. unfold F in H. pose (Num 0 .: rho) as nrho.
      assert (rho_canon nrho) as nrho_canon.
      1: split; easy.
      apply (@IB_aux_transport nrho), H; fold sat.
      - easy.
      - now apply IB_F_zero.
      - now apply IB_F_succ_left.
      - now apply IB_F_succ_right.
    Qed.
  End InverseTransport.

  (* If F is valid, h10 has a solution: *)
  Lemma inverseTransport : valid F -> H10UPC_SAT h10.
  Proof.
    intros H. apply (@IB_fulfills (fun b => Num 0)). apply H.
  Qed.

  Section Transport.
    Context (D:Type).
    Context (I:interp D).
    Existing Instance I.

    Definition iPr (d1 d2 : D) : Prop := (@i_atom _ sig_binary _ _ tt (Vector.cons _ d1 _ (Vector.cons _ d2 _ (Vector.nil _)))).
    Lemma iPr_spec rho' t t' d1 d2 : rho' t = d1 -> rho' t' = d2 -> rho' ⊨ Pr $t $t' <-> iPr d1 d2.
    Proof. cbn. intros -> ->. easy. Qed.

    Definition iN d := iPr d d.
    Lemma iN_spec rho' t d : rho' t = d -> rho' ⊨ N t <-> iN d.
    Proof. unfold N,iN. intros H. now rewrite iPr_spec. Qed.

    Definition iP' d := ~ (iN d).
    Lemma iP'_spec rho' t d : rho' t = d -> rho' ⊨ P' t <-> iP' d.
    Proof. unfold P',iP'. intros H. cbn [sat]. unfold not. erewrite iN_spec. 1:easy. easy. Qed.

    Definition iP k l r:= (((iP' k /\ iN l) /\ iN r) /\ iPr l k) /\ iPr k r.
    Lemma iP_spec rho' k l r dk dl dr : rho' k = dk -> rho' l = dl -> rho' r = dr -> rho' ⊨ P k l r <-> iP dk dl dr.
    Proof. intros H1 H2 H3. unfold P,iP. erewrite <- !iPr_spec, <- !iN_spec, <- iP'_spec. 1:cbn;reflexivity. all:easy. Qed.

    Definition ierel a b c d := exists d1 d0, (iP d0 a b /\ iP d1 c d) /\ iPr d0 d1.
    Lemma ierel_spec rho' a b c d da db dc dd : rho' a = da -> rho' b = db -> rho' c = dc -> rho' d = dd -> rho' ⊨ erel a b c d <-> ierel da db dc dd.
    Proof. intros H1 H2 H3 H4. unfold erel,rel,ierel. split.
    - intros [d1 [d0 H]]. exists d1,d0. rewrite <- !iPr_spec, <- !iP_spec. 1:apply H. all:easy.
    - intros [d1 [d0 H]]. exists d1,d0. rewrite <- !iPr_spec, <- !iP_spec in H. 1:apply H. all:easy.
    Qed.
    Lemma ierel_spec' rho' a b c d : rho' ⊨ erel a b c d <-> ierel (rho' a) (rho' b) (rho' c) (rho' d).
    Proof. now apply ierel_spec. Qed.

    Section withAxioms.
      Context (rho:env D).
      Context (φ:nat->nat).
      Context (Hφ : forall c, In c h10 -> h10upc_sem φ c).
      Context (HA1 : rho ⊨ F_zero).
      Context (HA2 : rho ⊨ F_succ_left).
      Context (HA3 : rho ⊨ F_succ_right).

      Record chain (n:nat) := {
        f :> nat -> D;
        chain_zero : f 0 = rho 0;
        chain_succ : forall m, m < n -> ierel (f m) (f 0) (f (S m)) (f 0)
      }.

      Lemma chain_N n (c:chain n) m : m <= n -> iN (c m).
      Proof using HA1.
      intros Hm. destruct m.
      - rewrite (chain_zero c). apply HA1.
      - destruct (chain_succ c Hm) as [d1 [d0 [[_ H] _]]]. unfold iP in H. apply H.
      Qed.

      Lemma chain_build n : inhabited (chain n).
      Proof using HA1 HA2.
      induction n as [|n [c]].
      - apply inhabits. split with (fun _ => rho 0).
        + easy.
        + intros m H. exfalso; lia.
      - cbn -[N P Pr] in HA2.
        destruct (@HA2 (c n)) as [pl [d [pr [[H1 H2] H3]]]].
        1: { rewrite ! iN_spec. 2:cbn; reflexivity. apply chain_N. easy. }
        rewrite !iP_spec in H1,H2. 1:rewrite !iPr_spec in H3. 2-9: cbn; easy.
        apply inhabits. pose (fun m => if m =? S n then d else c m) as f. split with f.
        + unfold f. destruct (Nat.eqb_neq 0 (S n)) as [_ ->]. 2:lia. apply chain_zero.
        + unfold f. destruct (Nat.eqb_neq 0 (S n)) as [_ ->]. 2:lia.
          intros m Hm. destruct (Nat.eqb_neq m (S n)) as [_ ->]. 2:lia.
          destruct (S m=?S n) eqn:Heq.
          * apply beq_nat_true in Heq. assert (m=n) as -> by lia. exists pr, pl. rewrite chain_zero. split. 1:split. all:easy.
          * apply chain_succ. apply beq_nat_false in Heq. lia.
      Qed.

      Ltac h10ind_not_lt_0 := match goal with [H : h10upc_ind ?k 0 0 0 |- _] => exfalso; now apply (@h10upc_ind_not_less_0 k H) end.

      Lemma chain_proves a b c d n (f:chain n) :
               h10upc_sem_direct ((a,b),(c,d))
            -> a < n -> b < n -> c < n -> d < n
            -> ierel (f a) (f b) (f c) (f d).
      Proof using HA3.
      rewrite h10_equiv.
      intros k; remember k as Habcd eqn:Heq; clear Heq; revert k.
      induction 1 as [a|a b c d b' c' d' H1 IH1 H2 IH2 H3 IH3 H4 IH4]; intros Ha Hb Hc Hd.
      - apply chain_succ. easy.
      - cbn -[erel] in HA3. specialize (@HA3 (f c) (f b) (f d) (f d') (f c') (f b') (f a)).
        rewrite !ierel_spec' in HA3. cbn in HA3.
        rewrite !chain_zero in *.
        assert (0 < n) as H0n by lia.
        assert (b' < n) as Hbn by (inversion H3; [lia | h10ind_not_lt_0]).
        assert (c' < n) as Hcn by (inversion H4; [lia | h10ind_not_lt_0]).
        assert (d' < n) as Hdn by (rewrite <- h10_equiv in H2; cbn in H2; lia).
        apply HA3; eauto.
      Qed.

      Definition rho_descr_chain rho phi n (c:chain n) hv :=
         forall k, k < hv -> rho k = c (phi k).

      Lemma translate_rec_correct hv hn (cc:chain hn) (h:list h10upc) phi f rho' :
               rho' ⊨ f
            -> (forall k, In k h -> h10upc_sem phi k)
            -> highest_var_list h < hv
            -> highest_num phi hv < hn
            -> rho_descr_chain rho' phi cc hv
            -> rho' ⊨ translate_rec f (S hv) h.
      Proof using D HA3 I rho.
      intros Hf Hsat Hhv Hhn Hc. induction h as [|[[a b][c d]] hr IH] in Hhv,Hsat|-*.
      - cbn. easy.
      - cbn -[erel]. cbn in Hhv. split.
        + rewrite ierel_spec. 2-5:rewrite Hc; [easy|lia].
          apply chain_proves. 1: eapply (Hsat ((a,b),(c,d))); now left.
          all: match goal with |- ?phi ?a < ?hn => enough (phi a <= highest_num phi hv) by lia end.
          all: apply highest_num_descr. all:lia.
        + apply IH.
          * intros x Hx. apply Hsat. now right.
          * lia.
      Qed.

      Lemma emplace_exists_spec rho' n i :
        (exists f, (fun k => if k <? n then f (k) else rho' (k-n)) ⊨ i)
        -> rho' ⊨ emplace_exists n i.
      Proof.
      intros [f Hf]. unfold emplace_exists.
      induction n as [|n IH] in rho',f,Hf|-*.
      - cbn. eapply sat_ext. 2:exact Hf. intros x. cbn. now rewrite Nat.sub_0_r.
      - cbn. exists (f n). eapply sat_ext. 2:apply (IH (f n .: rho') f).
        + intros x. easy.
        + eapply sat_ext. 2:apply Hf. intros x. cbv beta.
          destruct (x <? n) eqn:Heq, (x <? S n) eqn:HSeq.
          * easy.
          * exfalso. rewrite Nat.ltb_lt in Heq. rewrite Nat.ltb_ge in HSeq. lia.
          * rewrite Nat.ltb_ge in Heq. rewrite Nat.ltb_lt in HSeq. assert (x = n) as -> by lia. rewrite Nat.sub_diag. easy.
          * rewrite Nat.ltb_ge in Heq. rewrite Nat.ltb_ge in HSeq. assert (x-n=S(x-S n)) as -> by lia. cbn. easy.
      Qed.

      Lemma translate_constraints_correct :
            rho ⊨ translate_constraints (h10).
      Proof using D HA1 HA2 HA3 Hφ I h10 rho φ.
      unfold translate_constraints.
      pose (S(highest_var_list h10)) as hv. fold hv.
      pose (S(highest_num φ hv)) as hn.
      destruct (chain_build hn) as [c].
      apply emplace_exists_spec.
      exists (φ >> c).
      eapply (@translate_rec_correct hv hn c _  φ _ _).
      - cbn. easy.
      - exact Hφ.
      - unfold hv. lia.
      - unfold hn. lia.
      - intros m Hm. destruct (m <? hv) eqn:Heq.
        + easy.
        + apply Nat.ltb_ge in Heq. lia.
      Qed.
    End withAxioms.
    (* To conclude, we can wrap the axioms around it.*)
    Lemma F_correct rho : H10UPC_SAT h10 -> rho ⊨ F.
    Proof.
      intros [φ Hφ] z HA1 HA2 HA3. eapply translate_constraints_correct.
      - exact Hφ.
      - exact HA1.
      - exact HA2.
      - exact HA3.
    Qed.
  End Transport.

  (* If h10 has a solution, F is valid: *)
  Lemma transport : H10UPC_SAT h10 -> valid F.
  Proof.
    intros H M I rho. now apply F_correct.
  Qed.

  (* sat things *)
  Lemma sat1 : (complement satis (¬ F)) -> complement (complement H10UPC_SAT) h10.
  Proof.
    intros Hc1 Hc2. apply Hc1. exists dom, IB, (fun b => Num 0). intros H.
    apply Hc2. eapply IB_fulfills. exact H.
  Qed.
  Lemma sat2 : complement (complement H10UPC_SAT) h10 -> (complement satis (¬ F)).
  Proof.
    intros Hc1 [D [I [rho H]]]. apply Hc1. intros Hh10.
    apply H. fold sat. eapply F_correct. exact Hh10.
  Qed.

  (* sat things 2 *)
  Lemma sat3 : (complement (complement satis) (¬ F)) -> complement H10UPC_SAT h10.
  Proof.
    intros Hc1 Hc2. apply Hc1.
    intros [D [I [rho H]]]. apply H. fold sat.
    apply F_correct. easy.
  Qed.
  Lemma sat4 : complement H10UPC_SAT h10 -> (complement (complement satis) (¬ F)).
  Proof.
    intros Hc1 Hc2. apply Hc2. exists dom, IB, (fun b => Num 0). intros H.
    apply Hc1. eapply IB_fulfills. exact H.
  Qed.

  (* sat things 3 *)
  Lemma sat5 : satis (¬ F) -> complement H10UPC_SAT h10.
  Proof.
    intros [D [I [rho H]]] Hc. apply H. fold sat.
    apply F_correct. easy.
  Qed.
  Lemma sat6 : complement H10UPC_SAT h10 -> satis (¬ F).
  Proof.
    intros Hc1. exists dom, IB, (fun b => Num 0). intros H.
    apply Hc1. eapply IB_fulfills. exact H.
  Qed.

End validity.

Lemma fullFragValidReduction : H10UPC_SAT ⪯ (valid (ff := falsity_on)).
Proof.
exists @F. split.
- apply transport.
- apply inverseTransport.
Qed.

Lemma fullFragSatisReduction : complement H10UPC_SAT ⪯ (satis (ff := falsity_on)).
Proof.
exists (fun k => ¬ (@F k)). split.
- intros H. eapply sat6. easy.
- intros H. eapply sat5. easy.
Qed.


(* HTTcc vol 2.0 : now with High Order State *)

(*******************************************************************************
** A toy implementation of HTTcc using Coq 8.5 Universe Polymorphism
** support:
**
** This looks promising!
**
** References: software.imdea.org/~germand/HTTcc
**
*******************************************************************************)

Set Universe Polymorphism.
Set Printing All.

(*
** Some toy state: until we get full ssreflect support and can
** re-implement HTT's heaps
*)

Parameter state : Type -> Type.
(* Some algebra over  state *)

Parameter write: forall W,  W -> state W -> state W.
Parameter read: forall  W, state W -> W.

Axiom read_write : forall W h w,  read W (write W w h) = w.

Axiom write_write : forall W h w v,
                      write W w (write W w h) = write W v (write W w h).

Axiom write_read: forall W h, write W (read W h) h = h.

Parameter safe: forall W, state W -> Prop.

Definition pre W := state W -> Prop.
Definition post W X := X -> state W -> state W -> Prop.
Definition spec W A := (pre W * post W A)%type.

(* A polymorphic HTT + State + Continuation monad *)

Polymorphic
Definition SK {A X W: Type}
            (s : spec W A) : Type :=
  forall i: state W, (fst s) i ->
                  (forall x m, (snd s) x i m -> X) -> X.

Inductive SigSK {A X W : Type } :=
  BigSK {spec_of: spec W A;
         comm: @SK A X W spec_of}.

Polymorphic
Definition Kont {A X W: Type}  (s : spec W A) : Type :=
    forall k,
      @SK A X W  (fun i => (fst s) i /\ i = k, snd s) -> (fst s) k ->  X.

Arguments Kont {A} X {W} s.
Arguments SigSK A {X W}.
Arguments SK {A} X {W} s.
Arguments BigSK {A X W spec_of} _.

Definition verify {A W} (i: state W) (s : spec W A)
           (r : A -> state W -> Prop) :=
  (fst s) i /\ forall y m, (snd s) y i m -> r y m.

Definition conseq {A W} (s: spec W A) ( p : pre W) (q : post W A) :=
  forall i, p i -> verify i s (fun y m => q y i m).

Local Notation conseq' :=
  (fun W A (s1 s2 : spec W A) =>
     conseq s1 (let (x, _) := s2 in x)
               (let (_, x) := s2 in x)).

Section Ret.
Variables (X W R :Type) (x:X).

Definition ret_s  : spec W X :=
  (fun _ => True, fun r i m => i = m /\ r = x).

Lemma retQ_refl: forall s,  (snd ret_s) x s s.
Proof. intro; unfold ret_s; simpl; auto. Qed.

Polymorphic
Definition ret : SK R ret_s :=
  fun s p k => @k x s (retQ_refl s).

End Ret.
Arguments ret {X} W R x i _ _.

Section Bind.
Variables (A B W R: Type).
Variables (s1: spec W A).
Variables (s2 : A -> spec W B).
Variables (e1 : SK R s1) (e2 : forall x, SK R (s2 x)).

Definition bind_pre : pre W :=
  fun i =>
     (fst s1) i /\ forall x m, (snd s1) x i m -> (fst (s2 x)) m.

Definition bind_post : post W B :=
   fun y i m => exists x, exists h,
     (snd s1) x i h /\ (snd (s2 x)) y h m.

Definition bind_s :spec W B := (bind_pre, bind_post).

Lemma bindP1 h : bind_pre h -> (fst s1) h.
Proof. intro H; case H; auto. Qed.

Lemma bindP2 i x h : bind_pre i -> (snd s1) x i h -> (fst (s2 x)) h.
Proof. intros P Q; destruct P; apply H0; auto. Qed.

Lemma bindQ i x h y m :
        (snd s1) x i h -> (snd (s2 x)) y h m -> bind_post y i m.
Proof. intros; exists x; exists h; auto. Qed.

Definition bind : SK R bind_s :=
 fun i pf1 k =>
          e1 i (bindP1 i pf1)
           (fun x h p2 => (e2 x) h (bindP2 i x h pf1 p2)
           (fun y m p3 => k y m (bindQ i x h y m p2 p3))).
End Bind.
Arguments bind {A B W R s1 s2} e1 e2 _ _ _ .

Section Store.
Variables (X R :Type) (x:X).

Definition write_s : spec X unit :=
  (fun i => safe X i,
            fun r i m => m = write X x i /\ r = tt).

Lemma writeQ s:  (snd write_s) tt s (write X x s).
Proof. unfold write_s; simpl;auto. Qed.

Polymorphic
Definition store : SK R write_s  :=
  fun s p k => k tt (write X x s) (writeQ s).
End Store.
Arguments store {X} R x _ _ _.

Section Fetch.
Variables (X R :Type).

Definition read_P : pre X := fun i => exists v j,
                                        i = write X v j.
Definition read_Q  : post X X :=
  fun r i m =>  forall v j, i = write X v j ->
                  m = i /\ r = v.

Definition read_s := (read_P, read_Q).

Lemma fetchQ s :  read_Q (read X s) s s.
Proof. intros v j H; split ;[|rewrite H ;rewrite (read_write X j)]; auto. Qed.

Polymorphic
Definition fetch : SK R read_s :=
  fun s p k => k (read X s) s (fetchQ s).
End Fetch.
Arguments fetch {X R} _ _ _.

Section Consequence.
Variables (A W R: Type) (s1 s2: spec W A).
Variables (e1 : SK R s1)  (pf : conseq' W A s1 s2).

Lemma doP i : (fst s2) i -> (fst s1) i.
Proof. simpl; intro; case (pf i H); auto. Qed.

Lemma doQ i :
       (fst s2) i -> (forall y m, (snd s2) y i m ->  R) ->  R.
Proof.
intros P2 K.
case (pf i P2).
intros P1 H1.
apply (e1 i P1).
intros x m Q1.
exact (K x m (H1 x m Q1)).
Qed.

Polymorphic
Definition Do : SK R s2 :=  doQ.

End Consequence.

Arguments Do {A W R s1 s2} e1 pf _ _ _.

(* Some examples *)

Polymorphic
Definition rr1 {A: Type}
  := ret A nat (ret A nat 5).

Polymorphic
Definition st1 {A B : Type}
            := store A (ret B unit 5).

Polymorphic
Definition  br1 {X: Type}
  := bind (store X 4)
          (fun _ => bind fetch (ret _ _ )).

Polymorphic Definition id {A : Type} (a : A) := a.

(* I can Join rets *)

Definition brr1 {A: Type} := bind (@rr1 A) id.

(* However, I have to explicitly mention the state type here *)

(* I can store a program and then read it *)
Polymorphic
Definition bsf {A B: Type} := bind (@st1 A B) (fun _ => fetch).

(*
** Can I flatten it straight away?
**    join : SK (SK A) -> SK A := fun m => bind m id
**
*)

Fail Polymorphic
Definition bsf' :=
    bind bsf id.

(*
** Well, I guess that I  would still need
**   Sigma types for pulling something like this.
** Or a  proper join.
*)

Polymorphic
Definition stC1 {X: Type}
            := store X (BigSK (@br1 X)).

Polymorphic
Definition stC2 {X: Type}
            :=  bind (@stC1 X) (fun _ => fetch).

Fail
Polymorphic
Definition stC3 {X : Type}
            :=  bind (@stC2 X) (fun p => (comm p)).

(*
The command has indeed failed with message:
=> Error:
In environment
X : Type
p : @SigSK nat X nat
The term "@comm nat X nat p" has type "@SK nat X nat (@spec_of nat X nat p)"
while it is expected to have type "@SK ?112 X (@SigSK nat X nat) (?116 p)"
(cannot unify "state (@SigSK nat X nat)" and "state nat").
*)


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Export Fiat.QueryStructure.Implementation.DataStructures.Bags.BagsInterface
               Fiat.QueryStructure.Implementation.DataStructures.Bags.BagsProperties.

Unset Implicit Arguments.

Section IBagSpecs.

  Context {TBag TIndex TItem TSearchTerm : Type}.

  Definition TMap := TIndex -> option TItem.

  Definition ib_RepInv_fact
             (RepInv : TMap -> TBag -> Prop)
             (ibenumerate : TBag -> list TIndex) :=
    forall bag imap imap',
      (forall idx, List.In idx (ibenumerate bag) -> imap idx = imap' idx) ->
      (RepInv imap bag -> RepInv imap' bag).

  Definition ibempty_Preserves_RepInv
             (RepInv  : TMap -> TBag -> Prop)
             (ibempty : TBag) :=
    forall imap, RepInv imap ibempty.

  Definition ibinsert_Preserves_RepInv
             (RepInv   : TMap -> TBag -> Prop)
             (ibinsert : TBag -> TIndex -> TBag) :=
    forall bag imap idx, RepInv imap bag -> RepInv imap (ibinsert bag idx).

  Definition ibdelete_Preserves_RepInv
             (RepInv   : TMap -> TBag -> Prop)
             (ibdelete : TBag -> TSearchTerm -> list TIndex * TBag) :=
    forall bag imap searchterm, RepInv imap bag -> RepInv imap (snd (ibdelete bag searchterm)).

  Definition IBagEnumerateEmpty
             (ibempty     : TBag)
             (ibenumerate : TBag -> list TIndex) :=
    forall idx, ~ List.In idx (ibenumerate ibempty).

  Definition IBagInsertEnumerate
             (RepInv      : TMap -> TBag -> Prop)
             (ibenumerate : TBag -> list TIndex)
             (ibinsert    : TBag -> TIndex -> TBag) :=
    forall bag imap idx,
      RepInv imap bag ->
      Permutation (ibenumerate (ibinsert bag idx)) (idx :: ibenumerate bag).

  Definition IBagCountCorrect
             (RepInv  : TMap -> TBag -> Prop)
             (ibfind  : TBag -> TSearchTerm -> list TIndex)
             (ibcount : TBag -> TSearchTerm -> nat) :=
    forall bag imap searchterm,
      RepInv imap bag ->
      List.length (ibfind bag searchterm) = ibcount bag searchterm.

  Definition IBagMatcher
             (Matcher    : TSearchTerm -> TItem -> bool)
             (imap       : TIndex -> option TItem)
             (searchterm : TSearchTerm)
             (idx        : TIndex) :=
    match imap idx with
    | None      => false
    | Some item => Matcher searchterm item
    end.

  Definition IBagFindCorrect
             (RepInv      : TMap -> TBag -> Prop)
             (Matcher     : TSearchTerm -> TItem -> bool)
             (ibenumerate : TBag -> list TIndex)
             (ibfind      : TBag -> TSearchTerm -> list TIndex) :=
    forall bag imap searchterm,
      RepInv imap bag ->
      Permutation (ibfind bag searchterm)
                  (List.filter (IBagMatcher Matcher imap searchterm) (ibenumerate bag)).

  Definition IBagDeleteCorrect
             (RepInv      : TMap -> TBag -> Prop)
             (Matcher     : TSearchTerm -> TItem -> bool)
             (ibenumerate : TBag -> list TIndex)
             (ibdelete    : TBag -> TSearchTerm -> list TIndex * TBag) :=
    forall bag imap searchterm,
      RepInv imap bag ->
      Permutation (ibenumerate (snd (ibdelete bag searchterm)))
                  (snd (List.partition (IBagMatcher Matcher imap searchterm)
                                       (ibenumerate bag))) /\
      Permutation (fst (ibdelete bag searchterm))
                  (fst (List.partition (IBagMatcher Matcher imap searchterm)
                                       (ibenumerate bag))).

End IBagSpecs.

Class IBag (TBag TIndex TSearchTerm : Type) :=
  { ibempty     : TBag;
    ibenumerate : TBag -> list TIndex;
    ibfind      : TBag -> TSearchTerm -> list TIndex;
    ibinsert    : TBag -> TIndex -> TBag;
    ibcount     : TBag -> TSearchTerm -> nat;
    ibdelete    : TBag -> TSearchTerm -> list TIndex * TBag }.

Class IBagCorrect (TBag TIndex TItem TSearchTerm : Type)
      (RepInv  : (TIndex -> option TItem) -> TBag -> Prop)
      (Matcher : TSearchTerm -> TItem -> bool)
      (IBagImplementation : IBag TBag TIndex TSearchTerm) :=
  { ib_RepInv          : ib_RepInv_fact RepInv ibenumerate;
    ibempty_RepInv     : ibempty_Preserves_RepInv RepInv ibempty;
    ibinsert_RepInv    : ibinsert_Preserves_RepInv RepInv ibinsert;
    ibdelete_RepInv    : ibdelete_Preserves_RepInv RepInv ibdelete;

    ibenumerate_empty  : IBagEnumerateEmpty ibempty ibenumerate;
    ibinsert_enumerate : IBagInsertEnumerate RepInv ibenumerate ibinsert;
    ibcount_correct    : IBagCountCorrect RepInv ibfind ibcount;
    ibfind_correct     : IBagFindCorrect RepInv Matcher ibenumerate ibfind;
    ibdelete_correct   : IBagDeleteCorrect RepInv Matcher ibenumerate ibdelete }.

Class IPool (TPool TIndex TItem : Type) :=
  { pempty : TPool;
    pget   : TPool -> TIndex -> option TItem;
    pput   : TPool -> TIndex -> option TItem -> TPool;
    pfresh : TPool -> TIndex }.

Class IPoolCorrect (TPool TIndex TItem : Type)
      (PoolImplementation : IPool TPool TIndex TItem) :=
  { pempty_correct : forall idx, pget pempty idx = None;
    pput_eq        : forall pool idx item, pget (pput pool idx item) idx = item;
    pput_neq       : forall pool idx idx' item, idx <> idx' ->
                                                pget (pput pool idx item) idx' = pget pool idx';
    pfresh_correct : forall pool, pget pool (pfresh pool) = None }.

Module NatIPool.

  Context {TItem : Type}.

  Require Import
          Coq.FSets.FMapInterface
          Coq.FSets.FMapFacts
          Coq.FSets.FMapAVL
          Coq.Structures.OrderedTypeEx.

  Module Import XMap := FMapAVL.Make Nat_as_OT.
  Module Import XMapFacts := WFacts_fun Nat_as_OT XMap.

  Definition TPool := { ds : (t TItem * nat) |
                        forall idx t, MapsTo idx t (fst ds) -> idx < snd ds }.

  Definition NatIPool_pempty : TPool.
    refine (exist _ (empty TItem, O) _).
    intros idx t. rewrite empty_mapsto_iff. tauto.
  Defined.

  Definition NatIPool_pget (pool : TPool) (idx : nat) :=
    find idx (fst (proj1_sig pool)).

  Definition NatIPool_pput : TPool -> nat -> option TItem -> TPool.
    intros [ [m n] pf].
    refine (fun idx t =>
              match t with
              | None   => exist _ (remove idx m, n) _
              | Some t'=> exist _ (add idx t' m, max n (S idx)) _
              end); simpl in *; intuition.
    - destruct (Peano_dec.eq_nat_dec idx idx0); subst.
      apply NPeano.Nat.max_lt_iff. right. auto with arith.
      apply NPeano.Nat.max_lt_iff. left. eapply pf. eapply add_3. eauto. eauto.
    - eapply pf; eapply remove_3; eauto.
  Defined.

  Definition NatIPool_pfresh (pool : TPool) :=
    snd (proj1_sig pool).

  Lemma NatIPool_pempty_correct :
    forall idx, NatIPool_pget NatIPool_pempty idx = None.
  Proof.
    apply empty_o.
  Qed.

  Lemma NatIPool_pput_eq :
    forall pool idx item, NatIPool_pget (NatIPool_pput pool idx item) idx = item.
  Proof.
    unfold NatIPool_pget, NatIPool_pput.
    intros [ [m n] pf] idx item; destruct item eqn: eq; simpl; subst.
    - eapply add_eq_o; eauto.
    - eapply remove_eq_o; eauto.
  Qed.

  Lemma NatIPool_pput_neq :
    forall pool idx idx' item,
      idx <> idx' ->
      NatIPool_pget (NatIPool_pput pool idx item) idx' = NatIPool_pget pool idx'.
  Proof.
    unfold NatIPool_pget, NatIPool_pput.
    intros [ [m n] pf] idx idx' item; destruct item eqn: eq; simpl; subst; intros.
    - eapply add_neq_o; eauto.
    - eapply remove_neq_o; eauto.
  Qed.

  Lemma NatIPool_pfresh_correct :
    forall pool, NatIPool_pget pool (NatIPool_pfresh pool) = None.
  Proof.
    unfold NatIPool_pget, NatIPool_pfresh; intros [ [m n] pf]; simpl.
    destruct (find (elt:=TItem) n m) eqn: eq; eauto.
    apply find_2 in eq. apply pf in eq. simpl in eq. omega.
  Qed.

  Global Instance NatIPoolAsIPool
    : IPool TPool nat TItem :=
    {| pempty := NatIPool_pempty;
       pget   := NatIPool_pget;
       pput   := NatIPool_pput;
       pfresh := NatIPool_pfresh |}.

  Global Instance NatIPoolAsCorrectIPool
    : IPoolCorrect TPool nat TItem NatIPoolAsIPool :=
    {| pempty_correct := NatIPool_pempty_correct;
       pput_eq        := NatIPool_pput_eq;
       pput_neq       := NatIPool_pput_neq;
       pfresh_correct := NatIPool_pfresh_correct |}.

End NatIPool.

Section IndexedBag.

  Context {TBag TPool TIndex TItem TSearchTerm TUpdateTerm : Type}
          (TIndex_dec : forall idx idx' : TIndex, {idx = idx'} + {idx <> idx'})

          (RepInv : (TIndex -> option TItem) -> TBag -> Prop)
          (Matcher : TSearchTerm -> TItem -> bool)
          (Transform : TUpdateTerm -> TItem -> TItem)

          (IBagImpl : IBag TBag TIndex TSearchTerm)
          (IBagProof : IBagCorrect TBag TIndex TItem TSearchTerm RepInv Matcher IBagImpl)

          (IPoolImpl : IPool TPool TIndex TItem)
          (IPoolProof : IPoolCorrect TPool TIndex TItem IPoolImpl).

  Definition TIndexedBag := prod TBag TPool.

  Definition IndexedBag_bempty := (ibempty, pempty).

  Definition IndexesToItems
             (idxs : list TIndex)
             (pool : TPool) :=
    List.fold_right (fun idx ls => match pget pool idx with
                                   | None      => ls
                                   | Some item => cons item ls
                                   end) nil idxs.

  Definition IndexedBag_benumerate
             (bag : TIndexedBag) :=
    IndexesToItems (ibenumerate (fst bag)) (snd bag).

  Definition IndexedBag_bfind
             (bag : TIndexedBag)
             (searchterm : TSearchTerm) :=
    IndexesToItems (ibfind (fst bag) searchterm) (snd bag).

  Definition IndexedBag_binsert
             (bag : TIndexedBag)
             (item : TItem) :=
    let fresh := pfresh (snd bag) in
    (ibinsert (fst bag) fresh, pput (snd bag) fresh (Some item)).

  Definition IndexedBag_bcount
             (bag : TIndexedBag)
             (searchterm : TSearchTerm) :=
    ibcount (fst bag) searchterm.

  Definition IndexedBag_bdelete
             (bag : TIndexedBag)
             (searchterm : TSearchTerm) :=
    let (deleted, ibag) := ibdelete (fst bag) searchterm in
    (IndexesToItems deleted (snd bag),
     (ibag, List.fold_right (fun idx p => pput p idx None) (snd bag) deleted)).

  Definition IndexedBag_bupdate
             (bag : TIndexedBag)
             (searchterm : TSearchTerm)
             (updateterm : TUpdateTerm) :=
    let matched := ibfind (fst bag) searchterm in
    (IndexesToItems matched (snd bag),
     (fst bag, List.fold_right
                 (fun idx p => match pget p idx with
                               | None      => p
                               | Some item => pput p idx (Some (Transform updateterm item))
                               end) (snd bag) matched)).

  Definition IndexedBag_RepInv
             (bag : TIndexedBag) :=
    RepInv (pget (snd bag)) (fst bag) /\
    forall idx, List.In idx (ibenumerate (fst bag)) <->
                pget (snd bag) idx <> None.

  Definition IndexedBag_ValidUpdate
             (updateterm : TUpdateTerm) :=
    forall ibag imap idx,
      RepInv imap ibag ->
      RepInv (fun i => if TIndex_dec i idx
                       then match imap i with
                            | Some item => Some (Transform updateterm item)
                            | None      => None
                            end
                       else imap i) ibag.

  Lemma IndexedBag_Empty_RepInv :
    IndexedBag_RepInv IndexedBag_bempty.
  Proof.
    unfold IndexedBag_RepInv.
    split. apply ibempty_RepInv.
    intro idx. split.
    - intro asmp. exfalso. apply (ibenumerate_empty idx). assumption.
    - intro asmp. exfalso. apply asmp. apply pempty_correct.
  Qed.

  Lemma IndexedBag_binsert_Preserves_RepInv :
    binsert_Preserves_RepInv IndexedBag_RepInv IndexedBag_binsert.
  Proof.
    unfold binsert_Preserves_RepInv, IndexedBag_binsert, IndexedBag_RepInv.
    intros [ibag pool] item [repi repp]; simpl in *; split.
    - eapply ibinsert_RepInv; eapply ib_RepInv; [ | eauto ].
      intros idx asmp; rewrite pput_neq; eauto.
      intro contra; subst; apply repp in asmp; apply asmp; apply pfresh_correct.
    - intro idx; split; intro asmp.
      + eapply Permutation_in in asmp; try eapply ibinsert_enumerate; eauto.
        inversion asmp. subst. rewrite pput_eq. congruence.
        rewrite pput_neq. apply repp. assumption. intro contra.
        subst. apply repp in H. apply H. apply pfresh_correct.
      + eapply Permutation_in. symmetry. eapply ibinsert_enumerate. eauto.
        destruct (TIndex_dec (pfresh pool) idx); subst.
        * left; eauto.
        * right; apply repp; rewrite pput_neq in asmp; eauto.
  Qed.

  Lemma Permutation_in' :
    forall {A : Type} {l l' : list A} (x : A),
      Permutation l l' -> (List.In x l <-> List.In x l').
  Proof.
    split; intros; eapply Permutation_in; [ | | symmetry | ]; eauto.
  Qed.

  Lemma IndexedBag_bdelete_Preserves_RepInv :
    bdelete_Preserves_RepInv IndexedBag_RepInv IndexedBag_bdelete.
  Proof.
    unfold bdelete_Preserves_RepInv, IndexedBag_bdelete, IndexedBag_RepInv.
    simpl; intros [ibag pool] st [repi repp]; simpl.
    assert (forall idx, List.In idx (ibenumerate (snd (ibdelete ibag st))) ->
                        ~ List.In idx (fst (ibdelete ibag st))).
    { intros idx asmp asmp'.
      pose proof (ibdelete_correct _ _ st repi) as [Hsnd Hfst].
      pose proof (Permutation_in _ Hsnd asmp) as asmp_ls.
      pose proof (Permutation_in _ Hfst asmp') as asmp'_ls.
      apply ListFacts.In_partition_unmatched in asmp_ls.
      apply ListFacts.In_partition_matched in asmp'_ls.
      congruence. }
    rewrite surjective_pairing with (p:=ibdelete ibag st); split; simpl in *.
    - pose proof (ibdelete_RepInv _ _ st repi) as repi'; eapply ib_RepInv; [ | eauto ].
      intros idx asmp; apply H in asmp.
      generalize asmp; apply Common.fold_right_rect; eauto; intros; subst.
      destruct (TIndex_dec b idx); eauto; subst. exfalso. apply asmp0. econstructor. eauto.
      rewrite pput_neq; eauto. apply H0. intro. apply asmp0. econstructor 2. eauto.
    - intro idx; split; intro asmp.
      + pose proof (H _ asmp) as asmp'; generalize asmp'.
        eapply Common.fold_right_rect; eauto; intros; subst. apply repp.
        eapply (fun A f x l H => proj1 (proj1 (@List.filter_In A x f l) H)).
        pose proof (ibdelete_correct _ _ st repi) as [Hdel _].
        rewrite ListFacts.partition_filter_neq in Hdel; eapply Permutation_in; eauto.
        destruct (TIndex_dec b idx); subst; [ rewrite pput_eq | rewrite pput_neq ]; eauto.
        exfalso; apply asmp'0; econstructor; eauto.
        apply H0; intro; apply asmp'0; econstructor 2; eauto.
      + specialize (H idx); pose proof (ibdelete_correct _ _ st repi) as [Hsnd Hfst].
        rewrite ListFacts.partition_filter_neq in Hsnd; rewrite (Permutation_in' idx Hsnd) in *.
        rewrite ListFacts.partition_filter_eq in Hfst; symmetry in Hfst.
        apply PermutationFacts.permutation_filter in Hfst.
        destruct Hfst as [ls [Hfst1 Hfst2] ]. rewrite <- Hfst1 in *.
        apply List.filter_In; rewrite (Permutation_in' idx Hfst2).
        specialize (fun H => proj1 (Permutation_in' idx Hfst2) (proj2 (repp idx) H)); clear repp; intro repp.

        clear H Hfst1 Hfst2 Hsnd.
         induction ls; eauto; simpl in *.
        * exfalso; eauto.
        * destruct (IBagMatcher Matcher (pget pool) st a) eqn: eq; simpl in *.
          { destruct (TIndex_dec a idx); subst; eauto.
            rewrite pput_eq in asmp; congruence. rewrite pput_neq in asmp; eauto.
            specialize (IHls asmp); clear asmp.
            split; [ right | ]; apply IHls; intro; destruct (repp H); try congruence; eauto. }
          { destruct (TIndex_dec a idx); subst; eauto.
            split. tauto. rewrite eq. auto.
            split; [ right | ]; apply IHls; eauto.
            intro. destruct (repp H). congruence. auto. intro.
            destruct (repp H). congruence. auto. }
  Qed.

  Lemma  IndexedBag_bupdate_Preserves_RepInv :
    bupdate_Preserves_RepInv IndexedBag_RepInv IndexedBag_ValidUpdate IndexedBag_bupdate.
  Proof.
    unfold bupdate_Preserves_RepInv, IndexedBag_bupdate, IndexedBag_RepInv, IndexedBag_ValidUpdate.
    simpl; intros [ibag pool] st ut [repi repp]; split; simpl.
    - clear repp; remember (ibfind ibag st) as ls; clear Heqls.
      eapply Common.fold_right_rect; eauto.
      clear repi ls; intros _ idx ls _ asmp.
      remember (List.fold_right (fun (idx : TIndex) (p : TPool) =>
                                   match pget p idx with
                                   | Some item => pput p idx (Some (Transform ut item))
                                   | None => p
                                   end) pool ls) as pool'; clear Heqpool'.
      destruct (pget pool' idx) eqn: eq; eauto.
      specialize (valid_update _ _ idx asmp); clear asmp ls.
      assert ((pget (pput pool' idx (Some (Transform ut t)))) =
              (fun i : TIndex =>
                 if TIndex_dec i idx
                 then
                   match pget pool' i with
                   | Some item => Some (Transform ut item)
                   | None => None
                   end
                 else pget pool' i)) as H; try rewrite H; eauto.
      extensionality idx'; destruct (TIndex_dec idx' idx); subst.
      + rewrite pput_eq; rewrite eq; eauto.
      + rewrite pput_neq; eauto.
    - clear valid_update; intro idx; split; intro asmp.
      + eapply Common.fold_right_rect; simpl; intros; try apply repp; eauto; subst.
        destruct (pget (List.fold_right
                          (fun (idx : TIndex) (p : TPool) =>
                             match pget p idx with
                             | Some item => pput p idx (Some (Transform ut item))
                             | None => p
                             end) pool t) b); eauto.
        destruct (TIndex_dec b idx); subst;
        [ rewrite pput_eq; congruence | rewrite pput_neq ]; eauto.
      + remember (ibfind ibag st) as ls; clear Heqls.
        induction ls; simpl in *. apply repp; eauto.
        destruct (pget (List.fold_right
                          (fun (idx : TIndex) (p : TPool) =>
                             match pget p idx with
                             | Some item => pput p idx (Some (Transform ut item))
                             | None => p
                             end) pool ls) a) eqn: eq.
        * destruct (TIndex_dec a idx); subst. rewrite pput_eq in asmp.
          apply IHls; intro; congruence. rewrite pput_neq in asmp; eauto.
        * apply IHls; intro; congruence.
  Qed.

  Lemma IndexedBag_BagEnumerateEmpty :
    BagEnumerateEmpty IndexedBag_benumerate IndexedBag_bempty.
  Proof.
    unfold IndexedBag_benumerate, IndexedBag_bempty, IndexesToItems.
    hnf; simpl; intros item.
    destruct (ibenumerate ibempty) eqn: eq; eauto.
    exfalso; apply (ibenumerate_empty t); rewrite eq; simpl; eauto.
  Qed.

  Lemma InList_ind_helper :
    forall {A : Type} {P : A -> Prop} {x : A} {xs : list A},
      (forall k, List.In k (x :: xs) -> P k) -> (P x /\ (forall k, List.In k xs -> P k)).
  Proof.
    intros; split; intros; eapply H; simpl; eauto.
  Qed.

  Lemma IndexesToItems_perm :
    forall pool idxs idxs',
      Permutation idxs idxs' ->
      Permutation (IndexesToItems idxs pool) (IndexesToItems idxs' pool).
  Proof.
    unfold IndexesToItems; induction 1; eauto; simpl in *.
    - destruct (pget pool x); eauto.
    - destruct (pget pool x); destruct (pget pool y); eauto; apply perm_swap.
    - eapply perm_trans; eauto.
  Qed.

  Lemma IndexedBag_BagInsertEnumerate :
    BagInsertEnumerate IndexedBag_RepInv IndexedBag_benumerate IndexedBag_binsert.
  Proof.
    unfold IndexedBag_benumerate, IndexedBag_RepInv, IndexedBag_binsert.
    hnf; simpl; intros ins bag [repi repp].
    eapply perm_trans; [ eapply IndexesToItems_perm; try eapply ibinsert_enumerate | ]; eauto.
    simpl; rewrite pput_eq; constructor.
    remember (ibenumerate (fst bag)) as ls; clear Heqls.
    pose proof (fun idx => proj1 (repp idx)) as repp_f; clear repp.
    induction ls; simpl; eauto.
    destruct (InList_ind_helper repp_f) as [repp_f_h repp_f_t]; clear repp_f.
    rewrite pput_neq; eauto.
    destruct (pget (snd bag) a); eauto.
    intro contra; subst; apply repp_f_h; apply pfresh_correct.
  Qed.

  Lemma IndexedBag_BagFindCorrect :
    BagFindCorrect IndexedBag_RepInv IndexedBag_bfind Matcher IndexedBag_benumerate.
  Proof.
    unfold BagFindCorrect, IndexedBag_RepInv, IndexedBag_bfind, IndexedBag_benumerate.
    intros [ibag pool] st [repi _]; simpl in *.
    eapply perm_trans; [ | eapply IndexesToItems_perm; symmetry; eapply ibfind_correct ]; eauto.
    induction (ibenumerate ibag); eauto; simpl.
    unfold IBagMatcher in *; destruct (pget pool a) eqn: eq; simpl in *.
    - destruct (Matcher st t); eauto. simpl. rewrite eq. eapply perm_skip; eauto.
    - eauto.
  Qed.

  Lemma IndexedBag_BagCountCorrect :
    BagCountCorrect IndexedBag_RepInv IndexedBag_bcount IndexedBag_bfind.
  Proof.
    unfold BagCountCorrect, IndexedBag_RepInv, IndexedBag_bcount, IndexedBag_bfind.
    intros [ibag pool] st [repi repp]; simpl in *.
    rewrite <- ibcount_correct; eauto.
    specialize (fun i => proj1 (repp i)); clear repp; intro repp.
    assert (forall i, List.In i (ibfind ibag st) -> pget pool i <> None).
    intros i asmp. apply repp. eapply List.filter_In. eapply Permutation_in.
    eapply ibfind_correct; eauto. eauto.
    induction (ibfind ibag st); eauto.
    destruct (InList_ind_helper H) as [H_h H_t]; clear H.
    simpl; destruct (pget pool a); try congruence. simpl. f_equal.
    apply IHl. eauto.
  Qed.

  Lemma IndexedBag_BagDeleteCorrect :
    BagDeleteCorrect IndexedBag_RepInv IndexedBag_bfind Matcher IndexedBag_benumerate IndexedBag_bdelete.
  Proof.
    unfold BagDeleteCorrect, IndexedBag_benumerate, IndexedBag_bdelete.
    intros [ibag pool] st rep.
    pose proof (IndexedBag_bdelete_Preserves_RepInv _ st rep) as rep_del.
    destruct rep as [repi repp]; destruct rep_del as [_ repp_del].
    rewrite surjective_pairing with (p:=ibdelete ibag st); split; simpl in *.
    - admit.
    - admit.
  Qed.

  Lemma IndexedBag_BagUpdateCorrect :
    BagUpdateCorrect IndexedBag_RepInv IndexedBag_ValidUpdate IndexedBag_bfind Matcher IndexedBag_benumerate Transform IndexedBag_bupdate.
  Proof.
    unfold BagUpdateCorrect, IndexedBag_benumerate, IndexedBag_bupdate.
    simpl; intros [ibag pool] st ut [repi repp]; split; simpl.
    - admit.
    - admit.
  Qed.

  Global Instance IndexedBagAsBag
    : Bag TIndexedBag TItem TSearchTerm TUpdateTerm :=
    {| bempty            := IndexedBag_bempty;
       bfind_matcher     := Matcher;
       bupdate_transform := Transform;

       benumerate := IndexedBag_benumerate;
       bfind      := IndexedBag_bfind;
       binsert    := IndexedBag_binsert;
       bcount     := IndexedBag_bcount;
       bdelete    := IndexedBag_bdelete;
       bupdate    := IndexedBag_bupdate |}.

  Global Instance IndexedBagAsCorrectBag
    : CorrectBag IndexedBag_RepInv IndexedBag_ValidUpdate IndexedBagAsBag :=
    {| bempty_RepInv     := IndexedBag_Empty_RepInv;
       binsert_RepInv    := IndexedBag_binsert_Preserves_RepInv;
       bdelete_RepInv    := IndexedBag_bdelete_Preserves_RepInv;
       bupdate_RepInv    := IndexedBag_bupdate_Preserves_RepInv;

       binsert_enumerate := IndexedBag_BagInsertEnumerate;
       benumerate_empty  := IndexedBag_BagEnumerateEmpty;
       bfind_correct     := IndexedBag_BagFindCorrect;
       bcount_correct    := IndexedBag_BagCountCorrect;
       bdelete_correct   := IndexedBag_BagDeleteCorrect;
       bupdate_correct   := IndexedBag_BagUpdateCorrect |}.

End IndexedBag.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*                                                                      *)
(* Micromega: A reflexive tactic using the Positivstellensatz           *)
(*                                                                      *)
(*  Frédéric Besson (Irisa/Inria) 2006-2008                             *)
(*                                                                      *)
(************************************************************************)

Require Import OrderedRing.
Require Import RingMicromega.
Require Import Refl.
Require Import Raxioms RIneq Rpow_def DiscrR.
Require Setoid.
(*Declare ML Module "micromega_plugin".*)

Definition Rsrt : ring_theory R0 R1 Rplus Rmult Rminus Ropp (@eq R).
Proof.
  constructor.
  exact Rplus_0_l.
  exact Rplus_comm.
  intros. rewrite Rplus_assoc. auto.
  exact Rmult_1_l.
  exact Rmult_comm.
  intros ; rewrite Rmult_assoc ; auto.
  intros. rewrite Rmult_comm. rewrite Rmult_plus_distr_l.
   rewrite (Rmult_comm z).    rewrite (Rmult_comm z). auto.
  reflexivity.
  exact Rplus_opp_r.
Qed.

Add Ring Rring : Rsrt.
Open Scope R_scope.

Lemma Rmult_neutral : forall x:R , 0 * x = 0.
Proof.
  intro ; ring.
Qed.

Lemma Rsor : SOR R0 R1 Rplus Rmult Rminus Ropp (@eq R)  Rle Rlt.
Proof.
  constructor; intros ; subst ; try (intuition (subst; try ring ; auto with real)).
  constructor.
  constructor.
  unfold RelationClasses.Symmetric. auto.
  unfold RelationClasses.Transitive. intros. subst. reflexivity.
  apply Rsrt.
  eapply Rle_trans ; eauto.
  apply (Rlt_irrefl m) ; auto.
  apply Rnot_le_lt. auto with real.
  destruct (total_order_T n m) as [ [H1 | H1] | H1] ; auto.
  intros.
  rewrite <- (Rmult_neutral m).
  apply (Rmult_lt_compat_r) ; auto.
Qed.

Require ZMicromega.
(* R with coeffs in Z *)

Lemma RZSORaddon :
  SORaddon R0 R1 Rplus Rmult Rminus Ropp  (@eq R)  Rle (* ring elements *)
  0%Z 1%Z Zplus Zmult Zminus Zopp (* coefficients *)
  Zeq_bool Zle_bool
  IZR nat_of_N pow.
Proof.
  constructor.
  constructor ; intros ; try reflexivity.
  apply plus_IZR.
  symmetry. apply Z_R_minus.
  apply mult_IZR.
  apply Ropp_Ropp_IZR.
  apply IZR_eq.
  apply Zeq_bool_eq ; auto.
  apply R_power_theory.
  intros x y.
  intro.
  apply IZR_neq.
  apply Zeq_bool_neq ; auto.
  intros. apply IZR_le.  apply Zle_bool_imp_le. auto.
Qed.

Require Import EnvRing.

Definition INZ (n:N) : R :=
  match n with
    | N0 => IZR 0%Z
    | Npos p => IZR (Zpos p)
  end.

Definition Reval_expr := eval_pexpr  Rplus Rmult Rminus Ropp IZR nat_of_N pow.

Definition Reval_op2 (o:Op2) : R -> R -> Prop :=
    match o with
      | OpEq =>  @eq R
      | OpNEq => fun x y  => ~ x = y
      | OpLe => Rle
      | OpGe => Rge
      | OpLt => Rlt
      | OpGt => Rgt
    end.

Definition Reval_formula (e: PolEnv R) (ff : Formula Z) :=
  let (lhs,o,rhs) := ff in Reval_op2 o (Reval_expr e lhs) (Reval_expr e rhs).

Definition Reval_formula' :=
  eval_formula  Rplus Rmult Rminus Ropp (@eq R) Rle Rlt IZR nat_of_N pow.

Lemma Reval_formula_compat : forall env f, Reval_formula env f <-> Reval_formula' env f.
Proof.
  intros.
  unfold Reval_formula.
  destruct f.
  unfold Reval_formula'.
  unfold Reval_expr.
  split ; destruct Fop ; simpl ; auto.
  apply Rge_le.
  apply Rle_ge.
Qed.

Definition Reval_nformula :=
  eval_nformula 0 Rplus Rmult  (@eq R) Rle Rlt IZR.

Lemma Reval_nformula_dec : forall env d, (Reval_nformula env d) \/ ~ (Reval_nformula env d).
Proof.
  exact (fun env d =>eval_nformula_dec Rsor IZR env d).
Qed.

Definition RWitness := Psatz Z.

Definition RWeakChecker := check_normalised_formulas 0%Z 1%Z Zplus Zmult  Zeq_bool Zle_bool.

Require Import List.

Lemma RWeakChecker_sound :   forall (l : list (NFormula Z)) (cm : RWitness),
  RWeakChecker l cm = true ->
  forall env, make_impl (Reval_nformula env) l False.
Proof.
  intros l cm H.
  intro.
  unfold Reval_nformula.
  apply (checker_nf_sound Rsor RZSORaddon l cm).
  unfold RWeakChecker in H.
  exact H.
Qed.

Require Import Tauto.

Definition Rnormalise := @cnf_normalise Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool.
Definition Rnegate := @cnf_negate Z 0%Z 1%Z Zplus Zmult Zminus Zopp Zeq_bool.

Definition RTautoChecker (f : BFormula (Formula Z)) (w: list RWitness)  : bool :=
  @tauto_checker (Formula Z) (NFormula Z)
  Rnormalise Rnegate
  RWitness RWeakChecker f w.

Lemma RTautoChecker_sound : forall f w, RTautoChecker f w = true -> forall env, eval_f  (Reval_formula env)  f.
Proof.
  intros f w.
  unfold RTautoChecker.
  apply (tauto_checker_sound  Reval_formula Reval_nformula).
  apply Reval_nformula_dec.
  intros. rewrite Reval_formula_compat.
  unfold Reval_formula'. now apply (cnf_normalise_correct Rsor RZSORaddon).
  intros. rewrite Reval_formula_compat. unfold Reval_formula. now apply (cnf_negate_correct Rsor RZSORaddon).
  intros t w0.
  apply RWeakChecker_sound.
Qed.

(* Local Variables: *)
(* coding: utf-8 *)
(* End: *)


(*|
#################################
Coq: Derive argument from context
#################################

:Link: https://stackoverflow.com/q/53344715
|*)

(*|
Question
********
|*)

(* I have a section with many variables and definitions. *)
Section SectionWithDefs.

  Context {A B C: Type}.

  Variable arg1: A -> B.
  Variable arg2: B -> C.

  (* Functions that uses these variables. *)
  Definition f a := arg2 (arg1 a).
  (* ... *)

End SectionWithDefs.

(* Now I want to use some of these functions. *)
Section AnotherSection.

  Context {A B C: Type}.

  (* Here are the arguments. *)
  Variable arg1: A -> B.
  Variable arg2: B -> C.

  Variable a: A.

  Section CallFunctionWithArgiments.

    (* We can directly pass the arguments to the function... *)
    Eval compute in (f arg1 arg2 a).

  End CallFunctionWithArgiments.

  Section LetBlock.

    (* ... or we can create a sequence of let expression. *)
    Let f := f arg1 arg2.
    (* ... *)

    Eval compute in (f a).

  End LetBlock.

End AnotherSection.

(*|
It is really hard to use the first approach since it is very difficult
to maintain such code. Writing becomes really painful when there are
more than five different functions with 4-5 arguments each.

The second case is more convenient. But I still have a lot of extra
lines with "let" declarations:

.. code-block:: coq

    Let f1 := ...
    Let f2 := ...
    ...
    Let fn := ...

Is there any way to avoid this extra boilerplate? Ideally, I want Coq
to just "guess" correct arguments using types or even names of terms
in a context.
|*)

(*|
Answer
******

If the context (i.e., the list of ``arg1``, ``arg2``, etc.) is simple
enough, you could use type classes to not have to pass arguments
around.
|*)

Reset Initial. (* .none *)
(* I have a section with many variables and definitions. *)
Section SectionWithDefs.

  Context {A B C: Type}.

  Class Arg1 : Type := arg1 : A -> B.
  Context `{IArg1 : Arg1}.

  Class Arg2 : Type := arg2 : B -> C.
  Context `{IArg2 : Arg2}.

  (* Functions that uses these variables. *)
  Definition f a := arg2 (arg1 a).

  (* ... *)

End SectionWithDefs.

(* Now I want to use some of these functions. *)
Section AnotherSection.

  Context {A B C: Type}.

  (* Here are the arguments. *)
  Context `{MyIArg1 : Arg1 A B}.
  Context `{MyIArg2 : Arg2 B C}.

  Variable a: A.

  Section CallFunctionWithInstances.

    (* The implicit type class arguments [IArg1] and [IArg2] are
       resolved using instances in scope... *)
    Compute (f a).

  End CallFunctionWithInstances.

End AnotherSection.