(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(** * SigmaGSP.v: Sigma GSP protocol *)

Require Import PrimeLib.
Require Import EasyCrypt.
Require Import ZArith.
Require Psatz.

Set Implicit Arguments.

Open Scope Z_scope.

(** TODO: Move somewhere else *)

Lemma seqZ_S : forall n a,
 seqZ a (S n) = seqZ a n ++ (a + Z_of_nat n) :: nil.
Proof.
 induction n; intros.
 rewrite Zplus_0_r; trivial.
 simpl seqZ.
 rewrite <-app_comm_cons; apply f_equal.
 replace (a + Z_of_nat (S n)) with (Zsucc a + Z_of_nat n).
 rewrite <-(IHn (Zsucc a)); trivial.
 rewrite Zplus_succ_comm, inj_S; trivial.
Qed.

Lemma seqZ_app : forall n1 n2 n a,
 (n = n1 + n2)%nat ->
 seqZ a n = seqZ a n1 ++ seqZ (a + Z_of_nat n1) n2.
Proof.
 induction n1; intros.
 replace n2 with n by omega.
 simpl; rewrite Zplus_0_r; trivial.
 rewrite IHn1 with (n2:=S n2); [ | omega].
 rewrite (seqZ_S _ a).
 rewrite <-app_assoc; simpl; apply f_equal, f_equal.
 rewrite Zplus_succ_r, <-inj_S; trivial.
Qed.

Lemma seqZ_app' : forall n1 n a,
 (n1 <= n)%nat ->
 seqZ a n = seqZ a n1 ++ seqZ (a + Z_of_nat n1) (n - n1).
Proof.
 intros; apply seqZ_app; omega.
Qed.

Lemma seqZ_Zsucc : forall n a,
 seqZ (Zsucc a) n = map Zsucc (seqZ a n).
Proof.
 induction n; intros.
 trivial.
 simpl; apply f_equal, IHn.
Qed.

Lemma seqZ_Zplus : forall b ,
 0 <= b ->
 forall n a, seqZ (Zplus a b) n = map (Zplus b) (seqZ a n).
Proof.
 intros b Hpos.
 apply natlike_ind with
  (P:=fun b => forall n a, seqZ (a + b) n = map (Zplus b) (seqZ a n)).
 intros; rewrite Zplus_0_r, map_id; trivial.
 intros; rewrite <-Zplus_succ_r, seqZ_Zsucc, H0, map_map.
 apply map_ext; auto with zarith.
 trivial.
Qed.

Lemma finite_sum_le_const : forall (A:Type) (f:A -> U) L v,
 ((forall x, In x L -> f x <= v) -> finite_sum f L <= length L */ v)%tord.
Proof.
 intros.
 rewrite <-(@finite_sum_cte _ (fun _ => v)); trivial.
 apply finite_sum_le; trivial.
Qed.
(***)

Close Scope Z_scope.

(** A family of multiplicative finite groups *)
Module Type GROUP.

 Parameter t : nat -> Type.

 (** The group is finite and non-empty *)
 Parameter elems : forall k, list (t k).

 Parameter elems_full : forall k (x:t k), In x (elems k).
 Parameter elems_nodup : forall k, NoDup (elems k).

 (** Equality is decidable *)
 Parameter eqb : forall k, t k -> t k -> bool.
 Parameter eqb_spec : forall k (x y:t k), if eqb x y then x = y else x <> y.

 (** Identity element *)
 Parameter e : forall k, t k.

 (** Operations: product, inverse *)
 Parameter mul : forall k, t k -> t k -> t k.
 Parameter inv : forall k, t k -> t k.

 (** Specification *)
 Parameter mul_assoc : forall k (x y z:t k), mul x (mul y z) = mul (mul x y) z.
 Parameter mul_e_l : forall k (x:t k), mul (e k) x = x.
 Parameter mul_inv_l : forall k (x:t k), mul (inv x) x = e k.
 Parameter mul_comm : forall k (x y:t k), mul x y = mul y x.

 (* Power *)
 Fixpoint pow (k:nat) (x:t k) (n:nat) : t k :=
  match n with
  | O => e k
  | S n => mul x (pow x n)
  end.

 Fixpoint powZ (k:nat) (x:t k) (n:Z) {struct n}: t k :=
  match n with
  | Z0 => pow x 0
  | Zpos p => pow x (nat_of_P p)
  | Zneg p => inv (pow x (nat_of_P p))
  end.

 Parameter pow_order : forall k x, pow x (length (elems k)) = e k.

 (* Cost *)
 Parameter order_poly : polynomial.

 Parameter order_size_nat : forall k,
  size_nat (length (elems k)) < peval order_poly k.

 Parameter cost_mul : forall k (x y:t k), nat.
 Parameter cost_pow : forall k (x:t k) (n:Z), nat.
 Parameter cost_inv : forall k (x:t k), nat.

 Parameter cost_mul_poly : polynomial.
 Parameter cost_pow_poly : polynomial.
 Parameter cost_inv_poly : polynomial.

 Parameter cost_mul_poly_spec : forall k (x y:t k),
  cost_mul x y <= peval cost_mul_poly k.

 Parameter cost_pow_poly_spec : forall k (x:t k) (n:Z),
  cost_pow x n <= peval cost_pow_poly k.

 Parameter cost_inv_poly_spec : forall k (x:t k),
  cost_inv x <= peval cost_inv_poly k.

End GROUP.

(** * Derived properties of finite groups *)
Module Group_Properties (G:GROUP).

 Import G.

 Lemma elems_not_nil : forall k, elems k <> nil.
 Proof.
  intros k H.
  assert (X:=elems_full (e k)).
  rewrite H in X; trivial.
 Qed.

 Lemma eqb_refl : forall k (x:t k), eqb x x.
 Proof.
  intros k x.
  generalize (eqb_spec x x).
  case (eqb x x); [ | intro H; elim H]; trivial.
 Qed.

 Lemma mul_pow_plus : forall k (x:t k) n m,
  mul (pow x n) (pow x m) = pow x (n + m).
 Proof.
  induction n; intros; simpl.
  simpl; apply mul_e_l.
  simpl; rewrite <- mul_assoc, IHn; trivial.
 Qed.

 Lemma cancellation : forall k (x y z:t k), mul x y = mul x z -> y = z.
 Proof.
  intros.
  rewrite <- (mul_e_l y), <- (mul_e_l z).
  rewrite <- (mul_inv_l x), <- mul_assoc, <- mul_assoc, H; trivial.
 Qed.

 Lemma mul_e_r : forall k (x:t k), mul x (e k) = x.
 Proof.
  intros; rewrite mul_comm, mul_e_l; trivial.
 Qed.

 Lemma mul_inv_r : forall k (x:t k), mul x (inv x) = e k.
 Proof.
  intros; rewrite mul_comm, mul_inv_l; trivial.
 Qed.

 Lemma inv_mul : forall k (a b : t k), inv (mul a b) = mul (inv a) (inv b).
 Proof.
  intros.
  apply cancellation with (mul a b).
  rewrite mul_inv_r, (mul_comm a b), <- mul_assoc.
  rewrite (mul_assoc a (inv a)), mul_inv_r, mul_e_l, mul_inv_r; trivial.
 Qed.

 Lemma inv_e : forall k, inv (e k) = e k.
 Proof.
  intros.
  apply cancellation with (e k).
  rewrite mul_inv_r, mul_e_l; trivial.
 Qed.

 Lemma inv_inv : forall k (x:t k), inv (inv x) = x.
 Proof.
  intros.
  apply cancellation with (inv x).
  rewrite mul_inv_l, <- inv_mul, mul_inv_r.
  apply inv_e.
 Qed.

 Lemma pow_e : forall k n, pow (e k) n = e k.
 Proof.
  induction n; intros; simpl.
  trivial.
  rewrite mul_e_l; trivial.
 Qed.

 Lemma pow_mul_distr : forall k (x y:t k) n,
  pow (mul x y) n = mul (pow x n) (pow y n).
 Proof.
  induction n; intros.
  simpl; rewrite mul_e_r; trivial.
  simpl; rewrite mul_assoc.
  rewrite (mul_comm x (pow x n)).
  rewrite <- (mul_assoc (pow x n)).
  rewrite (mul_comm (pow x n)).
  repeat rewrite <- mul_assoc.
  rewrite IHn; trivial.
 Qed.

 Lemma pow_pow : forall k (x:t k) n m, pow (pow x n) m = pow x (n * m).
 Proof.
  induction n; intros; simpl.
  rewrite pow_e; trivial.
  rewrite <- mul_pow_plus, <- IHn; apply pow_mul_distr.
 Qed.

 Lemma pow_inv : forall k (x:t k) n, pow (inv x) n = inv (pow x n).
 Proof.
  induction n; simpl.
  rewrite inv_e; trivial.
  rewrite IHn, inv_mul; trivial.
 Qed.

 Lemma pow_minus : forall k (x:t k) m n,
  n > m ->
  pow x (n - m) = mul (pow x n) (inv (pow x m)).
 Proof.
  intros.
  replace n with (m + (n - m)) by omega.
  rewrite <- mul_pow_plus, <- mul_assoc, mul_comm, <- mul_assoc.
  rewrite mul_inv_l, mul_e_r, minus_plus; trivial.
 Qed.

 Lemma mul_powZ_plus : forall k (x:t k) n m,
  mul (powZ x n) (powZ x m) = powZ x (n + m).
 Proof.
  intros.
  case n; intros; simpl.
  apply mul_e_l.
  case m; intros; simpl.
  apply mul_e_r.

  rewrite nat_of_P_plus_morphism; apply mul_pow_plus.

  case_eq ((p ?= p0)%positive Eq); intro H; simpl.
  apply Pcompare_Eq_eq in H; rewrite H; rewrite mul_inv_r; trivial.

  apply ZC2 in H.
  rewrite nat_of_P_minus_morphism; trivial.
  rewrite pow_minus, mul_comm, inv_mul, inv_inv; trivial.
  apply nat_of_P_gt_Gt_compare_morphism in H; trivial.

  rewrite nat_of_P_minus_morphism; trivial.
  rewrite pow_minus; trivial.
  apply nat_of_P_gt_Gt_compare_morphism in H; trivial.

  case m; intros; simpl.
  apply mul_e_r.

  case_eq ((p ?= p0)%positive Eq); intro H; simpl.
  apply Pcompare_Eq_eq in H; rewrite H; rewrite mul_inv_l; trivial.

  apply ZC2 in H.
  rewrite nat_of_P_minus_morphism; trivial.
  rewrite pow_minus, mul_comm; trivial.
  apply nat_of_P_gt_Gt_compare_morphism in H; trivial.

  rewrite nat_of_P_minus_morphism; trivial.
  rewrite pow_minus, inv_mul, inv_inv; trivial.
  apply nat_of_P_gt_Gt_compare_morphism in H; trivial.

  rewrite nat_of_P_plus_morphism.
  rewrite <- inv_mul, mul_pow_plus; trivial.
 Qed.

 Lemma powZ_e : forall k n, powZ (e k) n = e k.
 Proof.
  induction n; simpl.
  trivial.
  apply pow_e.
  rewrite pow_e, inv_e; trivial.
 Qed.

 Lemma powZ_mul_distr : forall k (x y:t k) n,
  powZ (mul x y) n = mul (powZ x n) (powZ y n).
 Proof.
  destruct n; intros.
  simpl; rewrite mul_e_r; trivial.
  apply pow_mul_distr.
  simpl.
  rewrite <- inv_mul, pow_mul_distr; trivial.
 Qed.

 Lemma powZ_powZ : forall k (x:t k) n m, powZ (powZ x n) m = powZ x (n * m).
 Proof.
  induction n; intros; simpl.
  apply powZ_e.
  case m; intros; simpl.
   trivial.
   rewrite pow_pow, nat_of_P_mult_morphism; trivial.
   rewrite pow_pow, nat_of_P_mult_morphism; trivial.
  case m; intros; simpl.
   trivial.
   rewrite pow_inv, pow_pow, nat_of_P_mult_morphism; trivial.
   rewrite pow_inv, pow_pow, inv_inv, nat_of_P_mult_morphism; trivial.
 Qed.

 Lemma powZ_pow : forall k (x:t k) n,
  powZ x (Z_of_nat n) = pow x n.
 Proof.
  induction n; simpl.
  trivial.
  rewrite nat_of_P_o_P_of_succ_nat_eq_succ; simpl; trivial.
 Qed.

 Lemma powZ_minus : forall k (x : t k) n,
   powZ x (- n) = inv (powZ x n).
 Proof.
   intros k x n;case n; simpl; trivial.
   rewrite inv_e; trivial.
   intro p; rewrite inv_inv; trivial.
 Qed.

 Lemma powZ_order : forall k (x:t k), powZ x (Z_of_nat (length (elems k))) = e k.
 Proof.
  intros; rewrite powZ_pow; apply pow_order.
 Qed.

 Lemma powZ_gcd : forall k (x:t k) (a:Z),
  powZ x a = e k ->
  powZ x (Zgcd a (Z_of_nat (length (elems k)))) = e k.
 Proof.
  intros.
  destruct (Zis_gcd_bezout a (Z_of_nat (length (elems k))) _ (Zgcd_is_gcd a _)).
  rewrite <-H0, <-mul_powZ_plus.
  rewrite Zmult_comm, <-powZ_powZ, H, powZ_e, mul_e_l.
  rewrite Zmult_comm, <-powZ_powZ, powZ_order, powZ_e; trivial.
 Qed.

End Group_Properties.

Module Type PARAMETERS.

 Declare Module H : GROUP.

 Parameter cplus : nat -> nat.

 Parameter cplus_pos : forall k, 0 < cplus k.

 Parameter cplus_poly : polynomial.

 Parameter size_nat_cplus : forall k,
  size_nat (cplus k) <= peval cplus_poly k.

 Parameters _T _l : Z.

 Hypothesis l_pos : (0 < _l)%Z.

 Hypothesis T_pos : (0 <= _T)%Z.

 Parameter g : forall k, H.t k.

End PARAMETERS.

(*
** Functor constructing a SigmaGSP protocol corresponding to an
** exponentiation homomorphism.
*)
Module SigmaGSP (Params:PARAMETERS).

 Import Params.

 (** We first extend the semantics with the needed types and operators *)
 Open Scope nat_scope.
 Unset Strict Implicit.

 (** Types for elements of [G], [H], and for challenges [C] *)
 Inductive ut_ : Type := H_t.

 (** * User-defined type module *)
 Module Ut <: UTYPE.

  Definition t := ut_.

  Definition eqb (t1 t2:t) :=
   match t1, t2 with
   | H_t, H_t => true
   end.

  Lemma eqb_spec : forall x y, if eqb x y then x = y else x <> y.
  Proof.
   simpl; destruct x; destruct y; simpl; trivial; discriminate.
  Qed.

  Definition eq_dec (x y:t) : {x = y} + {True}.
   destruct x; destruct y; (left; apply refl_equal) || (right; trivial).
  Defined.

  Lemma eq_dec_r : forall x y i, eq_dec x y = right _ i -> x <> y.
  Proof.
   destruct x; destruct y; simpl; intros; discriminate.
  Qed.

  Definition interp k (t0:t) : Type :=
   match t0 with
   | H_t => H.t k
   end.

  Definition size k (t0:t) : interp k t0 -> nat :=
   match t0 with
   | H_t => fun _ => S (size_nat (length (H.elems k)))
   end.

  Definition default k (t0:t) : interp k t0 :=
   match t0 with
   | H_t => H.e k
   end.

  Definition default_poly (t0:t) := H.order_poly.

  Lemma size_positive : forall k (t0:t) x, 0 < @size k t0 x.
  Proof.
   intros k t0 x; unfold size; destruct t0; auto with arith.
  Qed.

  Lemma default_poly_spec : forall k (t0:t),
   @size k t0 (default k t0) <= peval (default_poly t0) k.
  Proof.
   intros k t0.
   unfold default, default_poly, size.
   destruct t0.
   apply H.order_size_nat.
  Qed.

  Definition i_eqb k t (x y:interp k t) :=
   match t return interp k t -> interp k t -> bool with
   | H_t => @H.eqb k
   end x y.

  Lemma i_eqb_spec : forall k t (x y:interp k t),
   if i_eqb x y then x = y else x <> y.
  Proof.
   intros; destruct t0.
   refine (H.eqb_spec _ _).
  Qed.

 End Ut.

 Module T := MakeType Ut.

 Inductive uop_ : Type :=
 | Ocplus
 | OT
 | Ol
 | OH_mul
 | OH_pow
 | OH_inv
 | Ophi.

 Module Uop <: UOP Ut T.

  Definition t := uop_.

  Definition eqb (o1 o2:t) : bool :=
   match o1, o2 with
    | Ocplus, Ocplus
    | OT, OT
    | Ol, Ol
    | OH_mul, OH_mul
    | OH_pow, OH_pow
    | OH_inv, OH_inv
    | Ophi, Ophi => true
    | _, _ => false
   end.

  Lemma eqb_spec : forall x y, if eqb x y then x = y else x <> y.
  Proof.
   destruct x; destruct y; simpl; trivial; intro; discriminate.
  Qed.

  Definition targs (op:t) : list T.type :=
   match op with
    | Ocplus => nil
    | OT => nil
    | Ol => nil
    | OH_mul => T.User H_t :: T.User H_t :: nil
    | OH_pow => T.User H_t :: T.Zt :: nil
    | OH_inv => T.User H_t :: nil
    | Ophi => T.Zt :: nil
   end.

  Definition tres (op:t) : T.type :=
   match op with
    | Ocplus => T.Zt
    | OT => T.Zt
    | Ol => T.Zt
    | OH_mul => T.User H_t
    | OH_pow => T.User H_t
    | OH_inv => T.User H_t
    | Ophi => T.User H_t
   end.

  Definition interp_op (k:nat) (op:t) : T.type_op k (targs op) (tres op) :=
   match op as op0 return T.type_op k (targs op0) (tres op0) with
    | Ocplus => Z_of_nat (cplus k)
    | OT => _T
    | Ol => _l
    | OH_mul => @H.mul k
    | OH_pow => @H.powZ k
    | OH_inv => @H.inv k
    | Ophi => @H.powZ k (g k)
   end.

  Implicit Arguments interp_op [k].

  Definition cinterp_op (k:nat) (op:t) : T.ctype_op k (targs op) (tres op) :=
   match op as op0 return T.ctype_op k (targs op0) (tres op0) with
    | Ocplus => (Z_of_nat (cplus k), 1)
    | OT => (_T, 1)
    | Ol => (_l, 1)
    | OH_mul => fun x y => (H.mul x y, H.cost_mul x y)
    | OH_pow => fun x y => (H.powZ x y, H.cost_pow x y)
    | OH_inv => fun x => (H.inv x, H.cost_inv x)
    | Ophi => fun x => (H.powZ (g k) x, H.cost_pow (g k) x)
   end.

  Implicit Arguments cinterp_op [k].

  Definition eval_op k
   (op:t) (args: dlist (T.interp k) (targs op)) : T.interp k (tres op) :=
   @T.app_op k (targs op) (tres op) (interp_op op) args.

  Definition ceval_op k
   (op:t) (args: dlist (T.interp k) (targs op)) : T.interp k (tres op) * nat :=
   @T.capp_op k (targs op) (tres op) (cinterp_op op) args.

  Lemma ceval_op_spec : forall k op args,
   @eval_op k op args = fst (@ceval_op k op args).
  Proof.
   intros k o args; destruct o; simpl in args;
    T.dlist_inversion args; subst; trivial.
  Qed.

 End Uop.

 Module US := EmptySupport Ut T.

 Module Sem := MakeSem.Make Ut T Uop US.
 Module SemT := BaseProp.Make Sem.

 Module Entries.

  (** Semantics with optimizations *)
  Module SemO <: SEM_OPT.

   Module Sem := Sem.
   Export Sem.

   (** Notations *)
   Notation "x '++' y" := (E.Eop O.OZadd {x, y}).
   Notation "x '--' y" := (E.Eop O.OZsub {x, y}) (at level 40, left associativity).
   Notation "x '**' y" := (E.Eop O.OZmul {x, y}) (at level 36, left associativity).
   Notation "x '^^' y" := (E.Eop O.OZpow {x, y}) (at level 30).
   Notation "x '*' y" := (E.Eop (O.Ouser OH_mul) {x,y}).
   Notation "x '^' a" := (E.Eop (O.Ouser OH_pow) {x,a}).
   Notation "x '^-1'" := (E.Eop (O.Ouser OH_inv) {x}) (at level 30).
   Notation "c+" := (E.Eop (O.Ouser Ocplus) (dnil _)).
   Notation "'TT'" := (E.Eop (O.Ouser OT) (dnil _)).
   Notation "'l'" := (E.Eop (O.Ouser Ol) (dnil _)).
   Notation "'Phi' x" := (E.Eop (O.Ouser Ophi) {x}) (at level 25).

   Definition simpl_op (op:Uop.t) (la:E.args (Uop.targs op)) :
    E.expr (Uop.tres op) := E.Eop (O.Ouser op) la.

   Implicit Arguments simpl_op [].

   Lemma simpl_op_spec : forall k op args (m:Mem.t k),
    E.eval_expr (simpl_op op args) m = E.eval_expr (E.Eop (O.Ouser op) args) m.
   Proof.
    destruct op; simpl; trivial.
   Qed.

  End SemO.

  Module BP := SemT.

  Module Uppt.

   Import SemO.
   Import BP.

   Implicit Arguments T.size [k t].

   (** PPT expression *)
   Definition PPT_expr (t:T.type) (e:E.expr t)
    (F:polynomial -> polynomial)
    (G:polynomial -> polynomial) : Prop :=
    forall k (m:Mem.t k) p,
     (forall t (x:Var.var t),
      BP.Vset.mem x (BP.fv_expr e) -> T.size (m x) <= peval p k)  ->
     let (v,n) := E.ceval_expr e m in
      T.size v <= peval (F p) k /\
      n <= peval (G p) k.

   (** PPT support *)
   Definition PPT_support t (s:E.support t)
    (F:polynomial -> polynomial)
    (G:polynomial -> polynomial) : Prop :=
    forall k (m:Mem.t k) p,
     (forall t (x:Var.var t),
      BP.Vset.mem x (BP.fv_distr s) -> T.size (m x) <= peval p k)  ->
     let (xs,n) := E.ceval_support s m in
      (forall v, In v xs -> T.size v <= peval (F p) k) /\
      n <= peval (G p) k.

   Definition utsize : Ut.t -> nat := fun _ => 1.

   Definition utsize_default_poly : nat -> polynomial := fun _ => H.order_poly.

   Lemma utsize_default_poly_spec : forall r ut,
    utsize ut <= r ->
    forall k,
     Ut.size (t:=ut) (Ut.default k ut) <= peval (utsize_default_poly r) k.
   Proof.
    intros r ut _ k.
    case ut; simpl; unfold Ut.size, utsize_default_poly.
    apply H.order_size_nat.
   Qed.

   Definition uop_poly (o:Uop.t) : bool :=
    match o with
    | Ocplus
    | OT
    | Ol
    | OH_mul | OH_pow | OH_inv
    | Ophi => true
    end.

   Lemma uop_poly_spec : forall o (la:dlist E.expr (O.targs (O.Ouser o))),
    uop_poly o ->
    (forall t (e:E.expr t), @DIn _ E.expr _ e _ la ->
     exists F, exists G, PPT_expr e F G) ->
    exists F, exists G, PPT_expr (E.Eop (O.Ouser o) la) F G.
   Proof.
    intros o la H Hla.
    destruct o.

    (* Ocplus *)
    T.dlist_inversion la.
    rewrite Heq in Hla |- *.
    exists (fun _ => cplus_poly).
    exists (fun _ => 1).
    simpl; split.
    simpl.
    unfold size_Z; rewrite Zabs_nat_Z_of_nat.
    apply size_nat_cplus.
    rewrite pcst_spec; trivial.

    (* OT *)
    T.dlist_inversion la.
    rewrite Heq in Hla |- *.
    exists (fun _ => size_Z _T).
    exists (fun _ => 1).
    simpl; split.
    rewrite pcst_spec; trivial.
    rewrite pcst_spec; trivial.

    (* Ol *)
    T.dlist_inversion la.
    rewrite Heq in Hla |- *.
    exists (fun _ => size_Z _l).
    exists (fun _ => 1).
    simpl; split.
    rewrite pcst_spec; trivial.
    rewrite pcst_spec; trivial.

    (* OH_mul *)
    T.dlist_inversion la.
    rewrite Heq in Hla |- *.
    destruct (Hla _ x) as [F1 [G1 H1] ].
    left; trivial.
    destruct (Hla _ x0) as [F2 [G2 H2] ].
    right; left; trivial.
    exists (fun _ => pplus 1 H.order_poly).
    exists (fun p => pplus H.cost_mul_poly (pplus (G1 p) (G2 p))).
    intros k m p Hm; simpl; split.
    rewrite pplus_spec, pcst_spec; trivial.
    generalize (H.order_size_nat k); simpl; unfold Ut.size; omega.
    generalize (H1 k m p) (H2 k m p); clear H1 H2.
    case_eq (E.ceval_expr x m); simpl.
    case_eq (E.ceval_expr x0 m); simpl.
    intros i n Heqi i0 n0 Heqi0 Hi Hi0.
    destruct Hi.
    intros; apply Hm; simpl.
    apply Vset.subset_correct with (fv_expr x); [ | trivial].
    unfold fv_expr; simpl.
    apply fv_expr_rec_subset.
    destruct Hi0.
    intros; apply Hm; simpl.
    apply Vset.subset_correct with (fv_expr x0); [ | trivial].
    unfold fv_expr at 2; simpl.
    fold (fv_expr_extend x0 (fv_expr_rec Vset.empty x)).
    rewrite union_fv_expr_spec.
    apply VsetP.subset_union_l.
    rewrite plus_0_r, pplus_spec, pplus_spec; apply plus_le_compat; auto.
    apply H.cost_mul_poly_spec.
    apply plus_le_compat; trivial.

    (* OH_pow *)
    T.dlist_inversion la.
    rewrite Heq in Hla |- *.
    destruct (Hla _ x) as [F1 [G1 H1] ].
    left; trivial.
    destruct (Hla _ x0) as [F2 [G2 H2] ].
    right; left; trivial.
    exists (fun _ => pplus 1 H.order_poly).
    exists (fun p => pplus H.cost_pow_poly (pplus (G1 p) (G2 p))).
    intros k m p Hm; simpl; split.
    rewrite pplus_spec, pcst_spec.
    generalize (H.order_size_nat k); simpl; unfold Ut.size; omega.
    generalize (H1 k m p) (H2 k m p); clear H1 H2.
    case_eq (E.ceval_expr x m); simpl.
    case_eq (E.ceval_expr x0 m); simpl.
    intros i n Heqi i0 n0 Heqi0 Hi Hi0.
    destruct Hi.
    intros; apply Hm; simpl.
    apply Vset.subset_correct with (fv_expr x); [ | trivial].
    unfold fv_expr; simpl.
    apply fv_expr_rec_subset.
    destruct Hi0.
    intros; apply Hm; simpl.
    apply Vset.subset_correct with (fv_expr x0); [ | trivial].
    unfold fv_expr at 2; simpl.
    fold (fv_expr_extend x0 (fv_expr_rec Vset.empty x)).
    rewrite union_fv_expr_spec.
    apply VsetP.subset_union_l.
    rewrite plus_0_r, pplus_spec, pplus_spec; apply plus_le_compat; auto.
    apply H.cost_pow_poly_spec.
    apply plus_le_compat; trivial.

    (* OG_inv *)
    T.dlist_inversion la.
    rewrite Heq in Hla |- *.
    destruct (Hla _ x) as [F1 [G1 H1] ].
    left; trivial.
    exists (fun _ => pplus 1 H.order_poly).
    exists (fun p => pplus H.cost_inv_poly (G1 p)).
    intros k m p Hm; simpl; split.
    rewrite pplus_spec, pcst_spec.
    generalize (H.order_size_nat k); simpl; unfold Ut.size; omega.
    generalize (H1 k m p); clear H1.
    case_eq (E.ceval_expr x m); simpl.
    intros y n Heqy Hy.
    destruct Hy.
    intros; apply Hm; simpl.
    apply Vset.subset_correct with (fv_expr x); [ | trivial].
    apply VsetP.subset_refl.
    rewrite plus_0_r, pplus_spec; apply plus_le_compat.
    apply H.cost_inv_poly_spec.
    trivial.

    (* Ophi *)
    T.dlist_inversion la.
    rewrite Heq in Hla |- *.
    destruct (Hla _ x) as [F1 [G1 H1] ].
    left; trivial.
    exists (fun _ => pplus 1 H.order_poly).
    exists (fun p => pplus H.cost_pow_poly (G1 p)).
    intros k m p Hm; simpl; split.
    rewrite pplus_spec, pcst_spec.
    generalize (H.order_size_nat k); simpl; unfold Ut.size; omega.
    generalize (H1 k m p); clear H1.
    case_eq (E.ceval_expr x m); simpl.
    intros y n Heqy Hy.
    destruct Hy.
    intros; apply Hm; simpl.
    apply Vset.subset_correct with (fv_expr x); [ | trivial].
    apply VsetP.subset_refl.
    rewrite plus_0_r, pplus_spec; apply plus_le_compat.
    apply H.cost_pow_poly_spec.
    trivial.
   Qed.

   Definition usupport_poly t (us:US.usupport t) : bool := true.

   Lemma usupport_poly_spec : forall t (us:US.usupport t),
    usupport_poly us ->
    exists F, exists G, PPT_support (E.Duser us) F G.
   Proof.
    destruct us.
   Qed.

  End Uppt.

 End Entries.

 Module Import Tactics := EasyCrypt.Make Entries.

 (** * The protocol *)
 Module Protocol.

  Definition xT     := T.User H_t.
  Definition wT     := T.Zt.
  Definition rT     := T.User H_t.
  Definition stateT := T.Zt.
  Definition cT     := T.Zt.
  Definition sT     := T.Zt.

  (** Knowledge relation *)
  Definition R k (x:T.interp k xT) (w:T.interp k wT) :=
   x = H.powZ (g k) w /\ (-_T <= w <= _T)%Z.

  Definition R' := R.

  Lemma R_dec : forall k (x:T.interp k xT) (w:T.interp k wT),
   sumbool (R x w) (~R x w).
  Proof.
   intros; unfold R.
   generalize (H.eqb_spec x (H.powZ (g k) w)).
   case (H.eqb x (H.powZ (g k) w));
   case (Z_le_dec (-_T)%Z w);
   case (Z_le_dec w _T); intuition.
  Qed.

  Definition R'_dec := R_dec.

  (** Variables *)
  Notation x      := (Var.Lvar (T.User H_t) 1).
  Notation w      := (Var.Lvar T.Zt 2).
  Notation r      := (Var.Lvar (T.User H_t) 3).
  Notation state  := (Var.Lvar T.Zt 4).
  Notation c      := (Var.Lvar T.Zt 5).
  Notation s      := (Var.Lvar T.Zt 6).
  Notation b      := (Var.Lvar T.Bool 7).
  Notation rstate := (Var.Lvar (T.Pair (T.User H_t) T.Zt) 8).
  Notation rs     := (Var.Lvar (T.Pair (T.User H_t) T.Zt) 9).
  Notation x'     := (Var.Lvar (T.User H_t) 10).
  Notation w'     := (Var.Lvar T.Zt 11).
  Notation r'     := (Var.Lvar (T.User H_t) 12).
  Notation state' := (Var.Lvar T.Zt 13).
  Notation c'     := (Var.Lvar T.Zt 14).
  Notation s'     := (Var.Lvar T.Zt 15).
  Notation c''    := (Var.Lvar T.Zt 16).
  Notation s''    := (Var.Lvar T.Zt 17).
  Notation c1     := (Var.Lvar T.Zt 18).
  Notation s1     := (Var.Lvar T.Zt 19).
  Notation c2     := (Var.Lvar T.Zt 20).
  Notation s2     := (Var.Lvar T.Zt 21).
  Notation t      := (Var.Lvar T.Zt 22).
  Notation u'     := (Var.Lvar T.Zt 23).
  Notation y'     := (Var.Lvar (T.User H_t) 24).
  Notation yu     := (Var.Lvar (T.Pair xT T.Zt) 25).

  (** Procedures *)
  Notation P1 := (Proc.mkP 1
   ((T.User H_t) :: T.Zt :: nil)
   (T.Pair (T.User H_t) T.Zt)).

  Notation P2 := (Proc.mkP 2
   ((T.User H_t) :: T.Zt :: T.Zt :: T.Zt :: nil)
   T.Zt).

  Notation S  := (Proc.mkP 3
   ((T.User H_t) :: T.Zt :: nil)
   (T.Pair (T.User H_t) T.Zt)).

  Notation KE := (Proc.mkP 4
   ((T.User H_t) :: (T.User H_t) :: T.Zt :: T.Zt :: T.Zt :: T.Zt :: nil)
   (T.Pair (T.User H_t) T.Zt)).

  Definition P1_args := dcons _ x' (dcons _ w' (dnil Var.var)).
  Definition P1_body :=
   [
    t <$- [ (-2 ** TT ** c+ ** l)%Z,, (2 ** TT ** c+ ** l)%Z]
   ].
  Definition P1_re   := (Phi t | t).

  Definition P2_args :=
   dcons _ x' (dcons _ w' (dcons _ state' (dcons _ c' (dnil Var.var)))).
  Definition P2_body := [ s' <- state' ++ c' ** (w' ++ TT) ].
  Definition P2_re : E.expr T.Zt := s'.

  Definition V x r c s :=
   (Phi (s -- c ** TT) =?= r * x ^ c) &&
   ((-2 ** TT ** c+ ** l)%Z <=Z s) &&
   (s <=Z (2 ** TT ** c+ ** l ++ 2 ** TT ** (c+ -- 1)))%Z.

  Definition S_args  := dcons _ x' (dcons _ c' (dnil Var.var)).
  Definition S_body  :=
   [
    s' <$- [ (-2 ** TT ** c+ ** l ++ c' ** (TT ++ TT))%Z,,
             ( 2 ** TT ** c+ ** l ++ c' ** (TT ++ TT))%Z ];
    r' <- Phi (s' -- c' ** TT) * (x' ^ c')^-1
   ].
  Definition S_re    := (r' | s').

  Definition KE_args :=
   dcons _ x' (dcons _ r' (dcons _ c' (dcons _ c'' (dcons _ s' (dcons _ s''
    (dnil Var.var)))))).

  Definition KE_body :=
   [
    u' <- ((s'' -- s') /Z (c'' -- c')) -- TT;
    y' <- Phi(u') * (x'^-1)
   ].

  Definition KE_re : (E.expr (T.Pair (T.User H_t) T.Zt)) := (y' | u').

  Parameter _E : env.

  Section ENV.

   Let add_P1 E := add_decl E P1 P1_args (refl_equal _) P1_body P1_re.
   Let add_P2 E := add_decl E P2 P2_args (refl_equal _) P2_body P2_re.
   Let add_S  E := add_decl E S S_args (refl_equal _) S_body S_re.
   Let add_KE E := add_decl E KE KE_args (refl_equal _) KE_body KE_re.

   Definition E := add_KE (add_S (add_P1 (add_P2 _E))).

  End ENV.

  Parameter P1_i : info P1_args P1_body P1_re.
  Parameter P2_i : info P2_args P2_body P2_re.
  Parameter S_i  : info S_args S_body S_re.
  Parameter KE_i : info KE_args KE_body KE_re.

  Definition protocol :=
   [
    rstate <c- P1 with {x, w};
    r <- Efst rstate; state <- Esnd rstate;
    c <$- [0%Z ,, c+ -Z 1%Z];
    s <c- P2 with {x, w, state, c};
    b <- V x r c s
   ].

  Definition protocol' :=
   [
    rstate <c- P1 with {x, w};
    r <- Efst rstate; state <- Esnd rstate;
    s <c- P2 with {x, w, state, c}
   ].

  Definition simulation :=
   [
    rs <c- S with {x,c};
    r <- Efst rs;
    s <- Esnd rs
   ].

  Definition R1 : mem_rel := fun k (m1:Mem.t k) _ => R (m1 x) (m1 w).

  Definition iEE :=
   (add_refl_info_O KE (fv_expr KE_re) Vset.empty Vset.empty
   (add_refl_info_O S (fv_expr S_re) Vset.empty Vset.empty
   (add_refl_info_O P1 (fv_expr P1_re) Vset.empty Vset.empty
   (add_refl_info_O P2 (fv_expr P2_re) Vset.empty Vset.empty
   (empty_info E E))))).

  Definition Inv := req_mem_rel {{x, w}} R1.

  Lemma decMR_R1 : decMR R1.
  Proof.
   unfold decMR, R1, R; intros k m1 m2.
   apply R_dec.
  Qed.

  Hint Resolve decMR_R1.

  Module HP := Group_Properties H.

  Lemma H_eqb_correct : forall k (x y:H.t k), x = y <-> H.eqb x y.
  Proof.
   intros; generalize (H.eqb_spec x y).
   case (H.eqb x y); intros; intuition; discriminate.
  Qed.

  Definition Uis_uniform (t:T.type) (d:US.usupport t) := true.

  Lemma Uis_uniform_correct : forall t (d:US.usupport t) k,
   Uis_uniform d = true -> NoDup (US.eval k d).
  Proof.
   destruct d.
  Qed.

  Definition Uis_full (t:T.type) (d:US.usupport t) := true.

  Lemma Uis_full_correct : forall t (d : US.usupport t) k,
   Uis_full d = true -> forall x, In x (US.eval k d).
  Proof.
   destruct d.
  Qed.

  Notation "'PHI' p" := (@Eapp (O.Ouser Ophi) (dcons _ p (dnil _))) (at level 30).
  Notation "'TTT'"   := (@Eapp (O.Ouser OT) (dnil _)) (at level 40).
  Notation "'---' x" := (@Eapp O.OZopp (dcons _ x (dnil _))) (at level 20).

  Opaque Zmult.

  Lemma completeness : forall k (m:Mem.t k),
   R (m x) (m w) -> Pr E protocol m (EP k b) == 1.
  Proof.
   intros.
   transitivity (Pr E [ b <- true ] m (EP k b)).
   apply equiv_deno with
    (ipred
     (Pand (Peq (Evar x<1>) (PHI (Evar w<1>)))
           (Pand (Ple (--- TTT) (Evar w<1>)) (Ple (Evar w<1>) (TTT)))))
    (kreq_mem {{b}}).
   inline_l iEE P1; sinline_l iEE P2.
   setoid_replace (kreq_mem {{b}}) with (ipred (preq_mem {{b}})).
   match goal with
    |- equiv (ipred ?P) ?E ?c1 ?E ?c2 (ipred ?Q) => change (Equiv P E c1 E c2 Q)
   end.
   check_proof
    (refl1_info (empty_info E E))
    (refl2_info (empty_info E E))
    Uis_uniform Uis_uniform_correct Uis_full Uis_full_correct
    (@Rwp_simpl E E
     (@Rrand_disj E E t true
      (@Rrand_disj E E c true
       (@Rnil E E)))); clear; simpl_goal; repeat split.

   pose T_pos; pose l_pos; auto with zarith.

   pose (cplus_pos k); auto with zarith.

   intros; apply is_true_andb; split; [apply is_true_andb; split | ].

   apply H_eqb_correct.
   rewrite H, HP.powZ_powZ, HP.mul_powZ_plus; apply f_equal; ring.

   apply Zle_imp_le_bool; rewrite <-Zplus_0_r at 1; auto with zarith.

   apply Zle_imp_le_bool, Zplus_le_compat; [trivial | ].
   rewrite Zmult_comm; apply Zmult_le_compat; auto with zarith.

   unfold SemT.iffMR, SemT.implMR; split; apply preq_mem_correct.

   intros m1 m2 H0; unfold EP, charfun, restr, fone; simpl.
   rewrite (H0 _ b); trivial.
   unfold R in H; split; simpl; intuition.

   unfold Pr; rewrite deno_assign_elim.
   unfold charfun, EP, restr; simpl; mem_upd_simpl.
  Qed.

  Import Psatz.

  Definition epsilon (k:nat) : U := [1/]1+Peano.pred (Zabs_nat (_l)).

  Lemma epsilon_bound : forall k c w,
   (Zabs_nat c <= cplus k)%nat ->
   (-_T <= w <= _T)%Z ->
   Zabs_nat (2*c*(_T - w)) */ [1/]1+Zabs_nat(4*_T * Z_of_nat (cplus k) * _l)%Z <=
   epsilon k.
  Proof.
   intros; unfold epsilon.
   repeat rewrite Zabs_nat_mult.
   rewrite <-(Nmult_1 ([1/]1+Peano.pred _)); apply Nmult_Unth_le.
   rewrite mult_1_l, <-(S_pred _ O).
   apply le_S.
   assert (Zabs_nat(_T - w) <= Zabs_nat 2 * Zabs_nat _T)%nat.
   rewrite <-Zabs_nat_mult; apply Zabs_nat_le; auto with zarith.
   replace (Zabs_nat 4) with (Zabs_nat 2 * Zabs_nat 2)%nat by (compute; trivial).
   apply mult_le_compat; trivial.
   repeat rewrite <-mult_assoc.
   apply mult_le_compat; [trivial | ].
   rewrite mult_comm, mult_assoc.
   apply mult_le_compat; trivial.
   rewrite Zabs_nat_Z_of_nat; trivial.
   change O with (Zabs_nat 0%Z); apply Zabs_nat_lt; split; [apply Zle_refl | ].
   apply l_pos.
  Qed.

  Lemma SHVZK_aux :
   prg_SD (req_mem_rel {{x,w,c}}
    (R1 /-\ (fun k m1 _ => 0 <= m1 c <= Z_of_nat (cplus k))))%Z
   E
   [
    t <$- [(-2)%Z ** TT ** c+ ** l,, 2%Z ** TT ** c+ ** l];
    r <- Phi t;
    s <- t ++ c ** (w ++ TT)
   ]
   E
   [
    s <$- [(-2)%Z ** TT ** c+ ** l ++ c ** (TT ++ TT),,
              2%Z ** TT ** c+ ** l ++ c ** (TT ++ TT)];
    r <- Phi (s -- c ** TT) * (x ^ c)^-1
   ]
   (kreq_mem {{r,s}}) epsilon.
  Proof.
   Open Scope Z_scope.
   Opaque sum_dom deno.

   intros k f1 f2 Hf m1 m2 [Heq [ [Hx Hw] Hc] ].
   rewrite deno_cons_elim, Mlet_simpl, deno_random_elim.
   rewrite Uabs_diff_sym.
   rewrite deno_cons_elim, Mlet_simpl, deno_random_elim.
   simpl; unfold O.eval_op; simpl.
   pose l_pos; pose T_pos.
   replace
    (-2 * _T * Z_of_nat (cplus k) * _l) with
    (-(2 * _T * Z_of_nat (cplus k) * _l)) by ring.
   unfold Z_support; rewrite 2 Zle_imp_le_bool;
    [ | ring_simplify; auto with zarith | ring_simplify; auto with zarith].
   rewrite <-(Heq _ c); trivial.
   set (A:=2 * _T * Z_of_nat (cplus k) * _l).
   set (c':=m1 c).
   set (w:=m1 w).
   ring_simplify (c' * (_T + _T)).
   replace (A + 1 - - A) with (2 * A + 1) by ring.
   rewrite 2 (sum_dom_finite 0%Z).
   repeat rewrite seqZ_length.
   match goal with
    |- context [Zabs_nat ?x] => ring_simplify x
   end.
   set (y:=[1/]1+Peano.pred (Zabs_nat (2 * A + 1))).

   rewrite Uabs_diff_morphism with
    (y:=finite_sum
     (fun a =>
      Umult y
      (f2 (m2{!s <-- a!}
             {!r <-- H.mul (H.powZ (g k) (a-c'*_T)) (H.inv(H.powZ (m2 x) c'))!})))
     (seqZ (-A + 2 * c' * _T) (Zabs_nat (2 * A + 1))))
    (y0:=finite_sum
     (fun a => Umult y
      (f1 (m1{!t <-- a!}{!r <-- H.powZ (g k) a!}{!s <-- a + c' * (w + _T)!})))
     (seqZ (-A) (Zabs_nat (2 * A + 1)))).
   replace
    (-A + 2 * c' * _T) with
    (-A + c' * (_T - w) + c' * (w + _T)) by ring.
   rewrite seqZ_Zplus, finite_sum_map.
   rewrite (@seqZ_app' (Zabs_nat (c' * (_T - w))) _ (-A)).
   rewrite (@seqZ_app' (Zabs_nat (2 * A + 1 - c' * (_T - w)))).
   rewrite 2 finite_sum_app.
   repeat rewrite inj_Zabs_nat, Zabs_eq.
   apply Uabs_diff_le_intro.

   rewrite Uplus_assoc, Uplus_sym; apply Uplus_le_compat.

   (* First *)
   rewrite (@finite_sum_le_const _ _ _ y); [ | trivial].
   rewrite seqZ_length, <-Zabs_nat_Zminus.
   replace (2 * A + 1 - (2 * A + 1 - c' * (_T - w))) with (c' * (_T - w)) by ring.

   transitivity (epsilon k); [ | auto].
   rewrite <-epsilon_bound with (c:=c') (w:=w); trivial.
   apply Nmult_Unth_le; rewrite <-(S_pred _ O).
   apply mult_le_compat.
   apply Zabs_nat_le; unfold c', w; split; auto with zarith.

   rewrite <-Zabs_nat_Zsucc.
   apply Zabs_nat_le; split; auto with zarith.
   unfold A; ring_simplify; apply Zle_refl.

   auto with zarith.

   change O with (Zabs_nat 0); apply Zabs_nat_lt; split;unfold A; auto with zarith.
   psatz Z.

   unfold c'; rewrite <-Zabs_nat_Z_of_nat; apply Zabs_nat_le; trivial.

   split; unfold A, c', w; psatz Z.

   (** Second *)
   rewrite Zabs_nat_Zminus.
   apply finite_sum_le; intros; Usimpl.
   apply Hf; simpl; unfold O.eval_op; simpl; mem_upd_simpl; intros t v Hin.
   assert (Vset.mem v {{r,s}}) by trivial.
   Vset_mem_inversion H0; clear Hin; subst; mem_upd_simpl.
   rewrite <-(Heq _ Protocol.x), Hx; trivial.
   rewrite HP.powZ_powZ, <-HP.powZ_minus, HP.mul_powZ_plus.
   apply f_equal; unfold w; ring.
   ring_simplify; trivial.

   split; unfold A, c', w; psatz Z.

   (** The other inequality *)
   rewrite (Uplus_sym _ (finite_sum (fun v => y * f2 _) _))%U.
   rewrite Uplus_assoc; apply Uplus_le_compat.

   (* First *)
   rewrite (@finite_sum_le_const _ _ _ y); [ | trivial].
   rewrite seqZ_length.

   transitivity (epsilon k); [ | auto].
   rewrite <-epsilon_bound with (c:=c') (w:=w); trivial.
   apply Nmult_Unth_le; rewrite <-(S_pred _ O).
   apply mult_le_compat.
   apply Zabs_nat_le; unfold c', w; psatz Z.

   unfold A.
   rewrite <-Zabs_nat_Zsucc.
   apply Zabs_nat_le.
   split; auto with zarith.
   ring_simplify; apply Zle_refl.

   psatz Z.

   change O with (Zabs_nat 0).
   apply Zabs_nat_lt; split; unfold A; [auto with zarith | psatz Z].

   rewrite <-Zabs_nat_Z_of_nat; apply Zabs_nat_le; auto with zarith.

   (* Second *)
   rewrite Zabs_nat_Zminus.
   apply finite_sum_le; intros; Usimpl.
   apply Hf; simpl; unfold O.eval_op; simpl; mem_upd_simpl; intros t v Hin.
   assert (Vset.mem v {{r,s}}) by trivial.
   Vset_mem_inversion H0; clear Hin; subst; mem_upd_simpl.
   rewrite <-(Heq _ Protocol.x), Hx; trivial.
   rewrite HP.powZ_powZ, <-HP.powZ_minus, HP.mul_powZ_plus.
   apply f_equal; unfold w; ring.
   ring_simplify; trivial.

   unfold A, w, c'; psatz Z.

   unfold A, w, c'; psatz Z.

   unfold A, w, c'; psatz Z.

   apply Zabs_nat_le; unfold A, w, c'; psatz Z.

   apply Zabs_nat_le; unfold A, w, c'; psatz Z.

   unfold A, w, c'; psatz Z.

   (***)
   apply finite_sum_eq; intros; Usimpl.
   unfold c'; rewrite (Heq _ c); trivial.
   rewrite (@deno_assign_elim k).
   simpl; unfold O.eval_op; simpl; mem_upd_simpl.

   (***)
   apply finite_sum_eq; intros; Usimpl.
   rewrite (@deno_cons_elim k), Mlet_simpl, deno_assign_elim, deno_assign_elim.
   simpl; unfold O.eval_op; simpl; mem_upd_simpl.
  Qed.

  Close Scope Z_scope.

  Lemma SHVZK :
   prg_SD (req_mem_rel {{x,w,c}}
    (R1 /-\ (fun k m1 _ => 0 <= m1 c <= Z_of_nat (cplus k))))%Z
   E protocol'
   E simulation
   (kreq_mem {{r,s}})
   epsilon.
  Proof.
   intros k f1 f2 Hf m1 m2 H.
   rewrite Uabs_diff_morphism with
    (y:=mu ([[
     [
      t <$- [(-2)%Z ** TT ** c+ ** l,, 2%Z ** TT ** c+ ** l];
      r <- Phi t;
      s <- t ++ c ** (w ++ TT)
     ] ]] E m1) f1)
    (y0:=mu ([[
     [
      s <$- [(-2)%Z ** TT ** c+ ** l ++ c ** (TT ++ TT),,
                2%Z ** TT ** c+ ** l ++ c ** (TT ++ TT)];
      r <- Phi (s -- c ** TT) * (x ^ c)^-1
     ] ]] E m2) f2).
   apply SHVZK_aux; trivial.

   apply equiv_deno with (kreq_mem {{x,w,c}}) (kreq_mem {{r,s}}).
   inline iEE P1; sinline iEE P2; eqobs_in.
   intros; transitivity (f2 m3); [ | symmetry]; auto.
   trivial.

   apply equiv_deno with (kreq_mem {{x,w,c}}) (kreq_mem {{r,s}}).
   sinline_l iEE Protocol.S; alloc_r s s'; ep iEE; swap iEE; eqobs_in.
   intros; transitivity (f1 m3); [symmetry | ]; auto.
   trivial.
  Qed.

  Definition pi : PPT_info E :=
   PPT_add_info (PPT_add_info (PPT_empty_info E) KE) Protocol.S.

  Lemma S_PPT : PPT_proc E Protocol.S.
  Proof.
   PPT_proc_tac pi.
  Qed.

  Section SOUNDNESS.

   Close Scope positive_scope.
   Open Scope Z_scope.

   Variable k : nat.
   Variable m : Mem.t k.

   Hypothesis accepting_1 : E.eval_expr (V x r c1 s1) m = true.
   Hypothesis accepting_2 : E.eval_expr (V x r c2 s2) m = true.
   Hypothesis c_range_1 : 0 <= m c1 < Z_of_nat (cplus k).
   Hypothesis c_range_2 : 0 <= m c2 < Z_of_nat (cplus k).

   Hypothesis H_neq : m c1 < m c2.

   Hypothesis H_delta_c :
    ((m c2 - m c1) | (m s2 - m s1 - (m c2 - m c1) * _T)).

   Variables d d' : Z.

   Let n := Z_of_nat (length (H.elems k)).

   (* d = Prod_{x | prime x /\ x | order /\ x <= cplus} x *)

   Hypothesis Hd : n = d * d'.

   Hypothesis d_spec : forall k x,
    prime x -> (x | d') -> Z_of_nat (cplus k) < x.

   Definition RR k (x y:T.interp k xT) (u:T.interp k wT) :=
    H.mul y x = H.powZ (g k) u /\
    H.powZ y d = H.e k /\
    -4 * _T * Z_of_nat (cplus k) * _l - 2 * _T * (Z_of_nat (cplus k) - 1) - _T <= u /\
    u <= 4 * _T * Z_of_nat (cplus k) * _l + 2 * _T * (Z_of_nat (cplus k) - 1) - _T.

   Lemma RR_dec : forall k (x y:T.interp k xT) u,
    sumbool (RR x y u) (~RR x y u).
   Proof.
    clear; unfold RR; intros.
    generalize (H.eqb_spec (H.mul y x) (H.powZ (g k) u)).
    case (H.eqb (H.mul y x) (H.powZ (g k) u)); [ | intuition].
    generalize (H.eqb_spec (H.powZ y d) (H.e k)).
    case (H.eqb (H.powZ y d) (H.e k)); [ | intuition].
    match goal with
     |- context [ ?x <= ?y <= ?z ] =>
     case (Z_le_dec x y); case (Z_le_dec y z); intuition
    end.
   Qed.

   Let u := (m s2 - m s1) / (m c2 - m c1) - _T.
   Let y := H.mul (H.powZ (g k) u) (H.inv (m x)).

   Lemma soundness_aux : RR (m x) y u.
   Proof.
    generalize accepting_1, accepting_2.
    simpl; unfold O.eval_op; simpl; intros H1 H2.
    apply andb_prop in H1; destruct H1 as [H Hge1].
    apply andb_prop in H; destruct H as [Heq1 Hle1].
    apply andb_prop in H2; destruct H2 as [H Hge2].
    apply andb_prop in H; destruct H as [Heq2 Hle2].
    rewrite <-Zle_is_le_bool in Hle1, Hle2, Hge1, Hge2 |- .
    apply H_eqb_correct in Heq1.
    apply H_eqb_correct in Heq2.

    assert (H.mul y (m x) = H.powZ (g k) u).
    unfold y, u; rewrite <-H.mul_assoc, H.mul_inv_l, HP.mul_e_r; trivial.

    unfold RR; intros; repeat split.

    trivial.

    (**)
    assert (H.powZ y (m c2 - m c1) = H.e k).
    apply HP.cancellation with (H.powZ (m x) (m c2 - m c1)).
    rewrite <-HP.powZ_mul_distr, HP.mul_e_r.
    unfold Zminus at 2; rewrite <-HP.mul_powZ_plus.
    rewrite <-HP.mul_e_r, <-(HP.mul_inv_r (m r)).
    rewrite H.mul_assoc, (H.mul_comm _ (m r)), H.mul_assoc.
    rewrite <-Heq2, <-H.mul_assoc, HP.powZ_minus.
    rewrite <-HP.inv_mul, (H.mul_comm _ (m r)), <-Heq1.
    rewrite <-HP.powZ_minus, HP.mul_powZ_plus.
    replace (m s2 - m c2 * _T + - (m s1 - m c1 * _T)) with (u * (m c2 - m c1)).
    rewrite <-HP.powZ_powZ, H.mul_comm, H; trivial.

    replace
     (m s2 - m c2 * _T + - (m s1 - m c1 * _T)) with
     ((m s2 - m s1) - (m c2 - m c1) * _T) by ring.
    set (A:=m s2 - m s1) in *.
    set (B:=m c2 - m c1) in *.
    unfold u.
    rewrite Zdivide_Zdiv_eq with (a:=B); [ | unfold B; psatz Z | trivial].
    rewrite Zmult_comm.
    apply f_equal.
    unfold Zminus; rewrite <-Z_div_plus; [ | unfold B; psatz Z].
    replace (A + -_T * B) with (A + -(B * _T)) by ring; trivial.

    (* y ^ d = e *)
    assert (m c2 - m c1 <= Z_of_nat (cplus k)) by psatz Z.
    assert (0 < m c2 - m c1) by psatz Z.
    set (delta_c:=m c2 - m c1) in *.
    clear -H0 n H1 H2 d_spec Hd.
    assert (Zdivide (Zgcd delta_c n) d).

    assert (Zgcd delta_c n | d * d') by (rewrite <-Hd; apply Zgcd_div_r).
    rewrite Zmult_comm in H; apply Gauss in H; trivial.
    unfold rel_prime; apply Zis_gcd_intro; auto with zarith; intros.

    case (Z_lt_dec 1 (Zabs x)); intro.
    case (prime_dec (Zabs x)); intro Hx.

    generalize (@d_spec k (Zabs x) Hx (Zdivide_Zabs_inv_l _ _ H4)); intro.
    assert (Zabs x <= delta_c).
    apply Zdivide_le; auto with zarith.
    apply Zdivide_Zabs_inv_l in H3.
    apply Zdivide_trans with (1:=H3), Zgcd_div_l.
    exfalso; auto with zarith.

    apply not_prime_divide_prime in Hx; trivial.
    destruct Hx as [p [? [? ?] ] ].
    assert (p | d').
    apply Zdivide_trans with (1:=H6).
    apply Zdivide_Zabs_inv_l in H4; trivial.
    assert (p | delta_c).
    apply Zdivide_trans with (1:=H6); trivial.
    apply Zdivide_trans with (2:=Zgcd_div_l _ n); trivial.
    assert (p <= delta_c).
    apply Zdivide_le; auto with zarith.
    generalize (@d_spec k p H5 H8); intro.
    assert (p <= delta_c).
    apply Zdivide_le; auto with zarith.
    apply Zdivide_trans with (1:=H6).
    apply Zdivide_Zabs_inv_l in H3.
    apply Zdivide_trans with (1:=H3), Zgcd_div_l.
    exfalso; auto with zarith.

    apply Zdivide_Zabs_inv_l; trivial.
    generalize (@d_spec k p H5 H8); intro.
    assert (p <= delta_c).
    apply Zdivide_le; auto with zarith.
    exfalso; auto with zarith.

    assert (Zabs x <= 1) by auto with zarith.
    case (Z_eq_dec (Zabs x) 1); intro.
    apply Zdivide_Zabs_l; rewrite e; auto with zarith.
    assert (Zabs x = 0).
    generalize (Zabs_pos x); intro.
    auto with zarith.
    apply Zabs_0_inv in H6.
    destruct H4; rewrite H6, Zmult_0_r in H4.
    assert (n = 0).
    rewrite Hd, H4, Zmult_0_r; trivial.

    unfold n in H7.
    elim (@HP.elems_not_nil k).
    destruct (H.elems k); [trivial | discriminate].

    apply HP.powZ_gcd in H0.
    destruct H; rewrite H, Zmult_comm, <-HP.powZ_powZ.
    unfold n; rewrite H0, HP.powZ_e; trivial.

    (**)
    unfold u.
    apply Zle_plus_swap; ring_simplify.
    apply Zdiv_le_lower_bound; [auto with zarith | ].
    psatz Z.

    (**)
    unfold u.
    apply Zle_plus_swap; ring_simplify.
    apply Zdiv_le_upper_bound; [auto with zarith | ].
    psatz Z.
   Qed.

   Close Scope Z_scope.

   Lemma soundness :
    Pr E ((yu <c- KE with {x, r, c1, c2, s1, s2}) :: nil) m
    (fun m => if RR_dec (m x) (fst(m yu)) (snd(m yu)) then true else false) == 1.
   Proof.
    transitivity (Pr E
     ( (yu <- (Phi ((s2 -- s1 /Z c2 -- c1) -- TT) * x ^-1 |
                    (s2 -- s1 /Z c2 -- c1) -- TT)) :: nil) m
     (fun m => if RR_dec (m x) (fst (m yu)) (snd (m yu)) then true else false)).
    apply EqObs_deno with {{x, r, c1, c2, s1, s2}} {{x, yu}}.
    sinline_l iEE KE; eqobs_in.

    intros; unfold charfun, restr.
    rewrite (H _ x), (H _ yu); trivial.
    trivial.

    unfold Pr; rewrite deno_assign_elim.
    unfold charfun, restr, fone.
    simpl E.eval_expr; unfold O.eval_op; simpl.
    mem_upd_simpl.
    match goal with
     |- context [RR_dec ?A ?B ?C] => case (RR_dec A B C)
    end.
    trivial.

    intro HR; elim HR; clear HR.
    apply soundness_aux.
   Qed.

   Lemma KE_PPT : PPT_proc E KE.
   Proof.
    PPT_proc_tac pi.
   Qed.

  End SOUNDNESS.

 End Protocol.

End SigmaGSP.


Require Import refine.
Require Import parser.

(** The CyCab example *)

(********* the security of component Station ************)

Definition Station: IA := parse
"IA [s1,s2] (s1) [pos] [far, halt] []
[s1->(pos)s2, s2->(far)s1, s2->(halt)s1]".

(* SIR-GNNI at l: false *)
Definition Station_hid_l: IA :=
 IAutomaton.hiding Station (ASet.GenActs [&"pos"]).

Definition Station_res_l: IA :=
 IAutomaton.restriction Station (ASet.GenActs [&"pos"]).

Eval compute in :> Station_hid_l.
Eval compute in :> Station_res_l.
Eval compute in SIRGNNI_refinement Station_res_l Station_hid_l.

(* SME-NI at l: false *)
Definition Station_rep_l: IA :=
 IAutomaton.replacement Station (&"tau") (ASet.GenActs [&"pos"]).

Eval compute in :> Station_rep_l.
Eval compute in SMENI_refinement Station_rep_l Station_hid_l.


Require Import Coq.Numbers.BinNums.
Require Import Coq.PArith.BinPosDef.
Require Import Logic.lib.PTree.
Require Import Coq.Sets.Ensembles.
Require Import Coq.Lists.List.
Import ListNotations.

Module Type LanguageSig.
  Parameter Inline expr : Type .
  Definition context := (expr -> Prop) .
  Parameter provable : (expr -> Prop) .
  Parameter impp : (expr -> expr -> expr) .
  Parameter andp : (expr -> expr -> expr) .
  Parameter orp : (expr -> expr -> expr) .
  Parameter Inline sepcon : (expr -> expr -> expr) .
  Parameter negp : (expr -> expr) .
  Parameter falsep : expr .
  Parameter truep : expr .
  Parameter emp : expr .
End LanguageSig.

Module DerivedNames (Names: LanguageSig).
Include Names.
  Definition multi_imp := (fun (xs : list expr) (y : expr) => fold_right impp y xs) .
  Definition empty_context := (Empty_set expr) .
  Definition derivable := (fun (Phi : expr -> Prop) (x : expr) => exists xs : list expr, Forall Phi xs /\ provable (multi_imp xs x)) .
End DerivedNames.

Module Type PrimitiveRuleSig (Names: LanguageSig).
Include DerivedNames (Names).
  Axiom falsep_sepcon_impp : (forall x : expr, provable (impp (sepcon falsep x) falsep)) .
  Axiom sepcon_comm_impp : (forall x y : expr, provable (impp (sepcon x y) (sepcon y x))) .
  Axiom sepcon_assoc1 : (forall x y z : expr, provable (impp (sepcon x (sepcon y z)) (sepcon (sepcon x y) z))) .
  Axiom sepcon_mono : (forall x1 x2 y1 y2 : expr, provable (impp x1 x2) -> provable (impp y1 y2) -> provable (impp (sepcon x1 y1) (sepcon x2 y2))) .
  Axiom andp_intros : (forall x y : expr, provable (impp x (impp y (andp x y)))) .
  Axiom andp_elim1 : (forall x y : expr, provable (impp (andp x y) x)) .
  Axiom andp_elim2 : (forall x y : expr, provable (impp (andp x y) y)) .
  Axiom modus_ponens : (forall x y : expr, provable (impp x y) -> provable x -> provable y) .
  Axiom axiom1 : (forall x y : expr, provable (impp x (impp y x))) .
  Axiom axiom2 : (forall x y z : expr, provable (impp (impp x (impp y z)) (impp (impp x y) (impp x z)))) .
End PrimitiveRuleSig.

Module Type LogicTheoremSig (Names: LanguageSig) (Rules: PrimitiveRuleSig Names).
Include Rules.
Parameter Inline tree_pos : Type .
  Axiom provable_derivable : (forall x : expr, provable x <-> derivable empty_context x) .
  Axiom deduction_andp_intros : (forall (Phi : context) (x y : expr), derivable Phi x -> derivable Phi y -> derivable Phi (andp x y)) .
  Axiom deduction_andp_elim1 : (forall (Phi : context) (x y : expr), derivable Phi (andp x y) -> derivable Phi x) .
  Axiom deduction_andp_elim2 : (forall (Phi : context) (x y : expr), derivable Phi (andp x y) -> derivable Phi y) .
  Axiom deduction_modus_ponens : (forall (Phi : context) (x y : expr), derivable Phi x -> derivable Phi (impp x y) -> derivable Phi y) .
  Axiom deduction_impp_intros : (forall (Phi : Ensemble expr) (x y : expr), derivable (Union expr Phi (Singleton expr x)) y -> derivable Phi (impp x y)) .
  Axiom derivable_finite_witnessed : (forall (Phi : context) (y : expr), derivable Phi y -> exists xs : list expr, Forall Phi xs /\ derivable (fun x : expr => In x xs) y) .
  Axiom deduction_weaken : (forall (Phi Psi : Ensemble expr) (x : expr), Included expr Phi Psi -> derivable Phi x -> derivable Psi x) .
  Axiom derivable_assum : (forall (Phi : Ensemble expr) (x : expr), Ensembles.In expr Phi x -> derivable Phi x) .
  Axiom deduction_subst : (forall (Phi Psi : context) (y : expr), (forall x : expr, Psi x -> derivable Phi x) -> derivable (Union expr Phi Psi) y -> derivable Phi y) .
  Axiom provable_impp_refl : (forall x : expr, provable (impp x x)) .
  Axiom provable_impp_refl' : (forall x y : expr, x = y -> provable (impp x y)) .
  Axiom provable_impp_arg_switch : (forall x y z : expr, provable (impp (impp x (impp y z)) (impp y (impp x z)))) .
  Axiom provable_impp_trans : (forall x y z : expr, provable (impp (impp x y) (impp (impp y z) (impp x z)))) .
  Axiom provable_multi_imp_shrink : (forall (xs : list expr) (x y : expr), provable (impp (impp x (multi_imp xs (impp x y))) (multi_imp xs (impp x y)))) .
  Axiom provable_multi_imp_arg_switch1 : (forall (xs : list expr) (x y : expr), provable (impp (impp x (multi_imp xs y)) (multi_imp xs (impp x y)))) .
  Axiom provable_multi_imp_arg_switch2 : (forall (xs : list expr) (x y : expr), provable (impp (multi_imp xs (impp x y)) (impp x (multi_imp xs y)))) .
  Axiom provable_add_multi_imp_left_head : (forall (xs1 xs2 : list expr) (y : expr), provable (impp (multi_imp xs2 y) (multi_imp (xs1 ++ xs2) y))) .
  Axiom provable_add_multi_imp_left_tail : (forall (xs1 xs2 : list expr) (y : expr), provable (impp (multi_imp xs1 y) (multi_imp (xs1 ++ xs2) y))) .
  Axiom provable_multi_imp_modus_ponens : (forall (xs : list expr) (y z : expr), provable (impp (multi_imp xs y) (impp (multi_imp xs (impp y z)) (multi_imp xs z)))) .
  Axiom provable_multi_imp_weaken : (forall (xs : list expr) (x y : expr), provable (impp x y) -> provable (impp (multi_imp xs x) (multi_imp xs y))) .
  Axiom provable_impp_refl_instance : (RelationClasses.Reflexive (fun x y : expr => provable (impp x y))) .
  Axiom deduction_impp_elim : (forall (Phi : context) (x y : expr), derivable Phi (impp x y) -> derivable (Union expr Phi (Singleton expr x)) y) .
  Axiom deduction_theorem : (forall (Phi : context) (x y : expr), derivable (Union expr Phi (Singleton expr x)) y <-> derivable Phi (impp x y)) .
  Axiom deduction_theorem_multi_imp : (forall (Phi : context) (xs : list expr) (y : expr), derivable (Union expr Phi (fun x : expr => In x xs)) y <-> derivable Phi (multi_imp xs y)) .
  Axiom derivable_impp_refl : (forall (Phi : context) (x : expr), derivable Phi (impp x x)) .
  Axiom deduction_left_impp_intros : (forall (Phi : context) (x y : expr), derivable Phi x -> derivable Phi (impp y x)) .
  Axiom derivable_modus_ponens : (forall (Phi : context) (x y : expr), derivable Phi (impp x (impp (impp x y) y))) .
  Axiom deduction_impp_trans : (forall (Phi : context) (x y z : expr), derivable Phi (impp x y) -> derivable Phi (impp y z) -> derivable Phi (impp x z)) .
  Axiom deduction_impp_arg_switch : (forall (Phi : context) (x y z : expr), derivable Phi (impp x (impp y z)) -> derivable Phi (impp y (impp x z))) .
  Axiom provable_proper_impp : (Morphisms.Proper (Morphisms.respectful (fun x y : expr => provable (impp x y)) Basics.impl) provable) .
  Axiom impp_proper_impp : (Morphisms.Proper (Morphisms.respectful (Basics.flip (fun x y : expr => provable (impp x y))) (Morphisms.respectful (fun x y : expr => provable (impp x y)) (fun x y : expr => provable (impp x y)))) impp) .
  Axiom derivable_proper_impp : (Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful (fun x y : expr => provable (impp x y)) Basics.impl)) derivable) .
  Axiom impp_curry : (forall x y z : expr, provable (impp (impp x (impp y z)) (impp (andp x y) z))) .
  Axiom impp_uncurry : (forall x y z : expr, provable (impp (impp (andp x y) z) (impp x (impp y z)))) .
  Axiom solve_impp_trans : (forall x y z : expr, provable (impp x y) -> provable (impp y z) -> provable (impp x z)) .
  Axiom andp_proper_impp : (Morphisms.Proper (Morphisms.respectful (fun x y : expr => provable (impp x y)) (Morphisms.respectful (fun x y : expr => provable (impp x y)) (fun x y : expr => provable (impp x y)))) andp) .
  Axiom cancel_one_succeed : (forall u x y z : expr, provable (impp (sepcon x y) z) -> provable (impp (sepcon (sepcon u x) y) (sepcon u z))) .
  Axiom cancel_one_giveup : (forall x y z w v : expr, provable (impp (sepcon x (sepcon y z)) (sepcon w v)) -> provable (impp (sepcon (sepcon y x) z) (sepcon w v))) .
  Axiom cancel_rev : (forall x y z w : expr, provable (impp (sepcon (sepcon y x) z) w) -> provable (impp (sepcon x (sepcon y z)) w)) .
  Axiom sepcon_proper_impp : (Morphisms.Proper (Morphisms.respectful (fun x y : expr => provable (impp x y)) (Morphisms.respectful (fun x y : expr => provable (impp x y)) (fun x y : expr => provable (impp x y)))) sepcon) .
  Axiom expr_deep : Set .
  Axiom impp_deep : (expr_deep -> expr_deep -> expr_deep) .
  Axiom sepcon_deep : (expr_deep -> expr_deep -> expr_deep) .
  Axiom emp_deep : expr_deep .
  Axiom varp_deep : (nat -> expr_deep) .
  Axiom var_pos : (expr -> option positive -> tree_pos) .
  Axiom sepcon_pos : (tree_pos -> tree_pos -> tree_pos) .
  Axiom cancel_mark : (expr_deep -> expr_deep -> tree_pos -> tree_pos -> tree_pos * tree_pos) .
  Axiom cancel_different : (tree_pos -> tree_pos -> expr) .
  Axiom cancel_same : (tree_pos -> tree_pos -> Prop) .
  Axiom restore : (tree_pos -> tree_pos -> expr) .
  Existing Instance provable_impp_refl_instance .
  Existing Instance provable_proper_impp .
  Existing Instance impp_proper_impp .
  Existing Instance derivable_proper_impp .
  Existing Instance andp_proper_impp .
  Existing Instance sepcon_proper_impp .
End LogicTheoremSig.

Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.ProofTheory.BasicDeduction.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.ProofTheory.RewriteClass.
Require Import Logic.MinimumLogic.ProofTheory.TheoryOfJudgement.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.DeMorgan.
Require Import Logic.PropositionalLogic.ProofTheory.GodelDummett.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.ProofTheoryPatterns.
Require Import Logic.PropositionalLogic.ProofTheory.TheoryOfIteratedConnectives.
Require Import Logic.PropositionalLogic.ProofTheory.TheoryOfClassicalAxioms.
Require Import Logic.PropositionalLogic.ProofTheory.TheoryOfPropositionalConnectives.
Require Import Logic.MetaLogicInj.Syntax.
Require Import Logic.MetaLogicInj.ProofTheory.ProofRules.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.ProofTheory.SeparationLogic.
Require Import Logic.SeparationLogic.ProofTheory.RewriteClass.
Require Import Logic.SeparationLogic.ProofTheory.DerivedRules.
Require Import Logic.SeparationLogic.ProofTheory.TheoryOfCancel.
Require Import Logic.SeparationLogic.ProofTheory.TheoryOfSeparationAxioms.
Require Import Logic.SeparationLogic.ProofTheory.IterSepcon.
Require Import Logic.SeparationLogic.ProofTheory.Corable.
Require Import Logic.SeparationLogic.ProofTheory.Deduction.
Require Import Logic.GeneralLogic.ProofTheory.BasicLogicEquiv.

Module LogicTheorem (Names: LanguageSig) (Rules: PrimitiveRuleSig Names) <: LogicTheoremSig Names Rules.
Include Rules.
  Instance L : Language := (Build_Language expr) .
  Instance minL : (MinimumLanguage L) := (Build_MinimumLanguage L impp) .
  Instance andpL : (AndLanguage L) := (Build_AndLanguage L andp) .
  Instance orpL : (OrLanguage L) := (Build_OrLanguage L orp) .
  Instance sepconL : (SepconLanguage L) := (Build_SepconLanguage L sepcon) .
  Instance negpL : (NegLanguage L) := (Build_NegLanguage L negp) .
  Instance falsepL : (FalseLanguage L) := (Build_FalseLanguage L falsep) .
  Instance truepL : (TrueLanguage L) := (Build_TrueLanguage L truep) .
  Instance empL : (EmpLanguage L) := (Build_EmpLanguage L emp) .
  Instance GammaP : (Provable L) := (Build_Provable L provable) .
  Instance GammaD : (Derivable L) := (Build_Derivable L derivable) .
  Instance minAX : (MinimumAxiomatization L GammaP) := (Build_MinimumAxiomatization L minL GammaP modus_ponens axiom1 axiom2) .
  Instance andpAX : (AndAxiomatization L GammaP) := (Build_AndAxiomatization L minL andpL GammaP andp_intros andp_elim1 andp_elim2) .
  Instance sepconAX_weak : (SepconAxiomatization_weak L GammaP) := (Build_SepconAxiomatization_weak L minL sepconL GammaP sepcon_comm_impp sepcon_assoc1) .
  Instance sepcon_mono_AX : (SepconMonoAxiomatization L GammaP) := (Build_SepconMonoAxiomatization L minL sepconL GammaP sepcon_mono) .
  Instance sepcon_falsep_AX : (SepconFalseAxiomatization L GammaP) := (Build_SepconFalseAxiomatization L minL falsepL sepconL GammaP falsep_sepcon_impp) .
  Instance GammaDP : (DerivableProvable L GammaP GammaD) := Provable2Derivable_Normal .
  Instance GammaPD : (ProvableDerivable L GammaP GammaD) := Axiomatization2SequentCalculus_GammaPD .
  Instance bSC : (BasicSequentCalculus L GammaD) := Axiomatization2SequentCalculus_bSC .
  Instance fwSC : (FiniteWitnessedSequentCalculus L GammaD) := Axiomatization2SequentCalculus_fwSC .
  Instance minSC : (MinimumSequentCalculus L GammaD) := Axiomatization2SequentCalculus_minSC .
  Instance andpSC : (AndSequentCalculus L GammaD) := Axiomatization2SequentCalculus_andpSC .
  Instance sepconAX : (SepconAxiomatization L GammaP) := SepconAxiomatizationWeak2SepconAxiomatization .
Definition tree_pos : Type := tree_pos.
  Definition provable_derivable : (forall x : expr, provable x <-> derivable empty_context x) := provable_derivable .
  Definition deduction_andp_intros : (forall (Phi : context) (x y : expr), derivable Phi x -> derivable Phi y -> derivable Phi (andp x y)) := deduction_andp_intros .
  Definition deduction_andp_elim1 : (forall (Phi : context) (x y : expr), derivable Phi (andp x y) -> derivable Phi x) := deduction_andp_elim1 .
  Definition deduction_andp_elim2 : (forall (Phi : context) (x y : expr), derivable Phi (andp x y) -> derivable Phi y) := deduction_andp_elim2 .
  Definition deduction_modus_ponens : (forall (Phi : context) (x y : expr), derivable Phi x -> derivable Phi (impp x y) -> derivable Phi y) := deduction_modus_ponens .
  Definition deduction_impp_intros : (forall (Phi : Ensemble expr) (x y : expr), derivable (Union expr Phi (Singleton expr x)) y -> derivable Phi (impp x y)) := deduction_impp_intros .
  Definition derivable_finite_witnessed : (forall (Phi : context) (y : expr), derivable Phi y -> exists xs : list expr, Forall Phi xs /\ derivable (fun x : expr => In x xs) y) := derivable_finite_witnessed .
  Definition deduction_weaken : (forall (Phi Psi : Ensemble expr) (x : expr), Included expr Phi Psi -> derivable Phi x -> derivable Psi x) := deduction_weaken .
  Definition derivable_assum : (forall (Phi : Ensemble expr) (x : expr), Ensembles.In expr Phi x -> derivable Phi x) := derivable_assum .
  Definition deduction_subst : (forall (Phi Psi : context) (y : expr), (forall x : expr, Psi x -> derivable Phi x) -> derivable (Union expr Phi Psi) y -> derivable Phi y) := deduction_subst .
  Definition provable_impp_refl : (forall x : expr, provable (impp x x)) := provable_impp_refl .
  Definition provable_impp_refl' : (forall x y : expr, x = y -> provable (impp x y)) := provable_impp_refl' .
  Definition provable_impp_arg_switch : (forall x y z : expr, provable (impp (impp x (impp y z)) (impp y (impp x z)))) := provable_impp_arg_switch .
  Definition provable_impp_trans : (forall x y z : expr, provable (impp (impp x y) (impp (impp y z) (impp x z)))) := provable_impp_trans .
  Definition provable_multi_imp_shrink : (forall (xs : list expr) (x y : expr), provable (impp (impp x (multi_imp xs (impp x y))) (multi_imp xs (impp x y)))) := provable_multi_imp_shrink .
  Definition provable_multi_imp_arg_switch1 : (forall (xs : list expr) (x y : expr), provable (impp (impp x (multi_imp xs y)) (multi_imp xs (impp x y)))) := provable_multi_imp_arg_switch1 .
  Definition provable_multi_imp_arg_switch2 : (forall (xs : list expr) (x y : expr), provable (impp (multi_imp xs (impp x y)) (impp x (multi_imp xs y)))) := provable_multi_imp_arg_switch2 .
  Definition provable_add_multi_imp_left_head : (forall (xs1 xs2 : list expr) (y : expr), provable (impp (multi_imp xs2 y) (multi_imp (xs1 ++ xs2) y))) := provable_add_multi_imp_left_head .
  Definition provable_add_multi_imp_left_tail : (forall (xs1 xs2 : list expr) (y : expr), provable (impp (multi_imp xs1 y) (multi_imp (xs1 ++ xs2) y))) := provable_add_multi_imp_left_tail .
  Definition provable_multi_imp_modus_ponens : (forall (xs : list expr) (y z : expr), provable (impp (multi_imp xs y) (impp (multi_imp xs (impp y z)) (multi_imp xs z)))) := provable_multi_imp_modus_ponens .
  Definition provable_multi_imp_weaken : (forall (xs : list expr) (x y : expr), provable (impp x y) -> provable (impp (multi_imp xs x) (multi_imp xs y))) := provable_multi_imp_weaken .
  Definition provable_impp_refl_instance : (RelationClasses.Reflexive (fun x y : expr => provable (impp x y))) := provable_impp_refl_instance .
  Definition deduction_impp_elim : (forall (Phi : context) (x y : expr), derivable Phi (impp x y) -> derivable (Union expr Phi (Singleton expr x)) y) := deduction_impp_elim .
  Definition deduction_theorem : (forall (Phi : context) (x y : expr), derivable (Union expr Phi (Singleton expr x)) y <-> derivable Phi (impp x y)) := deduction_theorem .
  Definition deduction_theorem_multi_imp : (forall (Phi : context) (xs : list expr) (y : expr), derivable (Union expr Phi (fun x : expr => In x xs)) y <-> derivable Phi (multi_imp xs y)) := deduction_theorem_multi_imp .
  Definition derivable_impp_refl : (forall (Phi : context) (x : expr), derivable Phi (impp x x)) := derivable_impp_refl .
  Definition deduction_left_impp_intros : (forall (Phi : context) (x y : expr), derivable Phi x -> derivable Phi (impp y x)) := deduction_left_impp_intros .
  Definition derivable_modus_ponens : (forall (Phi : context) (x y : expr), derivable Phi (impp x (impp (impp x y) y))) := derivable_modus_ponens .
  Definition deduction_impp_trans : (forall (Phi : context) (x y z : expr), derivable Phi (impp x y) -> derivable Phi (impp y z) -> derivable Phi (impp x z)) := deduction_impp_trans .
  Definition deduction_impp_arg_switch : (forall (Phi : context) (x y z : expr), derivable Phi (impp x (impp y z)) -> derivable Phi (impp y (impp x z))) := deduction_impp_arg_switch .
  Definition provable_proper_impp : (Morphisms.Proper (Morphisms.respectful (fun x y : expr => provable (impp x y)) Basics.impl) provable) := provable_proper_impp .
  Definition impp_proper_impp : (Morphisms.Proper (Morphisms.respectful (Basics.flip (fun x y : expr => provable (impp x y))) (Morphisms.respectful (fun x y : expr => provable (impp x y)) (fun x y : expr => provable (impp x y)))) impp) := impp_proper_impp .
  Definition derivable_proper_impp : (Morphisms.Proper (Morphisms.respectful eq (Morphisms.respectful (fun x y : expr => provable (impp x y)) Basics.impl)) derivable) := derivable_proper_impp .
  Definition impp_curry : (forall x y z : expr, provable (impp (impp x (impp y z)) (impp (andp x y) z))) := impp_curry .
  Definition impp_uncurry : (forall x y z : expr, provable (impp (impp (andp x y) z) (impp x (impp y z)))) := impp_uncurry .
  Definition solve_impp_trans : (forall x y z : expr, provable (impp x y) -> provable (impp y z) -> provable (impp x z)) := solve_impp_trans .
  Definition andp_proper_impp : (Morphisms.Proper (Morphisms.respectful (fun x y : expr => provable (impp x y)) (Morphisms.respectful (fun x y : expr => provable (impp x y)) (fun x y : expr => provable (impp x y)))) andp) := andp_proper_impp .
  Definition cancel_one_succeed : (forall u x y z : expr, provable (impp (sepcon x y) z) -> provable (impp (sepcon (sepcon u x) y) (sepcon u z))) := cancel_one_succeed .
  Definition cancel_one_giveup : (forall x y z w v : expr, provable (impp (sepcon x (sepcon y z)) (sepcon w v)) -> provable (impp (sepcon (sepcon y x) z) (sepcon w v))) := cancel_one_giveup .
  Definition cancel_rev : (forall x y z w : expr, provable (impp (sepcon (sepcon y x) z) w) -> provable (impp (sepcon x (sepcon y z)) w)) := cancel_rev .
  Definition sepcon_proper_impp : (Morphisms.Proper (Morphisms.respectful (fun x y : expr => provable (impp x y)) (Morphisms.respectful (fun x y : expr => provable (impp x y)) (fun x y : expr => provable (impp x y)))) sepcon) := sepcon_proper_impp .
  Definition expr_deep : Set := expr_deep .
  Definition impp_deep : (expr_deep -> expr_deep -> expr_deep) := impp_deep .
  Definition sepcon_deep : (expr_deep -> expr_deep -> expr_deep) := sepcon_deep .
  Definition emp_deep : expr_deep := emp_deep .
  Definition varp_deep : (nat -> expr_deep) := varp_deep .
  Definition var_pos : (expr -> option positive -> tree_pos) := var_pos .
  Definition sepcon_pos : (tree_pos -> tree_pos -> tree_pos) := sepcon_pos .
  Definition cancel_mark : (expr_deep -> expr_deep -> tree_pos -> tree_pos -> tree_pos * tree_pos) := cancel_mark .
  Definition cancel_different : (tree_pos -> tree_pos -> expr) := cancel_different .
  Definition cancel_same : (tree_pos -> tree_pos -> Prop) := cancel_same .
  Definition restore : (tree_pos -> tree_pos -> expr) := restore .
  Existing Instance provable_impp_refl_instance .
  Existing Instance provable_proper_impp .
  Existing Instance impp_proper_impp .
  Existing Instance derivable_proper_impp .
  Existing Instance andp_proper_impp .
  Existing Instance sepcon_proper_impp .
End LogicTheorem.

(*Require Logic.PropositionalLogic.DeepEmbedded.Solver.
Module IPSolver (Names: LanguageSig).
  Import Names.
  Ltac ip_solve :=
    change expr with Base.expr;
    change provable with Base.provable;
    change impp with Syntax.impp;
    change andp with Syntax.andp;
    intros; Solver.SolverSound.ipSolver.
End IPSolver.*)


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

(***
Modulus : 2^189 - 25
Base: 47.25
***)

Definition curve : CurveParameters :=
  {|
    sz := 4%nat;
    base := 47 + 1/4;
    bitwidth := 64;
    s := 2^189;
    c := [(1, 25)];
    carry_chains := Some [seq 0 (pred 4); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    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.


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

(***
Modulus : 2^221 - 3
Base: 24 + 5/9
***)

Definition curve : CurveParameters :=
  {|
    sz := 9%nat;
    base := 24 + 5/9;
    bitwidth := 32;
    s := 2^221;
    c := [(1, 3)];
    carry_chains := Some [seq 0 (pred 9); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    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.


Require Import Coq.Init.Peano.
Require Import Notations.
Require Import Coq.Lists.List.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.omega.Omega.
Require Import Coq.Arith.Le.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Numbers.NatInt.NZMul.
Require Import Coq.Structures.OrdersFacts.
Require Import Coq.ZArith.Znat.
Require Import Coq.QArith.QArith_base.
Require Import  Coq.QArith.QOrderedType.
Require Import QArith_base Equalities Orders OrdersTac.
Require Import Coq.Sorting.Permutation.
Require Import Wf.
Require Import Lexicographic_Product.
Require Import Qreduction.
Require Import Coq.Bool.Bool.
Require Import Inverse_Image.
Require Import Coq.Bool.Sumbool.
Require Import Coq.Sorting.Mergesort.
Import ListNotations.
Require Import Coq.Program.Basics.
Require Import Coq.Arith.Wf_nat.
Require Import Program.
Require Import  Recdef.
(*Add LoadPath "/home/users/u5711205/Downloads/Testing_Modularity/".*)
Require Export Parameters.
Require Import FrameBase.
Require Export Instantiation.
Import Instantiate.
Import M.
Import QSort.

Module AnuUnion.

Section ANUnion.

Definition Union_InitStep (prem :FT_Judgement) (conc :FT_Judgement): Prop :=
 exists ba ba',
  ((prem = (initial  ba)) /\
  (ba' = (Filter ba)) /\
  (conc = state  (ba', [nty], nas, (nbdy, nbdy), emp_elec , all_hopeful))).

Lemma UnionInitStep_SanityCheck_App : SanityCheck_Initial_App Union_InitStep.
Proof.
 unfold SanityCheck_Initial_App.
 intros.
 exists (state (Filter ba, [nty], nas, (nbdy, nbdy), emp_elec, all_hopeful)).
 split. auto.
 unfold Union_InitStep.
 exists ba.
 exists (Filter ba).
 split. assumption.
 split;auto.
Qed.

Lemma UnionInitStep_SanityCheck_Red: SanityCheck_Initial_Red Union_InitStep.
 unfold SanityCheck_Initial_Red.
 intros.
 unfold Union_InitStep in H.
 destruct H as [ba [ba' H1]].
 exists ba. exists ba'. exists [nty]. exists nas. exists (nbdy, nbdy). exists emp_elec. exists all_hopeful.
 split;auto.
 intuition.
 intuition.
Qed.

Definition Union_count (prem: FT_Judgement) (conc: FT_Judgement) : Prop :=
 exists ba t nt p np bl h e,                (** count the ballots requiring attention **)
  prem = state (ba, t, p, bl, e, h) /\     (* if we are in an intermediate state of the count *)
  [] <> ba /\                                        (* and there are ballots requiring attention *)
  (forall c, if (cand_in_dec c (proj1_sig h))
      then
  (exists l,
    np(c) = p(c) ++ [l] /\
    (forall b, In (proj1_sig (fst b)) (map (fun (d:ballot) => (proj1_sig (fst d))) l) <->
                                                               fcc ba (proj1_sig h) c b) /\
    (nt (c) = SUM (np(c))))
      else ((nt c) = (hd nty t) c) /\ (np c) = (p c)) /\
  conc = state ([], nt :: t, np, bl, e, h).

Hypothesis Bl_hopeful_NoIntersect : forall j: FT_Judgement, forall ba t p bl e h, j = state (ba,t,p,bl,e,h) ->
 (forall c, In c (snd bl) -> ~ In c (proj1_sig h)) * (forall c, In c (fst bl) -> ~ In c (snd bl)).

Lemma UnionCount_SanityCheck_App : SanityCheck_Count_App Union_count.
Proof.
 unfold SanityCheck_Count_App.
 intros.
 exists (state ([], (fun (c:cand) =>  if (cand_in_dec c (proj1_sig h)) then SUM (p (c) ++ [list_is_first_hopeful c (proj1_sig h) ba]) else (hd nty t) c) :: t, fun (c:cand) => (if (cand_in_dec c (proj1_sig h)) then (p (c) ++ [list_is_first_hopeful c (proj1_sig h) ba]) else (p c)), bl, e, h)).
 unfold Union_count.
 exists ba.
 exists t.
 exists ((fun (c:cand) =>  if (cand_in_dec c  (proj1_sig h)) then SUM (p (c) ++ [list_is_first_hopeful c (proj1_sig h) ba]) else ((hd nty t) c))).
 exists p.
 exists (fun (c:cand) => (if (cand_in_dec c (proj1_sig h)) then (p (c) ++ [list_is_first_hopeful c (proj1_sig h) ba]) else (p c))).
 exists bl.
 exists h.
 exists e.
 split; auto.
 split; auto.
 split.
 intro c.
 destruct (cand_in_dec c (proj1_sig h)).
 exists (list_is_first_hopeful c (proj1_sig h) ba).
 split; auto.
 split.
 intro b.
 apply (listballot_fcc ba t p bl e h quota c i b).
 simpl.
 destruct (cand_in_dec c (proj1_sig h)). auto.
 contradict n. assumption.
 simpl.
 destruct (cand_in_dec c (proj1_sig h)).
 contradict n. assumption.
 auto. auto.
Qed.

Lemma UnionCount_SanityCheck_Red: SanityCheck_Count_Red Union_count.
 Proof.
 unfold SanityCheck_Count_Red.
 intros.
 unfold Union_count in H.
 destruct H as [ba [t [nt [ p0 [np [bl [h [e H1]]]]]]]].
 destruct H1 as [H11 [H12 [H13 H14]]].
 assert (old_new_pile_equal_bl: forall c, In c (snd bl) -> p0 c = np c).
 specialize (Bl_hopeful_NoIntersect p ba t p0 bl e h H11).
 intros c0  Hyp.
 destruct Bl_hopeful_NoIntersect as [NoIntersect1 NoIntersect2].
 specialize (NoIntersect1 c0 Hyp).
 specialize (H13 c0).
 destruct (cand_in_dec c0 (proj1_sig h)).
 contradict NoIntersect1.
 assumption.
 intuition.
 exists ba; exists ([]: list ballot); exists t. exists nt; exists p0.
 exists np; exists bl; exists e; exists h. split. intuition.
 split; intuition.
 specialize (list_nonempty ballot ba). intro Hyp.
 intuition.
 destruct H as [b [l Hyp1]].
 rewrite Hyp1.
 simpl.
 omega.
 assert (hyp2: forall c, In c (snd bl) -> length (concat (p0 c)) = length (concat (np c))).
 intros.
 specialize (old_new_pile_equal_bl c0 H).
 rewrite old_new_pile_equal_bl.
 reflexivity.
 specialize (map_ext_in (fun c0 => length (concat (p0 c0))) (fun c0 => length (concat (np c0))) (snd bl) hyp2).
 intro.
 rewrite H. auto.
Qed.

Definition Union_hwin (prem: FT_Judgement) (conc: FT_Judgement) : Prop :=
  exists w ba t p bl e h,
   prem = state (ba, t, p, bl, e, h) /\
   length (proj1_sig e) + length (proj1_sig h) <= st /\
   w = (proj1_sig e) ++ (proj1_sig h) /\
   conc = winners (w).

Lemma  UnionHwin_SanityCheck_App : SanityCheck_Hwin_App Union_hwin.
Proof.
 unfold SanityCheck_Hwin_App.
 intros.
 unfold Union_hwin.
 exists (winners ((proj1_sig e) ++ (proj1_sig h))).
 exists ((proj1_sig e) ++ (proj1_sig h)).
 exists ba; exists t; exists p; exists bl; exists e; exists h.
 auto.
Qed.

Lemma UnionHwin_SanityCheck_Red : SanityCheck_Hwin_Red Union_hwin.
Proof.
 unfold SanityCheck_Hwin_Red.
 intros.
 unfold Union_hwin in H.
 destruct H as [w [ba [t [p [bl [e [h H1]]]]]]].
 exists w; exists ba; exists t; exists p; exists bl; exists e; exists h.
 intuition.
Qed.

Definition Union_ewin (prem: FT_Judgement) (conc: FT_Judgement) : Prop :=
  exists w ba t p bl e h,                    (** elected win **)
   prem = state (ba, t, p, bl, e, h) /\   (* if at any time *)
   length (proj1_sig e) = st /\             (* we have as many elected candidates as seats *)
   w = (proj1_sig e) /\                        (* and the winners are precisely the electeds *)
   conc = winners (w).                      (* they are declared the winners *)

Lemma UnionEwin_SanityCheck_App : SanityCheck_Ewin_App Union_ewin.
Proof.
 unfold SanityCheck_Ewin_App.
 intros.
 unfold Union_ewin.
 exists (winners (proj1_sig e)).
 exists (proj1_sig e). exists ba. exists t. exists p. exists bl. exists e. exists h.
 intuition.
Qed.

Lemma UnionEwin_SanityCheck_Red : SanityCheck_Ewin_Red Union_ewin.
Proof.
 unfold SanityCheck_Ewin_Red.
 intros.
 unfold Union_ewin in H.
 destruct H as [w [ba [t [p [bl [e [h H1]]]]]]].
 exists w. exists ba. exists t. exists p. exists bl. exists e. exists h.
 intuition.
 rewrite <- H0.
 assumption.
Qed.

Definition Union_transfer (prem: FT_Judgement) (conc: FT_Judgement) : Prop :=
 exists nba t p np bl nbl h e,         (** transfer votes **)
  prem = state ([], t, p, bl, e, h) /\
    (length (proj1_sig e) < st) /\
    (forall c, In c (proj1_sig h) -> ((hd nty t) c < quota)%Q) /\        (* and we can't elect any candidate *)
    exists l c,                          (* and there exists a list l and a candidate c *)
     (bl = (c :: l, []) /\                     (* such that c is the head of the backlog *)
     nbl = (l, []) /\                          (* and the backlog is updated by removing the head c *)
     nba = flat_map (fun x => x) (p c) /\            (* and the pile of ballots for c is the new list of ballots requiring attention *)
     np(c) = [] /\                                (* and the new pile for c is empty *)
     (forall d, d <> c -> np(d) = p(d))) /\ (* and the piles for every other candidate remain the same *)
   conc = state (nba, t, np, nbl, e, h).

Lemma UnionTransfer_SanityCheck_App : SanityCheck_Transfer1_App Union_transfer.
Proof.
 unfold SanityCheck_Transfer1_App.
 intros.
 unfold Union_transfer.
 destruct H0 as [H01 [H02 H03]].
 specialize (list_nonempty_type cand (fst bl) H02). intro Nonempty_bl.
 destruct Nonempty_bl as [c s].
 destruct s as [bls H3].
 exists (state (flat_map (fun x => x) (p c), t, fun d =>
                                                        if (cand_eq_dec d c) then [] else p d,
                                                        (bls, []), e, h)).
 exists (flat_map (fun x => x) (p c)). exists t. exists p.
 exists (fun d => if (cand_eq_dec d c) then [] else p d). exists (c::bls, ([]: list cand)).
 exists (bls, ([]: list cand)). exists h.
 exists e.
 intuition.
 rewrite H3 in H. assumption.
 exists bls. exists c.
 intuition.
 destruct (cand_eq_dec c c) as [i | j]. reflexivity.
 contradict j. auto.
 destruct (cand_eq_dec d c) as [i | j].
 contradict i. assumption.
 auto.
Qed.

Lemma UnionTransfer_SanityCheck_Red : SanityCheck_Transfer_Red Union_transfer.
 Proof.
 unfold SanityCheck_Transfer_Red.
 intros.
 unfold Union_transfer in H.
 destruct H as [nba [t [p [np [bl [nbl [h [e H1]]]]]]]].
 destruct H1 as [H11 [H12 [H13 H14]]].
 destruct H14 as [l [ c H141]].
 exists nba; exists t; exists p; exists np; exists bl; exists nbl; exists h; exists e.
 intuition.
 left.
 rewrite H1.
 rewrite H.
 simpl.
 omega.
Qed.

Definition Union_elim (prem: FT_Judgement) (conc: FT_Judgement) : Prop :=
  exists nba t p np e h nh bl2,
   prem = state ([], t, p, ([], bl2), e, h) /\
   length (proj1_sig e) + length (proj1_sig h) > st /\
   (forall c, In c (proj1_sig h) -> (hd nty t(c) < quota)%Q) /\
   exists c,
     ((forall d, In d (proj1_sig h) -> (hd nty t(c) <= hd nty t(d)))%Q /\
     eqe c (proj1_sig nh) (proj1_sig h) /\
     nba = flat_map (fun x => x) (p c) /\
     np(c)=[] /\
     (forall d, d <> c -> np (d) = p (d)) /\
   conc = state (nba, t, np, ([], []), e, nh)).

Lemma UnionElim_SanityCheck_App : SanityCheck_Elim_App Union_elim.
Proof.
 unfold SanityCheck_Elim_App.
 intros.
 unfold Union_elim.
 specialize (list_min cand (proj1_sig h) (hd nty t)). intro min_hopeful.
 destruct min_hopeful.
 rewrite e0 in H0.
 destruct H0 as [H01 H02].
 destruct e.
 simpl in H01.
 omega.
 destruct s as [min [s1 s2]].
 specialize (remc_nodup (proj1_sig h) min (proj2_sig h) s1);intro H'1.
 exists (state (flat_map (fun x => x) (p min), t, fun d => if (cand_eq_dec d min) then [] else (p d),
                                                ([], []), e, exist _ (remc min (proj1_sig h)) H'1)).
 exists (flat_map (fun x => x) (p min)).
 exists t. exists p. exists (fun d => if (cand_eq_dec d min) then [] else (p d)). exists e. exists h.
 exists (exist _ (remc min (proj1_sig h)) H'1).
 intuition.
 exists bl2.
 intuition.
 simpl.
 exists min.
 intuition.
 apply (remc_ok min (proj1_sig h) (proj2_sig h) s1).
 destruct (cand_eq_dec min min) as [i | j]. reflexivity.
 contradict j. auto.
 destruct (cand_eq_dec d min) as [i | j]. contradiction i. reflexivity.
Qed.

Lemma UnionElim_SanityCheck_Red : SanityCheck_Elim_Red Union_elim.
 Proof.
 unfold SanityCheck_Elim_Red.
 intros.
 unfold Union_elim in H.
 destruct H as [nba [t [p [np [e [h [nh [bl2 H1]]]]]]]].
 destruct H1 as [H11 [H12 [H13 H14]]].
 destruct H14 as [weakest H141].
 exists nba. exists t. exists p. exists np. exists e. exists h. exists nh.
 intuition.
 unfold eqe in H1.
 destruct H1 as [l1 [l2 [H' [H'' [H''' H'''']]]]].
 rewrite H'.
 rewrite H''.
 assert (Hyp : length (l1 ++ [weakest] ++ l2) = (length l1 + (length ([weakest] ++ l2)))% nat).
 simpl.
 rewrite (app_length).
 simpl. auto.
 rewrite Hyp.
 simpl.
 rewrite (app_length).
 exists bl2.
 exists ([]: list cand).
 intuition.
Qed.

Definition Union_elect (prem: FT_Judgement) (conc: FT_Judgement) : Prop :=
 exists t p np (bl nbl: (list cand) * (list cand)) (nh h: {hopeful: list cand | NoDup hopeful})(e ne: {l : list cand | length l <= st }),
    prem = state ([], t, p, bl, e, h) /\
    exists l,
     (l <> [] /\
     length l <= st - length (proj1_sig e) /\
     (forall c, In c l -> In c (proj1_sig h) /\ (hd nty t (c) >= quota)%Q) /\
     ordered (hd nty t) l /\
     Leqe l (proj1_sig nh) (proj1_sig h) /\
     Leqe l (proj1_sig e) (proj1_sig ne) /\
     (forall c, In c l -> ((np c) = map (map (fun (b : ballot) =>
        (fst b, (Qred (snd b * (Qred ((hd nty t)(c)- quota)/(hd nty t)(c))))%Q))) (p c))) /\
     (forall c, ~ In c l -> np (c) = p (c)) /\
    fst nbl = (fst bl) ++ l) /\
  conc = state ([], t, np, nbl, ne, nh).

Lemma UnionElect_SanityCheck_App : SanityCheck_Elect_App Union_elect.
Proof.
 unfold SanityCheck_Elect_App.
 intros.
 unfold Union_elect.
 specialize (constructing_electable_first).
 intro H1.
  (*I am changing X to H0*)
 destruct H0 as [c [X1 X2]].
 assert (Hyp: length (proj1_sig e) < st).
 omega.
 specialize (H1 e (hd nty t) h quota Hyp (proj2_sig h)).
 destruct H1 as [listElected H11].
 destruct H11 as [H111 [H112 [H113 [H114 H115]]]].
 specialize (Removel_nodup listElected (proj1_sig h) (proj2_sig h)). intro NoDupH.
 assert (Assum: length ((proj1_sig e) ++ listElected) <= st).
 rewrite app_length.
 omega.
 exists (state ([], t, fun c => update_pile p t listElected quota c, ((fst bl) ++ listElected, snd bl),
 exist _ ((proj1_sig e) ++ listElected) Assum, exist _ (Removel listElected (proj1_sig h)) NoDupH)).
 exists t. exists p. exists (fun x => update_pile p t listElected quota x).
 exists bl. exists ((fst bl) ++ listElected, snd bl). exists (exist _ (Removel listElected (proj1_sig h)) NoDupH).
 exists h. exists e. exists (exist (fun v => length v <= st) ((proj1_sig e) ++ listElected) Assum).
 split. auto.
 exists listElected.
 intuition.
 assert (NonEmptyElected: length listElected = 0).
 rewrite H2.
 simpl. reflexivity.
 assert (VacantSeat: length (listElected) < st - (length (proj1_sig e))).
 rewrite app_length in Assum.
 rewrite NonEmptyElected in Assum.
 omega.
 specialize (H115 c).
 intuition.
 rewrite H2 in H3.
 inversion H3.
 simpl.
 unfold Leqe.
 apply Permutation_App.
 apply (nodup_permutation).
 intros candid HypCand.
 specialize (H111 candid HypCand).
 intuition.
 assumption.
 apply (proj2_sig h).
 simpl.
 unfold Leqe.
 apply Permutation_refl.
 unfold update_pile.
 destruct (cand_in_dec c0 listElected) as [i | j].
 trivial.
 contradict j. assumption.
 unfold update_pile.
 destruct (cand_in_dec c0 listElected) as [i |j].
 contradict i.
 assumption.
 auto.
Qed.

Lemma UnionElect_SanityCheck_Red : SanityCheck_Elect_Red Union_elect.
Proof.
 unfold SanityCheck_Elect_Red.
 intros.
 unfold Union_elect in H.
 destruct H as [t [p [np [bl [nbl [nh [h [e [ne H1]]]]]]]]].
 exists t. exists p; exists np. exists bl. exists nbl. exists e. exists ne. exists nh. exists h.
 destruct H1 as [H11 H12].
 destruct H12 as [l H121].
 intuition.
 unfold Leqe in H4.
 specialize (Permutation_length H4). intro Permut_length.
 rewrite Permut_length.
 rewrite  app_length.
 specialize (list_nonempty_type cand l H1). intro X.
 destruct X as [c [l' HX]].
 rewrite HX.
 simpl.
 omega.
 unfold Leqe in H5.
 specialize (Permutation_length H5). intro.
 rewrite H8.
 rewrite app_length.
 specialize (list_nonempty_type cand l H1). intro X.
 destruct X as [c [l' HX]].
 rewrite HX.
 simpl.
 omega.
Qed.

Definition Union_TransferElected2 (prem: FT_Judgement) (conc: FT_Judgement) :=
 exists nba t p np bl nbl h e,
  prem = state ([], t, p, bl, e, h) /\
    (length (proj1_sig e) < st) /\
    (forall c, In c (proj1_sig h) -> ((hd nty t) c < quota)%Q) /\
    exists l c c' l',
     (bl = (c :: l, c'::l') /\
     nbl = (l, l') /\
     nba = concat (p c) /\
     concat (p c') = [] /\
     np(c) = [] /\
     (forall d, d <> c -> np(d) = p(d))) /\
   conc = state (nba, t, np, nbl, e, h).

Lemma UnionTran2_SanityCheck_App : SanityCheck_Transfer2_App Union_TransferElected2.
Proof.
 unfold SanityCheck_Transfer2_App.
 intros.
 unfold Union_TransferElected2.
 destruct H0 as [H1 [H2 [H3 H4]]].
 specialize (list_nonempty_type cand bl1 H2). intro Nonempty_bl.
 destruct Nonempty_bl as [Headbl1 [Tailbl1 bl1None]].

 exists (state (concat (p Headbl1), t, fun x => if (cand_eq_dec x Headbl1) then [] else p x,
                (Tailbl1, bl2), e, h)).
 exists (concat (p Headbl1)).
 exists t. exists p. exists (fun x => if (cand_eq_dec x Headbl1) then [] else (p x)).
 exists (Headbl1:: Tailbl1, c:: bl2). exists (Tailbl1,bl2). exists h. exists e.
 rewrite bl1None in H.
 intuition.
 exists Tailbl1. exists Headbl1. exists c. exists bl2.
 intuition.
 destruct (cand_eq_dec Headbl1 Headbl1) as [i | j].
 reflexivity.
 contradict j.  auto.
 destruct (cand_eq_dec d Headbl1) as [i | j].
 contradict i.
 auto.
 reflexivity.
Qed.

Lemma UnionTran2_SanityCheck_Red : SanityCheck_Transfer_Red Union_TransferElected2.
Proof.
 unfold SanityCheck_Transfer_Red.
 intros.
 unfold Union_TransferElected2 in H.
 destruct H as [nba [t [p [np [bl [nbl [h [e H1]]]]]]]].
 destruct H1 as [H11 [H12 [H13 H14]]].
 destruct H14 as [Tbl1 [Hbl1 [Hbl2 [Tbl2 H15]]]].
 exists nba.
 exists t. exists p. exists np. exists bl. exists nbl. exists h. exists e.
 destruct H15 as [H15 H152].
 destruct H15 as [HH1 HH2].
 destruct HH2 as [HH21 [HH22 [HH23 [HH24 HH25]]]].
 assert (Hypo: forall d, In d Tbl2 -> p (d) = np (d)).
 intros d Hy.
 assert (hypos: d <> Hbl1). intro contHypos. rewrite contHypos in Hy.
 specialize (Bl_hopeful_NoIntersect (state ([],t,p,bl, e,h)) [] t p bl e h (eq_refl)).
 destruct Bl_hopeful_NoIntersect as [i j].
 specialize (j Hbl1).
 rewrite HH1 in j.
 assert (hyu: In Hbl1 (fst (Hbl1:: Tbl1, Hbl2:: Tbl2))).
 simpl. left;auto.
 specialize (j hyu).
 apply j.
 simpl.
 right;assumption.
 specialize (HH25 d hypos).
 auto.
 split.  auto.
 split. left. rewrite HH1. rewrite HH21.
 simpl. rewrite HH23.
 assert (Leneq: forall d, In d Tbl2 -> length (concat (p d)) = length (concat (np d))).
 intros d he.
 specialize (Hypo d he). rewrite Hypo. auto.
 specialize (map_ext_in (fun c => length (concat (p c))) (fun d => length (concat (np d))) Tbl2 Leneq).
 intro map_equal.
 rewrite map_equal.
 simpl.
 omega.
 auto.
Qed.

Definition Union_TransferElim (prem: FT_Judgement) (conc: FT_Judgement) :=
 exists nba t p np bl nbl h e,
  prem = state ([], t, p, bl, e, h) /\
    (length (proj1_sig e) < st) /\
    (forall c, In c (proj1_sig h) -> ((hd nty t) c < quota)%Q) /\
    exists l c c' l',
     (bl = (c :: l, c'::l') /\
     nbl = (c::l, c'::l') /\
      (concat (p c') <> []) /\
      let x:= (groupbysimple _ (sort (concat (p c')))) in
       (nba = last x []) /\
       np c' = (removelast x) /\
     (forall d, d <> c' -> np(d) = p(d))) /\
   conc = state (nba, t, np, nbl, e, h).

Hypothesis Bl_NoDup : forall j: FT_Judgement, forall ba t p bl e h,
  j = state (ba,t,p,bl,e,h) -> NoDup (snd bl).

Lemma Union_TransferElim_SanityCheck_App : SanityCheck_Transfer3_App Union_TransferElim.
Proof.
 unfold SanityCheck_Transfer3_App.
 intros.
 destruct H0 as [H1 [H2 [H3 H4]]].
 unfold Union_TransferElim.
 exists (state (((last (groupbysimple _ (sort (concat (p c)))) []): list ballot),
 t, fun d => if (cand_eq_dec d c) then (removelast (groupbysimple _ (sort (concat (p c))))) else p d, (bl1, c::bl2), e, h)).
 exists (last (groupbysimple _ (sort (concat (p c)))) []).
 exists t. exists p. exists (fun d => if (cand_eq_dec d c)
   then (removelast ((groupbysimple _ (sort (concat (p c))))))  else p d).
 exists (bl1,c::bl2). exists (bl1, c::bl2). exists h. exists e. intuition.
 specialize (list_nonempty_type cand bl1 H2). intro Nbl1.
 destruct Nbl1 as [Hbl1 [Tbl1 bl1N]].
 exists Tbl1. exists Hbl1. exists c. exists bl2.
 rewrite bl1N.
 intuition.
 destruct (cand_eq_dec c c) as [i | j].
 auto. contradict j. reflexivity.
 destruct (cand_eq_dec d c) as [i |j].
 contradiction i. reflexivity.
Qed.

Lemma concat_app : forall (A:Type) (l1: list (list A)) l2, concat (l1 ++ l2) = concat l1 ++ concat l2.
Proof.
  intros.
  induction l1 as [|x l1 IH]. induction l2. simpl.
  reflexivity. simpl. auto.
  simpl. rewrite IH; apply app_assoc.
Qed.

Lemma Union_TransferElim_SanityCheck_Red: SanityCheck_Transfer_Red Union_TransferElim.
Proof.
 unfold SanityCheck_Transfer_Red.
 intros.
 unfold Union_TransferElim in H.
 destruct H as [nba [t [p [np [bl [nbl [h [e H1]]]]]]]].
 destruct H1 as [H11 [H12 [H13 H14]]].
 destruct H14 as [Tbl1 [Hbl1 [Hbl2 [Tbl2 H15]]]].
 destruct H15 as [H151 H152].
 destruct H151 as [K1 K2].
 destruct K2 as [K21 [K22 [K23 [K24 K25]]]].
 exists nba. exists t. exists p. exists np. exists bl. exists nbl. exists h. exists e.
 split. assumption.
 split. right. rewrite K1. rewrite K21. simpl. split. auto.
 assert (Tbl2_NoDup: NoDup (Hbl2 :: Tbl2)).
 specialize (Bl_NoDup (state ([],t,p,bl,e,h)) [] t p bl e h (eq_refl)).
 rewrite K1 in Bl_NoDup.
 simpl in Bl_NoDup.
 assumption.
 assert (Hbl2_notInTail: ~ In Hbl2 Tbl2).
 intro Cont.
 inversion Tbl2_NoDup.
 apply H1. assumption.
 assert (Piles_eq_Tbl2: forall d, In d Tbl2 -> p d = np d).
 intros d InTbl2.
 assert (not_eq_d: d <> Hbl2).
 intro cont. rewrite cont in InTbl2. apply Hbl2_notInTail. assumption.
 specialize (K25 d not_eq_d).
 auto.
 assert (Len_piles_eq: forall d, In d Tbl2 -> length (concat (p d)) = length (concat (np d))).
 intros d Hy.
 specialize (Piles_eq_Tbl2 d Hy).
 rewrite Piles_eq_Tbl2. auto.
 specialize (map_ext_in (fun c => length (concat (p c))) (fun c => length (concat (np c))) Tbl2 Len_piles_eq).
 intro nice.
 rewrite nice.
 rewrite K24.
 assert (Hypo: (groupbysimple _ (sort (concat (p Hbl2)))) <> []).
 apply groupbysimple_not_empty.
 apply sherin.
 auto.
 assert (Hypo2: groupbysimple _ (sort (concat (p Hbl2))) =
(removelast (groupbysimple _ (sort (concat (p Hbl2))))) ++ [last (groupbysimple _ (sort (concat (p Hbl2)))) []]).
 apply app_removelast_last.
 assumption.
 assert (Hypo222: concat (groupbysimple _ (sort (concat (p Hbl2)))) =
                  concat ((removelast (groupbysimple _ (sort (concat (p Hbl2)))))
                            ++
                            [last (groupbysimple _ (sort (concat (p Hbl2)))) []])).
 apply f_equal. assumption.
 rewrite concat_app in Hypo222.

 assert (Hypo22: length (concat (groupbysimple _ (sort (concat (p Hbl2))))) =
 (length (concat (removelast (groupbysimple _ (sort (concat (p Hbl2)))))) +
  length (concat [last (groupbysimple _ (sort (concat (p Hbl2)))) []]))%nat).
 rewrite <- app_length. apply f_equal. auto.
 assert (Hypolen : length
            (concat (groupbysimple {v : list cand | NoDup v /\ [] <> v} (sort (concat (p Hbl2))))) =
                   length (concat (p Hbl2))).
 rewrite <- concat_rat. auto.
 rewrite <- Hypolen.
 rewrite  Hypo22.
 simpl.
 assert (Hlen : forall (A : Type) (l : list A),
            l <> []  -> 0 < length l).
 intros. destruct l. contradiction H. auto. simpl. omega.
 specialize (groupby_notempty _ (sort (concat (p Hbl2)))). intros.
 pose proof (sortedList_notempty (concat (p Hbl2)) K22).
 specialize (H H0).
 specialize (Hlen _ _ H).
 rewrite app_nil_r.
 apply Nat.add_lt_mono_r.
 apply NPeano.Nat.lt_add_pos_r. trivial.
 auto.
Qed.

Variable bs: list ballot.

Definition UnionSTV := (mkSTV (quota)
    (Union_InitStep) (UnionInitStep_SanityCheck_App) (UnionInitStep_SanityCheck_Red)
    (Union_count) (UnionCount_SanityCheck_App) (UnionCount_SanityCheck_Red)
    (Union_transfer) (UnionTransfer_SanityCheck_App) (UnionTransfer_SanityCheck_Red)
    (Union_TransferElected2) (UnionTran2_SanityCheck_App) (UnionTran2_SanityCheck_Red)
    (Union_TransferElim) (Union_TransferElim_SanityCheck_App) (Union_TransferElim_SanityCheck_Red)
    (Union_elect) (UnionElect_SanityCheck_App) (UnionElect_SanityCheck_Red)
    (Union_elim) (UnionElim_SanityCheck_App) (UnionElim_SanityCheck_Red)
    (Union_hwin) (UnionHwin_SanityCheck_App) (UnionHwin_SanityCheck_Red)
    (Union_ewin) (UnionEwin_SanityCheck_App) (UnionEwin_SanityCheck_Red)).

Lemma init_stages_R_initial : ~ FT_final (initial (Filter bs)).
Proof.
 intro.
 unfold FT_final in H.
 destruct H.
 inversion H.
Qed.

Definition Union_Termination := M.Termination bs (initial (Filter bs)) init_stages_R_initial UnionSTV.

End ANUnion.

Extraction Language Haskell.
Extraction "Anu.hs" Union_Termination.

End AnuUnion.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C T P0 X Y : Universe, ((wd_ A B /\ (wd_ C B /\ (wd_ T B /\ (wd_ A C /\ (wd_ P0 B /\ (wd_ P0 A /\ (wd_ Y B /\ (wd_ X B /\ (wd_ X Y /\ (wd_ T X /\ (wd_ T Y /\ (wd_ A Y /\ (col_ X T Y /\ (col_ B C T /\ (col_ B C X /\ (col_ B C Y /\ col_ B A X)))))))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.