(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2015 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

Require Import Reals mathcomp.ssreflect.ssreflect.
Require Import Rcomplements Rbar.
Require Import Continuity Derive Hierarchy.

(** This file defines complex numbers [C] as [R * R]. Operations are
given, and [C] is proved to be a field, a normed module, and a
complete space. *)

(** * The set of complex numbers *)

Definition C := (R * R)%type.

Definition RtoC (x : R) : C := (x,0).
Coercion RtoC : R >-> C.

Lemma RtoC_inj : forall (x y : R),
  RtoC x = RtoC y -> x = y.
Proof.
  intros x y H.
  now apply (f_equal (@fst R R)) in H.
Qed.

Lemma Ceq_dec (z1 z2 : C) : { z1 = z2 } + { z1 <> z2 }.
Proof.
  destruct z1 as [x1 y1].
  destruct z2 as [x2 y2].
  case: (Req_EM_T x1 x2) => [ -> | Hx ].
  case: (Req_EM_T y1 y2) => [ -> | Hy ].
  by left.
  right ; contradict Hy.
  now apply (f_equal (@snd R R)) in Hy ; simpl in Hy.
  right ; contradict Hx.
  now apply (f_equal (@fst R R)) in Hx ; simpl in Hx.
Qed.

(** ** Constants and usual functions *)

(** 0 and 1 for complex are defined as [RtoC 0] and [RtoC 1] *)
Definition Ci : C := (0,1).

(** *** Arithmetic operations *)

Definition Cplus (x y : C) : C := (fst x + fst y, snd x + snd y).
Definition Copp (x : C) : C := (-fst x, -snd x).
Definition Cminus (x y : C) : C := Cplus x (Copp y).
Definition Cmult (x y : C) : C := (fst x * fst y - snd x * snd y, fst x * snd y + snd x * fst y).
Definition Cinv (x : C) : C := (fst x / (fst x ^ 2 + snd x ^ 2), - snd x / (fst x ^ 2 + snd x ^ 2)).
Definition Cdiv (x y : C) : C := Cmult x (Cinv y).

Delimit Scope C_scope with C.
Local Open Scope C_scope.

Infix "+" := Cplus : C_scope.
Notation "- x" := (Copp x) : C_scope.
Infix "-" := Cminus : C_scope.
Infix "*" := Cmult : C_scope.
Notation "/ x" := (Cinv x) : C_scope.
Infix "/" := Cdiv : C_scope.

(** *** Other usual functions *)

Definition Re (z : C) : R := fst z.

Definition Im (z : C) : R := snd z.

Definition Cmod (x : C) : R := sqrt (fst x ^ 2 + snd x ^ 2).

Definition Cconj (x : C) : C := (fst x, (- snd x)%R).

Lemma Cmod_0 : Cmod 0 = 0.
Proof.
unfold Cmod.
simpl.
rewrite Rmult_0_l Rplus_0_l.
apply sqrt_0.
Qed.
Lemma Cmod_1 : Cmod 1 = 1.
Proof.
unfold Cmod.
simpl.
rewrite Rmult_0_l Rplus_0_r 2!Rmult_1_l.
apply sqrt_1.
Qed.

Lemma Cmod_opp : forall x, Cmod (-x) = Cmod x.
Proof.
unfold Cmod.
simpl.
intros x.
apply f_equal.
ring.
Qed.

Lemma Cmod_triangle : forall x y, Cmod (x + y) <= Cmod x + Cmod y.
Proof.
  intros x y ; rewrite /Cmod.
  apply Rsqr_incr_0_var.
  apply Rminus_le_0.
  unfold Rsqr ; simpl ; ring_simplify.
  rewrite /pow ?Rmult_1_r.
  rewrite ?sqrt_sqrt ; ring_simplify.
  replace (-2 * fst x * fst y - 2 * snd x * snd y)%R with (- (2 * (fst x * fst y + snd x * snd y)))%R by ring.
  rewrite Rmult_assoc -sqrt_mult.
  rewrite Rplus_comm.
  apply -> Rminus_le_0.
  apply Rmult_le_compat_l.
  apply Rlt_le, Rlt_0_2.
  apply Rsqr_incr_0_var.
  apply Rminus_le_0.
  rewrite /Rsqr ?sqrt_sqrt ; ring_simplify.
  replace (fst x ^ 2 * snd y ^ 2 - 2 * fst x * snd x * fst y * snd y +
    snd x ^ 2 * fst y ^ 2)%R with ( (fst x * snd y - snd x * fst y)^2)%R
    by ring.
  apply pow2_ge_0.
  repeat apply Rplus_le_le_0_compat ; apply Rmult_le_pos ; apply pow2_ge_0.
  apply sqrt_pos.
  apply Rplus_le_le_0_compat ; apply Rle_0_sqr.
  apply Rplus_le_le_0_compat ; apply Rle_0_sqr.
  replace (fst x ^ 2 + 2 * fst x * fst y + fst y ^ 2 + snd x ^ 2 + 2 * snd x * snd y + snd y ^ 2)%R
    with ((fst x + fst y)^2 + (snd x + snd y)^2)%R by ring.
  apply Rplus_le_le_0_compat ; apply pow2_ge_0.
  apply Rplus_le_le_0_compat ; apply pow2_ge_0.
  apply Rplus_le_le_0_compat ; apply pow2_ge_0.
  apply Rplus_le_le_0_compat ; apply sqrt_pos.
Qed.

Lemma Cmod_mult : forall x y, Cmod (x * y) = (Cmod x * Cmod y)%R.
Proof.
  intros x y.
  unfold Cmod.
  rewrite -sqrt_mult.
  apply f_equal ; simpl ; ring.
  apply Rplus_le_le_0_compat ; apply pow2_ge_0.
  apply Rplus_le_le_0_compat ; apply pow2_ge_0.
Qed.

Lemma Rmax_Cmod : forall x,
  Rmax (Rabs (fst x)) (Rabs (snd x)) <= Cmod x.
Proof.
  case => x y /=.
  rewrite -!sqrt_Rsqr_abs.
  apply Rmax_case ; apply sqrt_le_1_alt, Rminus_le_0 ;
  rewrite /Rsqr /= ; ring_simplify ; by apply pow2_ge_0.
Qed.
Lemma Cmod_2Rmax : forall x,
  Cmod x <= sqrt 2 * Rmax (Rabs (fst x)) (Rabs (snd x)).
Proof.
  case => x y /= ; apply Rmax_case_strong => H0 ;
  rewrite -!sqrt_Rsqr_abs ;
  rewrite -?sqrt_mult ;
  try (by apply Rle_0_sqr) ;
  try (by apply Rlt_le, Rlt_0_2) ;
  apply sqrt_le_1_alt ; simpl ; [ rewrite Rplus_comm | ] ;
  rewrite /Rsqr ; apply Rle_minus_r ; ring_simplify ;
  apply Rsqr_le_abs_1 in H0 ; by rewrite /pow !Rmult_1_r.
Qed.

(** ** C is a field *)

Lemma RtoC_plus (x y : R) :
  RtoC (x + y) = RtoC x + RtoC y.
Proof.
  unfold RtoC, Cplus ; simpl.
  by rewrite Rplus_0_r.
Qed.
Lemma RtoC_opp (x : R) :
  RtoC (- x) = - RtoC x.
Proof.
  unfold RtoC, Copp ; simpl.
  by rewrite Ropp_0.
Qed.
Lemma RtoC_minus (x y : R) :
  RtoC (x - y) = RtoC x - RtoC y.
Proof.
  by rewrite /Cminus -RtoC_opp -RtoC_plus.
Qed.
Lemma RtoC_mult (x y : R) :
  RtoC (x * y) = RtoC x * RtoC y.
Proof.
  unfold RtoC, Cmult ; simpl.
  apply injective_projections ; simpl ; ring.
Qed.
Lemma RtoC_inv (x : R) : (x <> 0)%R -> RtoC (/ x) = / RtoC x.
Proof.
  intros Hx.
  by apply injective_projections ; simpl ; field.
Qed.
Lemma RtoC_div (x y : R) : (y <> 0)%R -> RtoC (x / y) = RtoC x / RtoC y.
Proof.
  intros Hy.
  by apply injective_projections ; simpl ; field.
Qed.

Lemma Cplus_comm (x y : C) : x + y = y + x.
Proof.
  apply injective_projections ; simpl ; apply Rplus_comm.
Qed.
Lemma Cplus_assoc (x y z : C) : x + (y + z) = (x + y) + z.
Proof.
  apply injective_projections ; simpl ; apply sym_eq, Rplus_assoc.
Qed.
Lemma Cplus_0_r (x : C) : x + 0 = x.
Proof.
  apply injective_projections ; simpl ; apply Rplus_0_r.
Qed.
Lemma Cplus_0_l (x : C) : 0 + x = x.
Proof.
  apply injective_projections ; simpl ; apply Rplus_0_l.
Qed.
Lemma Cplus_opp_r (x : C) : x + -x = 0.
Proof.
  apply injective_projections ; simpl ; apply Rplus_opp_r.
Qed.

Lemma Copp_plus_distr (z1 z2 : C) : - (z1 + z2) = (- z1 + - z2).
Proof.
  apply injective_projections ; by apply Ropp_plus_distr.
Qed.
Lemma Copp_minus_distr (z1 z2 : C) : - (z1 - z2) = z2 - z1.
Proof.
  apply injective_projections ; by apply Ropp_minus_distr.
Qed.

Lemma Cmult_comm (x y : C) : x * y = y * x.
Proof.
  apply injective_projections ; simpl ; ring.
Qed.
Lemma Cmult_assoc (x y z : C) : x * (y * z) = (x * y) * z.
Proof.
  apply injective_projections ; simpl ; ring.
Qed.
Lemma Cmult_0_r (x : C) : x * 0 = 0.
Proof.
  apply injective_projections ; simpl ; ring.
Qed.
Lemma Cmult_0_l (x : C) : 0 * x = 0.
Proof.
  apply injective_projections ; simpl ; ring.
Qed.
Lemma Cmult_1_r (x : C) : x * 1 = x.
Proof.
  apply injective_projections ; simpl ; ring.
Qed.
Lemma Cmult_1_l (x : C) : 1 * x = x.
Proof.
  apply injective_projections ; simpl ; ring.
Qed.

Lemma Cinv_r (r : C) : r <> 0 -> r * /r = 1.
Proof.
  move => H.
  apply injective_projections ; simpl ; field.
  contradict H.
  apply Rplus_sqr_eq_0 in H.
  apply injective_projections ; simpl ; by apply H.
  contradict H.
  apply Rplus_sqr_eq_0 in H.
  apply injective_projections ; simpl ; by apply H.
Qed.

Lemma Cinv_l (r : C) : r <> 0 -> /r * r = 1.
Proof.
intros Zr.
rewrite Cmult_comm.
now apply Cinv_r.
Qed.

Lemma Cmult_plus_distr_l (x y z : C) : x * (y + z) = x * y + x * z.
Proof.
  apply injective_projections ; simpl ; ring.
Qed.

Lemma Cmult_plus_distr_r (x y z : C) : (x + y) * z = x * z + y * z.
Proof.
  apply injective_projections ; simpl ; ring.
Qed.

Definition C_AbelianGroup_mixin :=
  AbelianGroup.Mixin _ _ _ _ Cplus_comm Cplus_assoc Cplus_0_r Cplus_opp_r.

Canonical C_AbelianGroup :=
  AbelianGroup.Pack C C_AbelianGroup_mixin C.

Lemma Copp_0 : Copp 0 = 0.
Proof.
  apply: opp_zero.
Qed.

Definition C_Ring_mixin :=
  Ring.Mixin _ _ _ Cmult_assoc Cmult_1_r Cmult_1_l Cmult_plus_distr_r Cmult_plus_distr_l.

Canonical C_Ring :=
  Ring.Pack C (Ring.Class _ _ C_Ring_mixin) C.

Lemma Cmod_m1 :
  Cmod (Copp 1) = 1.
Proof.
rewrite Cmod_opp.
apply Cmod_1.
Qed.

Lemma Cmod_eq_0 :
  forall x, Cmod x = 0 -> x = 0.
Proof.
intros x H.
unfold Cmod, pow in H.
rewrite 2!Rmult_1_r -sqrt_0 in H.
apply sqrt_inj in H.
apply Rplus_sqr_eq_0 in H.
now apply injective_projections.
apply Rplus_le_le_0_compat ; apply Rle_0_sqr.
apply Rle_refl.
Qed.

Definition C_AbsRing_mixin :=
  AbsRing.Mixin _ _ Cmod_0 Cmod_m1 Cmod_triangle (fun x y => Req_le _ _ (Cmod_mult x y)) Cmod_eq_0.

Canonical C_AbsRing :=
  AbsRing.Pack C (AbsRing.Class _ _ C_AbsRing_mixin) C.

Lemma Cmod_ge_0 :
  forall x, 0 <= Cmod x.
Proof.
intros x.
apply sqrt_pos.
Qed.
Lemma Cmod_gt_0 :
  forall (x : C), x <> 0 <-> 0 < Cmod x.
Proof.
intros x ; split => Hx.
destruct (Cmod_ge_0 x) => //.
by apply sym_eq, Cmod_eq_0 in H.
contradict Hx.
apply Rle_not_lt, Req_le.
by rewrite Hx Cmod_0.
Qed.

Lemma Cmod_norm :
  forall x : C, Cmod x = (@norm R_AbsRing _ x).
Proof.
intros [u v].
unfold Cmod.
simpl.
apply (f_equal2 (fun x y => sqrt (x + y))) ;
  rewrite /norm /= !Rmult_1_r ;
  apply Rsqr_abs.
Qed.

Lemma Cmod_R :
  forall x : R, Cmod x = Rabs x.
Proof.
intros x.
unfold Cmod.
simpl.
rewrite Rmult_0_l Rplus_0_r Rmult_1_r.
apply sqrt_Rsqr_abs.
Qed.

Lemma Cmod_inv :
  forall x : C, x <> 0 -> Cmod (/ x) = Rinv (Cmod x).
Proof.
intros x Zx.
apply Rmult_eq_reg_l with (Cmod x).
rewrite -Cmod_mult.
rewrite Rinv_r.
rewrite Cinv_r.
rewrite Cmod_R.
apply Rabs_R1.
exact Zx.
contradict Zx.
now apply Cmod_eq_0.
contradict Zx.
now apply Cmod_eq_0.
Qed.

Lemma Cmod_div (x y : C) : y <> 0 ->
  Cmod (x / y) = Rdiv (Cmod x) (Cmod y).
Proof.
  move => Hy.
  rewrite /Cdiv.
  rewrite Cmod_mult.
  by rewrite Cmod_inv.
Qed.

Lemma Cmult_neq_0 (z1 z2 : C) : z1 <> 0 -> z2 <> 0 -> z1 * z2 <> 0.
Proof.
  intros Hz1 Hz2 => Hz.
  assert (Cmod (z1 * z2) = 0).
  by rewrite Hz Cmod_0.
  rewrite Cmod_mult in H.
  apply Rmult_integral in H ; destruct H.
  now apply Hz1, Cmod_eq_0.
  now apply Hz2, Cmod_eq_0.
Qed.

Lemma Cminus_eq_contra : forall r1 r2 : C, r1 <> r2 -> r1 - r2 <> 0.
Proof.
  intros ; contradict H ; apply injective_projections ;
  apply Rminus_diag_uniq.
  now apply (f_equal (@fst R R)) in H.
  now apply (f_equal (@snd R R)) in H.
Qed.

Lemma C_field_theory : field_theory (RtoC 0) (RtoC 1) Cplus Cmult Cminus Copp Cdiv Cinv eq.
Proof.
constructor.
constructor.
exact Cplus_0_l.
exact Cplus_comm.
exact Cplus_assoc.
exact Cmult_1_l.
exact Cmult_comm.
exact Cmult_assoc.
exact Cmult_plus_distr_r.
easy.
exact Cplus_opp_r.
intros H.
injection H.
exact R1_neq_R0.
easy.
apply Cinv_l.
Qed.

Add Field C_field_field : C_field_theory.

(** * C is a NormedModule *)

Canonical C_UniformSpace :=
  UniformSpace.Pack C (UniformSpace.class (prod_UniformSpace _ _)) C.

(** on C (with the balls of R^2) *)

Canonical C_ModuleSpace :=
  ModuleSpace.Pack C_Ring C (ModuleSpace.class _ (Ring_ModuleSpace C_Ring)) C.

Canonical C_NormedModuleAux :=
  NormedModuleAux.Pack C_AbsRing C (NormedModuleAux.Class C_AbsRing _ (ModuleSpace.class _ C_ModuleSpace) (UniformSpace.class C_UniformSpace)) C.

Lemma C_NormedModule_mixin_compat1 :
  forall (x y : C) (eps : R),
  Cmod (minus y x) < eps -> ball x eps y.
Proof.
  intros x y eps.
  rewrite Cmod_norm.
  apply: prod_norm_compat1.
Qed.

Lemma C_NormedModule_mixin_compat2 :
  forall (x y : C_NormedModuleAux) (eps : posreal),
  ball x eps y -> Cmod (minus y x) < sqrt 2 * eps.
Proof.
  intros x y eps H.
  rewrite Cmod_norm.
  replace (sqrt 2) with (sqrt 2 * Rmax 1 1)%R.
  apply: prod_norm_compat2 H.
  rewrite -> Rmax_left by apply Rle_refl.
  apply Rmult_1_r.
Qed.

Definition C_NormedModule_mixin :=
  NormedModule.Mixin _ C_NormedModuleAux _ _ Cmod_triangle (fun x y => Req_le _ _ (Cmod_mult x y))
    C_NormedModule_mixin_compat1 C_NormedModule_mixin_compat2 Cmod_eq_0.

Canonical C_NormedModule :=
  NormedModule.Pack C_AbsRing C (NormedModule.Class _ _ _ C_NormedModule_mixin) C.

(** on R *)

Canonical C_R_ModuleSpace :=
  ModuleSpace.Pack R_Ring C (ModuleSpace.class _ (prod_ModuleSpace R_Ring R_ModuleSpace R_ModuleSpace)) C.

Canonical C_R_NormedModuleAux :=
  NormedModuleAux.Pack R_AbsRing C (NormedModuleAux.Class R_AbsRing _ (ModuleSpace.class _ C_R_ModuleSpace) (UniformSpace.class _)) C.

Canonical C_R_NormedModule :=
  NormedModule.Pack R_AbsRing C (NormedModule.class _ (prod_NormedModule _ _ _)) C.

Lemma scal_R_Cmult :
  forall (x : R) (y : C),
  scal (V := C_R_ModuleSpace) x y = Cmult x y.
Proof.
intros x y.
apply injective_projections ;
  rewrite /scal /= /scal /= /mult /= ; ring.
Qed.

(** * C is a CompleteSpace *)

Definition C_complete_lim (F : (C -> Prop) -> Prop) :=
  (R_complete_lim (fun P => F (fun z => P (Re z))), R_complete_lim (fun P => F (fun z => P (Im z)))).

Lemma C_complete_ax1 :
  forall F : (C -> Prop) -> Prop,
  ProperFilter F ->
  (forall eps : posreal, exists x : C, F (ball x eps)) ->
  forall eps : posreal, F (ball (C_complete_lim F) eps).
Proof.
  intros.
  apply filter_and ; simpl ; revert eps.
  apply (R_complete (fun P => F (fun z => P (Re z)))).
  split ; intros.
  destruct (filter_ex _ H1).
  by exists (Re x).
  split.
  by apply filter_true.
  intros ; by apply filter_and.
  intros ; eapply filter_imp, H2.
  intros ; by apply H1.
  intros ; destruct (H0 eps).
  exists (Re x).
  move: H1 ; apply filter_imp.
  intros ; by apply H1.
  apply (R_complete (fun P => F (fun z => P (Im z)))).
  split ; intros.
  destruct (filter_ex _ H1).
  by exists (Im x).
  split.
  by apply filter_true.
  intros ; by apply filter_and.
  intros ; eapply filter_imp, H2.
  intros ; by apply H1.
  intros ; destruct (H0 eps).
  exists (Im x).
  move: H1 ; apply filter_imp.
  intros ; by apply H1.
Qed.

Lemma C_complete_ax2 :
  forall F1 F2 : (C -> Prop) -> Prop,
  filter_le F1 F2 ->
  filter_le F2 F1 ->
  close (C_complete_lim F1) (C_complete_lim F2).
Proof.
intros F1 F2 H12 H21 eps.
split ; apply R_complete_close ; intros P.
apply H12.
apply H21.
apply H12.
apply H21.
Qed.

Definition C_CompleteSpace_mixin :=
  CompleteSpace.Mixin _ C_complete_lim C_complete_ax1 C_complete_ax2.

(* on C *)

Canonical C_CompleteNormedModule :=
  CompleteNormedModule.Pack _ C (CompleteNormedModule.Class C_AbsRing _ (NormedModule.class _ C_NormedModule) C_CompleteSpace_mixin) C.

(* on R *)

Canonical C_R_CompleteNormedModule :=
  CompleteNormedModule.Pack _ C (CompleteNormedModule.Class R_AbsRing _ (NormedModule.class _ C_R_NormedModule) C_CompleteSpace_mixin) C.

(** * Locally compat *)

Lemma locally_C x P :
  locally (T := C_UniformSpace) x P <-> locally (T := AbsRing_UniformSpace C_AbsRing) x P.
Proof.
  split => [[e He] | [e He]].
  - exists e => /= y Hy.
    apply He.
    split.
    eapply Rle_lt_trans, Hy.
    eapply Rle_trans, Rmax_Cmod.
    apply Rmax_l.
    eapply Rle_lt_trans, Hy.
    eapply Rle_trans, Rmax_Cmod.
    apply Rmax_r.
  - assert (Hd : 0 < e / sqrt 2).
    apply Rdiv_lt_0_compat.
    by apply e.
    apply Rlt_sqrt2_0.
    exists (mkposreal _ Hd) => /= y [Hy1 Hy2].
    apply He.
    eapply Rle_lt_trans.
    apply Cmod_2Rmax.
    rewrite Rmult_comm ; apply Rlt_div_r.
    apply Rlt_sqrt2_0.
    apply Rmax_case.
    by apply Hy1.
    by apply Hy2.
Qed.

(** * Limits *)

Definition C_lim (f : C -> C) (z : C) : C :=
  (real (Lim (fun x => fst (f (x, snd z))) (fst z)),
  real (Lim (fun x => snd (f (x, snd z))) (fst z))).

Lemma is_C_lim_unique (f : C -> C) (z l : C) :
  filterlim f (locally' z) (locally l) -> C_lim f z = l.
Proof.
  case: l => lx ly H.
  apply injective_projections ; simpl.

  apply (f_equal real (y := Finite lx)).
  apply is_lim_unique => /= P [eps Hp].
  destruct (H (fun z => P (fst z))) as [delta Hd] ; clear H.
  exists eps => y Hy.
  apply Hp, Hy.
  exists delta.
  intros y By Hy.
  apply Hd.
  split ; simpl.
  apply By.
  apply ball_center.
  contradict Hy.
  clear -Hy.
  destruct z as [z1 z2].
  now injection Hy.

  apply (f_equal real (y := Finite ly)).
  apply is_lim_unique => /= P [eps Hp].
  destruct (H (fun z => P (snd z))) as [delta Hd] ; clear H.
  exists eps => y Hy.
  apply Hp.
  apply Hy.
  exists delta.
  intros y By Hy.
  apply Hd.
  split ; simpl.
  apply By.
  apply ball_center.
  contradict Hy.
  clear -Hy.
  destruct z as [z1 z2].
  now injection Hy.
Qed.

(** * Derivatives *)

Definition C_derive (f : C -> C) (z : C) := C_lim (fun x => (f x - f z) / (x - z)) z.

Lemma is_C_derive_unique (f : C -> C) (z l : C) :
  is_derive f z l -> C_derive f z = l.
Proof.
  intros [_ Df].
  specialize (Df _ (fun P H => H)).
  apply is_C_lim_unique.
  intros P HP.
  destruct HP as [eps HP].
  destruct (Df (pos_div_2 eps)) as [eps' Df'].
  unfold filtermap, locally', within.

  apply locally_C.
  exists eps'.
  intros y Hy Hyz.
  apply HP.
  assert (y - z <> 0).
  contradict Hyz.
  replace y with (y - z + z) by ring.
  rewrite Hyz.
  apply Cplus_0_l.
  apply: norm_compat1.
  rewrite /minus /plus /opp /=.
  replace ((f y - f z) / (y - z) + - l) with
    ((f y + - f z + - ((y + - z) * l)) / (y + - z)).
  2: by field.
  rewrite /norm /= Cmod_div => //.
  apply Rlt_div_l.
  by apply Cmod_gt_0.
  eapply Rle_lt_trans.
  apply (Df' y Hy).
  simpl.
  rewrite /Rdiv Rmult_assoc.
  apply Rmult_lt_compat_l.
  by apply eps.
  rewrite Rmult_comm Rlt_div_l.
  rewrite /norm /minus /plus /opp /= /abs /=.
  apply Rminus_lt_0 ; ring_simplify.
  by apply Cmod_gt_0.
  by apply Rlt_0_2.
Qed.
Lemma C_derive_correct (f : C -> C) (z l : C) :
  ex_derive f z -> is_derive f z (C_derive f z).
Proof.
  case => df Hf.
  replace (C_derive f z) with df => //.
  by apply sym_eq, is_C_derive_unique.
Qed.


Section ml.
Theorem Dm_exn: forall A:Set -> Prop,
(exists x:Set, ~ A x) -> (~ forall x:Set, A x).
Proof.
intro f.
intro h0.
intro h1.
case h0.
intro g.
intro nfg.
apply nfg.
apply h1.
Qed.
End ml.

Check Dm_exn.


(*
  Ported from Basho's riak_core vclock module.
  https://github.com/basho/riak_core/blob/develop/src/vclock.erl

  Christopher Meiklejohn, 10/06/2013
  christopher.meiklejohn@gmail.com
*)

Require Import Coq.FSets.FMaps.
Require Import Coq.FSets.FSets.
Require Import Coq.Arith.Arith.
Require Import Coq.Structures.OrdersEx.
Require Import Coq.MSets.MSetList.

Module UOT_to_OrderedTypeLegacy (UOT:OrderedType) <:
  (IsEqOrig UOT) <: OrderedType.OrderedType.

  Definition t := UOT.t.
  Definition lt := UOT.lt.
  Definition eq := UOT.eq.
  Definition eq_refl := let (r, _, _) := UOT.eq_equiv in r.
  Definition eq_sym := let (_, s, _) := UOT.eq_equiv in s.
  Definition eq_trans := let (_, _, t) := UOT.eq_equiv in t.

  Lemma lt_trans : forall x y z : t, UOT.lt x y -> UOT.lt y z -> UOT.lt x z.
  Proof. destruct UOT.lt_strorder as [i t]. apply t. Qed.

  Lemma lt_not_eq : forall x y : t, UOT.lt x y -> ~ UOT.eq x y.
  Proof. destruct UOT.lt_strorder as [i t]. intros. intro. rewrite H0 in *.
         exact (i y H). Qed.

  Definition compare (x y : t) : OrderedType.Compare UOT.lt UOT.eq x y :=
    match (CompareSpec2Type (UOT.compare_spec x y)) with
      | CompLtT l => OrderedType.LT l
      | CompEqT e => OrderedType.EQ e
      | CompGtT g => OrderedType.GT g
    end.

  Definition eq_dec := UOT.eq_dec.
  Definition eq_equiv := UOT.eq_equiv.
  Definition lt_strorder := UOT.lt_strorder.
  Definition lt_compat := UOT.lt_compat.
End UOT_to_OrderedTypeLegacy.

Module Nat_as_Legacy_OT    := UOT_to_OrderedTypeLegacy (Nat_as_OT).
Module VectorClockMap      := FMapWeakList.Make (Nat_as_Legacy_OT).
Module VectorClockMapFacts := FMapFacts.Facts (VectorClockMap).

Module VClock.

Definition VectorClock := VectorClockMap.t nat.

(*
  % @doc Create a brand new vclock.
  -spec fresh() -> vclock().
  fresh() ->
      [].
*)

Definition VClock_fresh : VectorClock := VectorClockMap.empty nat.

(*
  % @doc Compares two VClocks for equality.
  -spec equal(VClockA :: vclock(), VClockB :: vclock()) -> boolean().
  equal(VA,VB) ->
      lists:sort(VA) =:= lists:sort(VB).
*)
Definition VClock_equal (c1 c2 : VectorClock) :=
  VectorClockMap.equal beq_nat c1 c2.

(*
  % @doc Combine all VClocks in the input list into their least possible
  %      common descendant.
  -spec merge(VClocks :: [vclock()]) -> vclock() | [].
  merge([])             -> [];
  merge([SingleVclock]) -> SingleVclock;
  merge([First|Rest])   -> merge(Rest, lists:keysort(1, First)).

  merge([], NClock) -> NClock;
  merge([AClock|VClocks],NClock) ->
      merge(VClocks, merge(lists:keysort(1, AClock), NClock, [])).

  merge([], [], AccClock) -> lists:reverse(AccClock);
  merge([], Left, AccClock) -> lists:reverse(AccClock, Left);
  merge(Left, [], AccClock) -> lists:reverse(AccClock, Left);
  merge(V=[{Node1,{Ctr1,TS1}=CT1}=NCT1|VClock],
        N=[{Node2,{Ctr2,TS2}=CT2}=NCT2|NClock], AccClock) ->
      if Node1 < Node2 ->
              merge(VClock, N, [NCT1|AccClock]);
         Node1 > Node2 ->
              merge(V, NClock, [NCT2|AccClock]);
         true ->
              ({_Ctr,_TS} = CT) = if Ctr1 > Ctr2 -> CT1;
                                     Ctr1 < Ctr2 -> CT2;
                                     true        -> {Ctr1, erlang:max(TS1,TS2)}
                                  end,
              merge(VClock, NClock, [{Node1,CT}|AccClock])
      end.
*)
Definition Clock_merge (n1 n2 : option nat) :=
  match n1, n2 with
    | None, None => None
    | Some n, None => Some n
    | None, Some n => Some n
    | Some n1', Some n2' => Some (max n1' n2')
  end.

Definition VClock_merge c1 c2 := VectorClockMap.map2 Clock_merge c1 c2.

(*
  % @doc Increment VClock at Node.
  -spec increment(Node :: vclock_node(), VClock :: vclock()) -> vclock().
  increment(Node, VClock) ->
      increment(Node, timestamp(), VClock).

  % @doc Increment VClock at Node.
  -spec increment(Node :: vclock_node(), IncTs :: timestamp(),
                  VClock :: vclock()) -> vclock().
  increment(Node, IncTs, VClock) ->
      {{_Ctr, _TS}=C1,NewV} = case lists:keytake(Node, 1, VClock) of
                                  false ->
                                      {{1, IncTs}, VClock};
                                  {value, {_N, {C, _T}}, ModV} ->
                                      {{C + 1, IncTs}, ModV}
                              end,
      [{Node,C1}|NewV].
*)
Definition VClock_increment actor clocks :=
  match VectorClockMap.find actor clocks with
    | None       =>  VectorClockMap.add actor 1 clocks
    | Some count => (VectorClockMap.add actor (S count) clocks)
  end.

(*
  % @doc Return true if Va is a direct descendant of Vb,
  % else false -- remember, a vclock is its own descendant!
  -spec descends(Va :: vclock()|[], Vb :: vclock()|[]) -> boolean().
  descends(_, []) ->
      % all vclocks descend from the empty vclock
      true;
  descends(Va, Vb) ->
      [{NodeB, {CtrB, _T}}|RestB] = Vb,
      case lists:keyfind(NodeB, 1, Va) of
          false ->
              false;
          {_, {CtrA, _TSA}} ->
              (CtrA >= CtrB) andalso descends(Va,RestB)
          end.
*)
Definition Clock_compare (n1 n2 : option nat) :=
  match n1, n2 with
    | None, None => None
    | Some n, None => Some false
    | None, Some n => Some true
    | Some n1', Some n2' => Some (leb n1' n2')
  end.

Definition Clock_true (n1 n2 : option nat) :=
  match n1, n2 with
    | None, None => None
    | Some n, None => Some true
    | None, Some n => Some true
    | Some n1', Some n2' => Some true
  end.

Definition VClock_descends (c1 c2 : VectorClock) :=
  VectorClockMap.equal eqb
    (VectorClockMap.map2 Clock_compare c2 c1)
    (VectorClockMap.map2 Clock_true c2 c1).

(*
  % @doc Get the timestamp value in a VClock set from Node.
  -spec get_timestamp(Node :: vclock_node(), VClock :: vclock()) ->
    timestamp() | undefined.
  get_timestamp(Node, VClock) ->
      case lists:keyfind(Node, 1, VClock) of
    {_, {_Ctr, TS}} -> TS;
    false           -> undefined
      end.
*)

(*
  % @doc Possibly shrink the size of a vclock, depending on current age and size.
  -spec prune(V::vclock(), Now::integer(), BucketProps::term()) -> vclock().
  prune(V,Now,BucketProps) ->
      %% This sort need to be deterministic, to avoid spurious merge conflicts later.
      %% We achieve this by using the node ID as secondary key.
      SortV = lists:sort(fun({N1,{_,T1}},{N2,{_,T2}}) -> {T1,N1} < {T2,N2} end, V),
      prune_vclock1(SortV,Now,BucketProps).
  % @private
  prune_vclock1(V,Now,BProps) ->
      case length(V) =< get_property(small_vclock, BProps) of
          true -> V;
          false ->
              {_,{_,HeadTime}} = hd(V),
              case (Now - HeadTime) < get_property(young_vclock,BProps) of
                  true -> V;
                  false -> prune_vclock1(V,Now,BProps,HeadTime)
              end
      end.
  % @private
  prune_vclock1(V,Now,BProps,HeadTime) ->
      % has a precondition that V is longer than small and older than young
      case (length(V) > get_property(big_vclock,BProps)) orelse
           ((Now - HeadTime) > get_property(old_vclock,BProps)) of
          true -> prune_vclock1(tl(V),Now,BProps);
          false -> V
      end.
*)

(*
  % @doc Return the list of all nodes that have ever incremented VClock.
  -spec all_nodes(VClock :: vclock()) -> [vclock_node()].
  all_nodes(VClock) ->
      [X || {X,{_,_}} <- VClock].
*)

(*
  get_property(Key, PairList) ->
      case lists:keyfind(Key, 1, PairList) of
        {_Key, Value} ->
          Value;
        false ->
          undefined
      end.
*)

(*
  % @doc Return a timestamp for a vector clock
  -spec timestamp() -> timestamp().
  timestamp() ->
      %% Same as calendar:datetime_to_gregorian_seconds(erlang:universaltime()),
      %% but significantly faster.
      {MegaSeconds, Seconds, _} = os:timestamp(),
      ?SECONDS_FROM_GREGORIAN_BASE_TO_EPOCH + MegaSeconds*1000000 + Seconds.
*)

(*
  % @doc Get the counter value in VClock set from Node.
  -spec get_counter(Node :: vclock_node(), VClock :: vclock()) -> counter().
  get_counter(Node, VClock) ->
      case lists:keyfind(Node, 1, VClock) of
    {_, {Ctr, _TS}} -> Ctr;
    false           -> 0
      end.
*)

Lemma Clock_merge_comm : forall n1 n2,
  Clock_merge n1 n2 = Clock_merge n2 n1.
Proof.
  intros. destruct n1; destruct n2; auto.
  simpl. f_equal. apply Max.max_comm.
Qed.

Lemma Clock_merge_idempotent : forall n1,
  Clock_merge n1 n1 = n1.
Proof.
  intros. destruct n1; auto; simpl.
  f_equal. apply Max.max_idempotent.
Qed.

Lemma Clock_merge_assoc : forall n1 n2 n3,
  Clock_merge n1 (Clock_merge n2 n3) = Clock_merge (Clock_merge n1 n2) n3.
Proof.
  intros. destruct n1; destruct n2; destruct n3; auto.
  unfold Clock_merge. f_equal. apply Max.max_assoc.
Qed.

Lemma Clock_compare_refl : forall x,
  Clock_compare x x = Clock_true x x.
Proof.
  intros; destruct x; auto. unfold Clock_compare. unfold Clock_true.
  destruct n; auto. f_equal. simpl. rewrite leb_correct; auto.
Qed.

Theorem VectorClock_merge_comm : forall c1 c2,
  VClock_equal (VClock_merge c1 c2) (VClock_merge c2 c1) = true.
Proof.
Admitted.

Theorem VectorClock_merge_idempotent : forall clocks,
  VClock_equal (VClock_merge clocks clocks) clocks = true.
Proof.
Admitted.

Theorem VectorClock_merge_assoc : forall c1 c2 c3,
  VClock_equal
    (VClock_merge c1 (VClock_merge c2 c3))
    (VClock_merge (VClock_merge c1 c2) c3) = true.
Proof.
Admitted.

Theorem VectorClock_descends_idempotent : forall clocks,
  VClock_descends clocks clocks = true.
Proof.
Admitted.

Theorem VectorClock_incr_mono : forall clocks actor,
  VClock_descends (VClock_increment actor clocks) clocks = true.
Proof.
Admitted.

Theorem VectorClock_merge_mono : forall c1 c2,
  VClock_descends (VClock_merge c1 c2) c1 = true.
Proof.
Admitted.

End VClock.

Extraction Language CoreErlang.

Recursive Extraction
          VClock.VClock_fresh
          VClock.VClock_equal
          VClock.VClock_merge
          VClock.VClock_descends
          VClock.VClock_increment.


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 O E Eprime AX AY BX BY CX CY AXMBX AYMBY BXMCX BYMCY XProd BXMAX BYMAY CXMAX CYMAY CXMBX CYMBY AXMCX AYMCY L1 L2 L3 : Universe, ((wd_ O AXMBX /\ (wd_ O AYMBY /\ (wd_ O BXMCX /\ (wd_ O BYMCY /\ (wd_ O E /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (col_ O E AX /\ (col_ O E AY /\ (col_ O E BX /\ (col_ O E BY /\ (col_ O E CX /\ (col_ O E CY /\ (col_ O E AXMBX /\ (col_ O E AYMBY /\ (col_ O E BXMCX /\ (col_ O E BYMCY /\ (col_ O E BXMAX /\ (col_ O E BYMAY /\ (col_ O E CXMAX /\ (col_ O E CYMAY /\ (col_ O E CXMBX /\ (col_ O E CYMBY /\ (col_ O E AXMCX /\ (col_ O E AYMCY /\ (col_ O E XProd /\ (col_ O E L1 /\ (col_ O E L2 /\ col_ O E L3)))))))))))))))))))))))))))) -> col_ CX AX BX)).
Proof.
  time tac.
Qed.

End FOFProblem.


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 O E Eprime AX AY BX BY CX CY AXMBX AYMBY BXMCX BYMCY XProd BXMAX BYMAY CXMAX CYMAY CXMBX CYMBY AXMCX AYMCY L1 L2 L3 : Universe, ((wd_ O AXMBX /\ (wd_ O AYMBY /\ (wd_ O BXMCX /\ (wd_ O BYMCY /\ (wd_ O E /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (col_ O E AX /\ (col_ O E AY /\ (col_ O E BX /\ (col_ O E BY /\ (col_ O E CX /\ (col_ O E CY /\ (col_ O E AXMBX /\ (col_ O E AYMBY /\ (col_ O E BXMCX /\ (col_ O E BYMCY /\ (col_ O E BXMAX /\ (col_ O E BYMAY /\ (col_ O E CXMAX /\ (col_ O E CYMAY /\ (col_ O E CXMBX /\ (col_ O E CYMBY /\ (col_ O E AXMCX /\ (col_ O E AYMCY /\ (col_ O E XProd /\ (col_ O E L1 /\ (col_ O E L2 /\ col_ O E L3)))))))))))))))))))))))))))) -> col_ AX BX CX)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import ZArith.

From QuickChick Require Import QuickChick.

Require Import TestingCommon Indist Generation.
Require Import GenerationProofsHelpers.

From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.

(* The old version of the semantics for sequence is preferrable for these proofs *)
Lemma Forall2_combine : forall {A} n (gs : list (G A)) l,
  List.Forall2 (fun y => semGenSize y n) gs l ->
  forall x, List.In x (seq.zip l gs) -> semGenSize (snd x) n (fst x).
Proof.
  move => A size gs l H.
  induction H as [| x y l l' H1 H2 Hforall ].
  + move => x HIn.
    inv HIn.
  + move => [a ga] HIn.
    simpl in *.
    case: HIn => [[]* | HIn]; subst => //=.
    by apply Hforall in HIn; simpl in HIn.
Qed.

Lemma seqzip__Forall2 : forall {A} n (gs : list (G A)) l,
  length l == length gs ->
  (forall x, List.In x (seq.zip l gs) -> semGenSize (snd x) n (fst x)) ->
  List.Forall2 (fun y => semGenSize y n) gs l.
Proof.
  move => A size gs.
  induction gs as [ | g gs IHg].
  + move => l Hlen HIn.
    destruct l.
    - by constructor.
    - inv Hlen.
  + move => l Hlen HIn.
    destruct l.
    - inv Hlen.
    - constructor => //.
      * apply (HIn (a,g)). by left.
      * apply IHg => //=.
        move => x HIn'.
        apply HIn.
        by right.
Qed.

Section Sized.

Variable size : nat.

Lemma existsHighObsLow : forall l obs,
  isHigh l obs -> isHigh H obs.
  move => l obs High.
  destruct l; destruct obs; auto.
Qed.

Lemma gen_from_length_correct: forall l,
  (RandomQC.leq 0 (l-1))%Z ->
  semGenSize (gen_from_length l) size <-->
  (fun z => (Z.le 0 z /\ Z.le z (l-1))).
Proof.
  move => l H' z; split => /=.
  + move => /semChooseSize H.
    apply H in H'; clear H.
    split; move : H' => /andP [/= H1 H2]; by apply Zle_bool_imp_le.
  + move => [H1 H2].
    apply semChooseSize => //=.
    apply/andP.
    split; by apply Zle_imp_le_bool.
Qed.

Lemma gen_from_nat_length_correct: forall l,
  (RandomQC.leq 0 (Z.of_nat l - 1))%Z ->
  semGenSize (gen_from_nat_length l) size <-->
  (fun z => (Z.le 0 z /\ Z.le z ((Z.of_nat l)-1))).
Proof.
  move => l z.
  rewrite /gen_from_nat_length.
  move/(_ (Z.of_nat l)): gen_from_length_correct; apply.
  auto.
Qed.

Lemma gen_BinOpT_correct :
  semGenSize gen_BinOpT size <--> [set: BinOpT].
Proof.
  rewrite /gen_BinOpT /all. move => op.
  split => // _.
  apply semElementsSize.
  case : op; simpl; auto.
  - do 4 right; left; by []. (* I don't know why it doesn't get this *)
Qed.

Lemma gen_label_correct : semGenSize gen_label size <--> [set: Label].
Proof.
  rewrite /gen_label /all => l. split => [|?] //=.
  apply semElementsSize. case l; simpl; by tauto.
Qed.

Lemma gen_high_label_correct (obs : Label) :
  isHigh H obs ->
  semGenSize (gen_high_label obs) size <--> [set l : Label | isHigh l obs].
Proof.
  rewrite /gen_high_label.
  move => High l. split.
  + move => /semElementsSize H.
    destruct obs; destruct l; auto;
    simpl in H;
    try by move: H => [? | [ ? | [ ? | ?]]];
    try by move: H => [? | [ ? | ?]];
    inv H.
  + move => H.
    apply semElementsSize.
    destruct obs; destruct l; auto;
    simpl; try inv H.
    - by left.
    - by right;left.
    - by right;right;left.
    - by left.
    - by right;left.
    - by left.
    - by right; left.
Qed.

Section WithDataLenNonEmpty.

Canonical lab4_eqType := (@LabelEqType.label_eqType Label _).

Variable inf : Info.
Hypothesis data_len_nonempty : data_len inf <> [::].
Hypothesis code_len_correct  : RandomQC.leq Z0 ((code_len inf) - 1)%Z.
Hypothesis data_len_positive : forall mf z, (mf,z) \in (data_len inf) ->
                                            RandomQC.leq Z0 (z-1)%Z.
Hypothesis no_regs_positive : RandomQC.leq Z0 ((Z.of_nat (no_regs inf)) - 1)%Z.
Hypothesis frame_sizes_correct : RandomQC.leq C.min_frame_size C.max_frame_size.
(* PC *)

Definition pc_in_bounds (pc : Ptr_atom) :=
  let '(PAtm z l) := pc in
  (0 <= z <= (code_len inf) - 1)%Z.

Lemma gen_PC_correct:
  semGenSize (gen_PC inf) size <--> [set pc : Ptr_atom | pc_in_bounds pc].
Proof.
  rewrite /gen_PC /smart_gen /smart_gen_label /pc_in_bounds
          semBindSize (eq_bigcupl _ _ gen_label_correct) => pc.
  split.
  + move => [label [_ /semBindSize[z [/gen_from_length_correct H1
                                      /semReturnSize H2]]]].
    apply H1 in code_len_correct.
    by case H2.
  + move: pc => [z l] EqZ.
    exists l; split => //.
    apply semBindSize.
    rewrite /bigcup.
    exists z; split.
    * by apply gen_from_length_correct.
    * by apply semReturnSize.
Qed.

(* FIXME: move this somewhere else *)
Lemma seq_InP (A : eqType) (x : A) (xs : seq A) :
  reflect (seq_In xs x) (x \in xs).
Proof.
elim: xs=> [|x' xs IH] /=; first by constructor.
by rewrite inE; apply/(iffP orP)=> [[/eqP ->|/IH]|[->|/IH]]; auto.
Qed.

(* Pointer *)
Definition valid_pointer (ptr : Pointer) :=
  let '(Ptr mf addr) := ptr in
  (exists len, (mf, len) \in (data_len inf) /\
               (0 <= addr <= len - 1)%Z).

Lemma gen_pointer_correct:
    semGenSize (gen_pointer inf) size <--> valid_pointer.
Proof.
  move => ptr. remember inf as Inf.
  destruct Inf.
  rewrite /gen_pointer /valid_pointer.
  split.
  * move => /semBindSize[[mf z] [/semElementsSize H]].
    destruct data_len.
    - by case data_len_nonempty.
    - move => /semBindSize [addr [/gen_from_length_correct CL]].
      move => /semReturnSize Ret.
      case Ret.
      exists z; split.
      simpl in H; case: H => H; subst; rewrite /= inE; apply/orP; [by left|right].
        by apply/seq_InP.
      apply CL.
      by apply (data_len_positive mf z); apply/seq_InP.
  * case: ptr => mf z.
    destruct data_len as [|x xs] eqn:DL.
    - by case data_len_nonempty.
    - move => [len [HIn EqZ]].
      apply semBindSize.
      exists (mf, len); split.
      + apply semElementsSize.
        subst; simpl in HIn.
        by apply/seq_InP.
      + apply semBindSize.
        exists z; split.
        * apply gen_from_length_correct => //=.
          move: EqZ => [HL HH].
          assert (0 <= len - 1)%Z by (eapply Z.le_trans; eassumption).
          by apply Zle_imp_le_bool.
        * by apply semReturnSize.
Qed.

(* Int *)
Definition int_spec (z : Z) : Prop :=
  (- Z.of_nat size <= z <= Z.max (Z.of_nat size) (code_len inf - 1))%Z.

Lemma gen_int_correct :
  semGenSize (gen_int inf) size <--> int_spec.
move => z.
split.
+ move => /semFrequencySize /= [[freq g] [H1 H2]].
  case: H1 => [[] * | [[] * | [[] * | //]]]; subst.
  - move: H2 => /arbInt_correct [? ?].
    split; [ omega | ].
    eapply Z.le_trans; eauto.
    by apply Z.le_max_l.
  - move: H2 => /semReturnSize /= H; case H.
    split; [ omega | ].
    eapply (Z.le_trans _ (Z.of_nat size) _); [ omega | ].
    by apply Z.le_max_l.
  - move: H2 => /gen_from_length_correct H.
    apply H in code_len_correct.
    split; [ omega | ];
    eapply (Z.le_trans _ (code_len inf - 1) _); [ omega | ].
    by apply Z.le_max_r.
+ move => [ZMin ZMax].
  apply semFrequencySize => /=.
  case (Z_lt_le_dec z 0) => ZLt0.
  - eexists; split.
    * by left.
    * apply arbInt_correct.
      split; omega.
  - case (Z.max_spec (Z.of_nat size) (code_len inf - 1)).
    * move => [_ H]; subst; simpl in *.
      rewrite H in ZMax.
      eexists; split.
      + by [right; right; left].
      + apply gen_from_length_correct => //=; omega.
    * move => [_ H]; subst; simpl in *.
      rewrite H in ZMax.
      eexists; split.
      + by left.
      + apply arbInt_correct; omega.
Qed.

(* Value *)

Definition val_spec (v : Value) : Prop :=
  match v with
    | Vint n => int_spec n
    | Vptr ptr => valid_pointer ptr
    | Vlab l => True
  end.

(* Largely similar proofs now, should probably automate part of it *)
Lemma gen_value_correct:
    semGenSize (gen_value inf) size <--> val_spec.
Proof.
  rewrite /gen_value /val_spec.
  remember inf as Inf.
  clear data_len_nonempty.
  clear code_len_correct.
  clear data_len_positive.
  clear no_regs_positive.
  case : Inf HeqInf => def clen dlen reg HeqInf.
  case; rewrite HeqInf.
  + (* VInt *)
    Opaque gen_int.
    move => z.
    split => //.
    - move => /semFrequencySize /=.
      move => [[freq g] [H1 /= H2]].
Admitted.
(*
      case: H1 => [[_ Heq] | [[_ Heq] | [[_ Heq] | //]]]; rewrite <- Heq in H2;
      apply semLiftGenSize in H2;
      move: H2 => [? [H1 H2]];
      case: H2 => // <-.
      by apply gen_int_correct in H1.
    - move => ZSpec.
      apply semFrequencySize => /=.
      eexists; split.
      * by left.
      * simpl. apply semLiftGenSize.
        exists z; split => //.
        by apply gen_int_correct.
  + (* Vptr *)
    Opaque gen_pointer valid_pointer.
    case => mf addr.
    split.
    - move => /semFrequencySize /=.
      move => [[freq g] [H1 /= H2]].
      case: H1 => [[_ Heq] | [[_ Heq] | [[_ Heq] | //]]]; rewrite <- Heq in H2;
      apply semLiftGenSize in H2;
      move: H2 => [? [H1 H2]];
      case: H2 => // <-.
      by apply gen_pointer_correct in H1.
    - move => ZSpec.
      apply semFrequencySize => /=.
      eexists; split.
      * by right; left.
      * simpl. apply semLiftGenSize.
        exists (Ptr mf addr); split => //.
        by apply gen_pointer_correct.
   + (* Vlab *)
     move => L. split => // _.
     apply semFrequencySize => /=.
     eexists; split.
     * by [right; right; left].
     * simpl. apply semLiftGenSize.
       eexists; split => //.
       by apply gen_label_correct.
Qed.
*)
(* Atom *)

Definition atom_spec atm  :=
  let '(Atm val lab) := atm in
  val_spec val.

Lemma gen_atom_correct:
    semGenSize (gen_atom inf) size <--> atom_spec.
Proof.
  move => [val lab]. rewrite /gen_atom.
  split.
  + move => /semLiftGen2Size /=.
    move => [[val' lab'] [H1 H2]].
    inversion H2; subst; clear H2.
    case: H1 => /= [H1 H2].
    by apply gen_value_correct.
  + move => H /=.
    apply semLiftGen2Size.
    eexists; split => /= ; try split => /=.
    - eapply gen_value_correct.
      rewrite /atom_spec in H.
      by instantiate (1 := (val, lab)).
    - by apply gen_label_correct.
    - by [].
Qed.

(* regSet  *)

Definition regs_spec regs :=
  (length regs = no_regs inf) /\
  (forall reg, reg \in regs -> atom_spec reg).

Lemma gen_registers_correct:
  semGenSize (gen_registers inf) size <--> regs_spec.
Proof.
  move => regs.
  rewrite /gen_registers. split.
  + move /semVectorOfSize => [H1 H2].
    split => //. move => reg /seq_InP HIn. by apply/gen_atom_correct; apply H2.
  + move => [Hlen Hregs]. apply/semVectorOfSize. split => // x HIn.
    by apply/gen_atom_correct; apply Hregs; apply/seq_InP.
Qed.

(* stack_loc *)

Definition valid_reg_ptr ptr_r :=
  (Z0 <= ptr_r <= (Z.of_nat (no_regs inf) - 1))%Z.

Definition stack_loc_spec (t : StackFrame) : Prop :=
  let '(SF ptr_a regs ptr_r lab) := t in
  regs_spec regs /\
  valid_reg_ptr ptr_r /\
  let 'PAtm addr lab' := ptr_a in
  (0 <= addr <= ((code_len inf) - 1))%Z.

Lemma gen_stack_loc_correct :
    (semGenSize (smart_gen_stack_loc inf) size <--> stack_loc_spec).
Proof.
  rewrite /smart_gen_stack_loc /smart_gen semBindSize.
  split.
  + move => [regs' [/gen_registers_correct Hregs]].
    move /semBindSize => [[pca pcl] []] Hpc.
    move /semBindSize => [ptr_r []] Hptr_r.
    move /semBindSize => [lab []] Hlab.
    move => /semReturnSize H.
    inv H.
    rewrite /stack_loc_spec.
    do 2 split => //.
    - apply gen_from_nat_length_correct in Hptr_r.
      * by case Hptr_r.
      * by apply no_regs_positive.
    - by apply gen_PC_correct in Hpc.

  + case: a => [[ret_pc_val ret_pc_lab] regs ptr_r lab] [[Hlen Hregs] [Hptr Hpc_val]].
    exists regs; split => //=.
    - by apply gen_registers_correct.
    apply semBindSize.
    exists (PAtm ret_pc_val ret_pc_lab); split.
    - by apply gen_PC_correct.
    apply semBindSize.
    exists ptr_r; split.
    - by apply gen_from_nat_length_correct.
    apply semBindSize.
    exists lab; split.
    - by apply gen_label_correct.
    by apply semReturnSize.
Qed.

(* Stack *)

Definition stack_spec (s: Stack) : Prop :=
  s = ST nil \/
  exists loc, s = ST (loc :: nil) /\ stack_loc_spec loc.

Lemma gen_stack_correct:
    semGenSize (smart_gen_stack inf) size <--> stack_spec.
Proof.
  Opaque smart_gen_stack_loc.
  rewrite /smart_gen_stack /stack_spec. move => st.
  split.
  + move/semFrequencySize => /= [[freq g] [H1 /= H2]].
    case: H1 => [[] * | [[] * | //]]; subst.
    - apply semReturnSize in H2. by left; case H2.
    - move: H2 => /semBindSize [sf [/gen_stack_loc_correct H1 /semReturnSize H2]].
      right; exists sf; split => /= //.
  + move => [StNil | [sf [H1 H2]]]; subst; apply semFrequencySize => /=.
    - eexists; split => /= //.
      * by left.
      * by apply semReturnSize.
    - eexists; split => /= //.
      * by right; left.
      * apply semBindSize.
        exists sf; split => /= //.
        + by apply gen_stack_loc_correct.
        + by apply semReturnSize.
Qed.

(* frame *)

Definition mem_single_upd_spec mem mf (mem' : memory) :=
  match Mem.get_frame mem mf with
    | Some (Fr lab data) =>
      exists fr, Mem.upd_frame mem mf fr = Some mem' /\
                 let 'Fr lab' data' := fr in
                 lab' = lab /\
                 length data' = length data /\
                 forall atm, atm \in data' -> atom_spec atm
    | None => mem' = mem
  end.

Lemma populate_frame_correct :
  forall mem mf,
    semGenSize (populate_frame inf mem mf) size <--> (mem_single_upd_spec mem mf).
Proof.
  move=> mem mf mem'.  rewrite /populate_frame /mem_single_upd_spec.
  case Heq: (Mem.get_frame mem mf)=> [[lab data]|] //=.
  - move/Mem.upd_get_frame : (Heq) => Hupd.
    split.
    + move /semBindSize => [atmlst [/semVectorOfSize [Hl Hvec] HMatch]].
      move/(_ (Fr lab atmlst)): Hupd => [fr Hfr].
      rewrite Hfr /= in HMatch;
      apply semReturnSize in HMatch.
      inversion HMatch; subst; clear HMatch.
      exists (Fr lab atmlst); repeat split => /= //.
      move => atm HIn. apply gen_atom_correct. by apply Hvec; apply/seq_InP.
    + move => [fr [Hget H]].
      case: fr Hupd Hget H =>
        lab' data' Hupd Hget [Heq1 [Heq2 H]]; subst.
      apply semBindSize.
      exists data'. split.
      apply semVectorOfSize. split => // x HIn. by apply/gen_atom_correct; apply H; apply/seq_InP; eauto.
      rewrite Hget. by apply semReturnSize.
  - split.
    + move => /semReturnSize H. by case H.
    + by move => H; subst; apply semReturnSize.
Qed.

(* Memory *)

Lemma zreplicate_spec :
  forall {A : eqType} (v : A) (z : Z),
    (0 <= z)%Z ->
    exists (l : list A),
      (forall x, x \in l -> x = v) /\
      length l = Z.to_nat z /\
      zreplicate z v = Some l.
Proof.
  move => A v z Hle. exists (nseq (Z.to_nat z) v).
  repeat split.
  - move=> x HIn. apply Z2Nat.inj_le in Hle; try omega.
    elim: (Z.to_nat z) HIn => [| n IHn] //=.
    rewrite /= inE=> /orP [/eqP Heq | HIn]; try assumption; auto.
  - apply Z2Nat.inj_le in Hle; try omega.
    induction (Z.to_nat z) as [| n IHn].
    + reflexivity.
    + simpl. rewrite IHn; auto; simpl; omega.
  - rewrite /zreplicate. destruct (Z_lt_dec z 0); try reflexivity.
    omega.
Qed.

Lemma zreplicate_eq :
  forall {A : eqType} (l: list A) v z,
    (0 <= z)%Z ->
    (forall x, x \in l ->  x = v) ->
    length l = Z.to_nat z ->
    zreplicate z v = Some l.
Proof.
  move => A l v x Hle HIn Heq.
  rewrite /zreplicate. destruct ( Z_lt_dec x 0 ) as [H | H].
  - omega.
  - apply Z2Nat.inj_le in Hle; try omega; simpl.
    clear H Hle. congr Some. rewrite -{}Heq.
    elim: l HIn=> [|a l IH] //= HIn; congr cons.
      by symmetry; apply: HIn; rewrite inE eqxx.
    by apply: IH=> a' Pa'; apply: HIn; rewrite inE Pa' orbT.
Qed.

Definition init_mem_spec (size : nat) (m : memory)
           (blocks : list (mframe * Z)) (m': memory)
  (blocks': list (mframe * Z)) :=
  exists (lst : list (Label * (list Atom))),
    length lst = size /\
    (forall l data,
        (l, data) \in lst ->
        (C.min_frame_size <= Z.of_nat (length data) <= C.max_frame_size)%Z /\
        (forall v, v \in data ->  v = (Vint 0 @ bot))) /\
    (m', blocks') =
    foldl
      (fun (ml : memory * (list (mframe * Z))) (elem : Label * (list Atom))  =>
         let '(l, data) := elem in
         let '(m_i, bs) := ml in
         let (b, m) := Mem.alloc Local m_i bot (Fr l data) in
         (m, (b, Z.of_nat (length data)) :: bs)
      ) (m, blocks) lst.

Definition mem_constraints (m : memory) :=
  forall b l data,
    Mem.get_frame m b = Some (Fr l data) ->
    (C.min_frame_size <= Z.of_nat (length data) <= C.max_frame_size)%Z /\
    Mem.stamp b = bot.

(* (* CH: now unused *) *)
(* Lemma all_bellow_top : forall l, *)
(*   In l (allThingsBelow top). *)
(* Proof. rewrite /allThingsBelow. case; simpl; tauto. Qed. *)

Lemma gen_init_mem_helper_correct:
  forall (n: nat) (m : memory) (blocks : list (mframe * Z)),
    (mem_constraints m) ->
    semGenSize (gen_init_mem_helper n (m, blocks)) size <-->
    (fun p => init_mem_spec n m blocks (fst p) (snd p)).
Proof.
  move => n m blocks Hspec [m' lst']. rewrite /init_mem_spec. split.
  { move => Hgen. generalize dependent m. generalize dependent blocks.
      induction n as [| n IHn]; intros blocks mem Hspec Hgen.
      - exists [::]. repeat split => /= //.
        rewrite /gen_init_mem_helper in Hgen. by apply semReturnSize in Hgen.
      - rewrite /gen_init_mem_helper in Hgen.
        fold gen_init_mem_helper in Hgen.
        apply semBindSize in Hgen.
        move : Hgen => [len [Hchoose /semBindSize [lab [Hlab Hgen]]]].

        move: Hchoose => /semChooseSize H.
        apply H in frame_sizes_correct; clear H.
        move: frame_sizes_correct => /andP [/= /Zle_bool_imp_le Hle1 /Zle_bool_imp_le Hle2].
        rewrite /C.min_frame_size /C.max_frame_size in Hle1 Hle2 *.
        unfold alloc in Hgen.
        destruct (zreplicate_spec (Vint 0 @ ⊥) len) as [data [HIn [Heq HSome]]].
        simpl in *; omega. rewrite HSome in Hgen.
        remember (Mem.alloc Local mem ⊥ (Fr lab data)) as alloc.
        destruct alloc as [fr mem'].
        destruct (IHn ((fr, Z.of_nat (length data)) :: blocks) mem')
          as [lst [Hlen [Hforall Hfold]]] => //; clear IHn.
        + rewrite /init_mem_spec in Hspec *.
          symmetry in Heqalloc. move : (Heqalloc) => Halloc.
          move => fr' lab' data' Hget.
          apply Mem.alloc_get_frame with (b' := fr') in Halloc.
          move: Halloc; rewrite Hget.
          have [efr|nefr] := altP (fr =P fr').
          * move=> [??]; subst lab' data' fr'.
            rewrite /C.min_frame_size /C.max_frame_size Heq.
            repeat split => //=; try (simpl in *; rewrite Z2Nat.id; omega).
            by eapply Mem.alloc_stamp; apply Heqalloc.
          * move=> Halloc. eapply Hspec. rewrite -Halloc. eauto.
        + rewrite Heq. simpl in *; rewrite Z2Nat.id; last omega.
          by move: Hgen; rewrite -Heqalloc.
        + exists ((lab, data) :: lst). split. by subst.
          split => //=.
          * move => l data'; rewrite inE=> /orP [/eqP [eq1 eq2] | H]; subst.
            split => //. rewrite Heq //. rewrite Z2Nat.id. split => //.
            eapply Z.le_trans; [| apply Hle1] => //.
            edestruct Hforall as [Hrng HIn']. apply H.
            split; auto. simpl in Hfold. rewrite Hfold.
            by rewrite -Heqalloc. }
  { move => [lst [Hlen [HIn Hfold]]]. generalize dependent lst.
    generalize dependent m. generalize dependent blocks.
    induction n as [| n IHn]; intros blocks m Hspec lst Hlen HIn Hfold.
    - destruct lst; simpl in *.
      by apply semReturnSize.
      congruence.
    - rewrite /gen_init_mem_helper. fold gen_init_mem_helper. apply semBindSize.
      destruct lst as [|[lab data] lst]. simpl in Hlen; congruence.
      destruct (HIn lab data) as [[Hle1 Hle2] HInx]; try by apply in_eq.
        by rewrite inE eqxx.
      exists (Z.of_nat (length data)). split.
      + apply semChooseSize.
        by apply frame_sizes_correct.
        apply/andP.
        split; by apply Zle_imp_le_bool.
      + apply semBindSize.
        exists lab. split; try by apply gen_label_correct.
        rewrite /alloc.
        rewrite (zreplicate_eq data); auto; try omega; try by rewrite Nat2Z.id.
        remember (Mem.alloc Local m L (Fr lab data)) as frm.
        destruct frm as [fr1 m1]. rewrite -Heqfrm.
        apply IHn with (lst := lst).
        * rewrite /init_mem_spec in Hspec *.
          move => block lab' data' Hget.
          symmetry in Heqfrm. move: (Heqfrm)=> Halloc.
          apply Mem.alloc_get_frame with (b' := block) in Halloc.
          move: Halloc; have [efr|nefr] := altP (fr1 =P _).
          - rewrite {}Hget => - [??]; subst lab' data' block.
            split => //.
            eapply Mem.alloc_stamp.
            apply Heqfrm.
          - rewrite Hget. rewrite /mem_constraints in Hspec => e.
              eapply Hspec; by eauto.
       * by inversion Hlen.
       * move => lab' data' HIn'.
         by apply: (HIn lab'); rewrite inE; apply/orP; right.
       * simpl in Hfold. by rewrite -Heqfrm in Hfold. }
Qed.

Lemma gen_init_mem_correct:
  forall (top : Label),
    semGenSize gen_init_mem size <-->
    (fun ml =>
       (exists n,
          C.min_no_frames <= n <= C.max_no_frames /\
          init_mem_spec n (Mem.empty Atom Label) [::] (fst ml) (snd ml))).
  Proof.
    move => top init_mem. split.
    { unfold gen_init_mem.
      move => /semBindSize [len [Hchoose Hgen]].
      exists len. apply semChooseSize in Hchoose.
      move: Hchoose => /andP [/= Hle1 Hle2]. simpl in *.
      edestruct (gen_init_mem_helper_correct len (Mem.empty Atom Label))
        as [Hl _].
      - move => b l data Hget.
        by rewrite Mem.get_empty in Hget.
      - destruct (Hl Hgen) as [lst H].
        split => //. apply/andP. split => //.
        by eauto.
        assumption.
    }
    { move => [len [/andP [Hle1 Hle2] Hspec]].
      edestruct (gen_init_mem_helper_correct len (Mem.empty Atom Label))
        as [_ Hr].
      - rewrite /init_mem_spec /=. move => b l data Hget.
        by rewrite Mem.get_empty in Hget.
      - rewrite /gen_init_mem.
        apply semBindSize.
        exists len. split.
        + apply semChooseSize. split => //.
          apply/andP. by split.
          by auto.
    }
Qed.

Definition init_mem_single_upd_spec (mem : Mem.t Atom Label)
           (mf : Mem.block Label) (mem' : memory) :=
  match Mem.get_frame mem mf with
    | Some (Fr lab data) =>
      exists fr : Memory.frame,
        Mem.upd_frame mem mf fr = Some mem' /\
        (let 'Fr lab' data' := fr in
         lab' = lab /\
         length data' = length data /\
         (forall atm : Atom, atm \in data' -> atom_spec atm))
    | None => mem' = mem
  end.

Definition populated_memory_spec (m : memory) (m': memory) :=
  let blocks := [seq fst p | p <- data_len inf] in
  foldr (fun block (p : memory -> Prop) m_prev =>
           exists m, (mem_single_upd_spec m_prev block m) /\ p m)
        (eq m') blocks m /\
  (forall b lab d,
     Mem.get_frame m' b = Some (Fr lab d) ->
     Mem.stamp b = bot /\
     (C.min_frame_size <= Z.of_nat (length d) <= C.max_frame_size)%Z).

(* Lemma semFoldGen_right :
  forall {A B : Type} (f : A -> B -> G A) (bs : list B) (a0 : A) (s : nat),
    semGenSize (foldGen f bs a0) s <-->
    [ set an |
      foldr (fun b p => [set a_prev | exists a, a \in (semGenSize (f a_prev b) s :&: p)])
            [set an] bs a0].
Pr *)

Lemma populate_memory_correct:
  forall (m : memory),
    mem_constraints m ->
    semGenSize (populate_memory inf m) size <-->
    (populated_memory_spec m ).
Proof.
  move => m Hcontent m'.
  split.
  { unfold populate_memory.
    move => /semFoldGen_right Hgen. rewrite /populated_memory_spec.
    generalize dependent m.
    set lst := ((map _ (data_len inf))).
    induction lst as [| b bs IHbs]; move=> m Hinit Hfold.
    rewrite /mem_constraints in Hinit.
    - simpl in *; subst.
      inversion Hfold; subst; clear Hfold.
      split => // b l d /Hinit [? ?];
      by repeat split => //.
   - simpl in *. move: Hfold => [m'' [Hpop Hfold]].
     have Hcnstr: mem_constraints m''.
     { rewrite /populate_frame in Hpop.
       remember (Mem.get_frame m b) as get.
       destruct get as [[l d]|].
       * symmetry in Heqget.
         apply semBindSize in Hpop.
         case : Hpop => [d' [/semVectorOfSize [Hlen Hforall] Hupd]].
         destruct (Mem.upd_get_frame (Fr l d') Heqget)
           as [fr Hupd'].
         rewrite Hupd' in Hupd.
         apply semReturnSize in Hupd.
         inv Hupd. rewrite /mem_constraints.
         destruct (Hinit _ _ _ Heqget) as [? ?].
         subst. move => b' l' d'' Hget.
         move: (Mem.get_upd_frame Hupd' b') => Hget'.
         case: (b =P b') Hget' => e Hget'.  inv e.
         - rewrite Hget in Hget'. inv Hget'. split => //.
           split; [rewrite Hlen | repeat split => //]; omega.
         - rewrite Hget in Hget'. symmetry in Hget'.
           destruct (Hinit _ _ _ Hget') as [? ?].
           by repeat split => //.
       * apply semReturnSize in Hpop; by inv Hpop.
     }
     destruct (IHbs m'' Hcnstr Hfold) as [Hfold' Hcnstr']. split => //.
     exists m''. split=> //.
     by apply populate_frame_correct. }
  { rewrite /populated_memory_spec /populate_memory. move => [Hfold Hconstr].
    apply semFoldGen_right. generalize dependent m.
    set lst := ((map _ (data_len inf))).
    induction lst as [| b bs IHbs]; move=> m Hinit Hfold.
    + by simpl in *.
    + simpl in *. move : Hfold => [m'' [Hupd Hfold]]. eexists. split => //.
      * apply populate_frame_correct. eassumption.
      * apply IHbs => //. rewrite /mem_single_upd_spec in Hupd.
        case Heqget: (Mem.get_frame m b) Hupd=> [[l d]|] Hupd; try by inv Hupd.
        move : Hupd => [[l' d'] [Hupd' [eq1 [Hlen Hforall]]]]; subst.
        destruct (Mem.upd_get_frame (Fr l d') Heqget)
          as [fr Hupd''].
        rewrite Hupd'' in Hupd'. inv Hupd'. rewrite /mem_constraints.
        destruct (Hinit _ _ _ Heqget) as [? ?].
        subst. move => b' l' d'' Hget.
        move: (Mem.get_upd_frame Hupd'' b') => Hget'.
        case: (b =P b') Hget' => e Hget'.  inv e.
        - rewrite Hget in Hget'. inv Hget'. split => //.
           split; [rewrite Hlen | repeat split => //]; omega.
        - rewrite Hget in Hget'. symmetry in Hget'.
          destruct (Hinit _ _ _ Hget') as [? ?].
          repeat split => //. }
Qed.

(* Instruction *)

Definition Instruction_spec (st : State) (instr : @Instr Label) :=
  let '(St im m stk regs pc ) := st in
  let '(dptr, cptr, num, lab) :=
      groupRegisters st regs [::] [::] [::] [::] Z0 in
  match instr with
    | PcLab z | PutLab _ z
    | Put _ z => (0 <= z <= (Zlength regs -1))%Z
    | Mov z1 z2 => (0 <= z1 <= (Zlength regs -1))%Z /\ (0 <= z2 <= (Zlength regs-1))%Z

    | MLab z1 z2 | Load z1 z2 | Store z1 z2 | MSize z1 z2 | PGetOff z1 z2
    | Write z1 z2 =>
      dptr <> [::] /\ z1 \in dptr /\  (0 <= z2 <= (Zlength regs-1))%Z

    | Nop => True | Halt => False
    | Lab z1 z2 =>
      (0 <= z1 <= (Zlength regs-1))%Z /\ (0 <= z2 <= (Zlength regs-1))%Z

    | BCall z1 z2 z3 =>
      cptr <> [::] /\ lab <> [::] /\
      z1 \in cptr /\ z2 \in lab /\  (0 <= z3 <= (Zlength regs-1))%Z
    | BRet =>
      match stk with
        | ST [::] => False
        | ST _  => True
      end
    | Alloc z1 z2 z3 =>
      num <> [::] /\ lab <> [::] /\
      z1 \in num /\ z2 \in lab /\  (0 <= z3 <= (Zlength regs-1))%Z
    | Jump z => cptr <> [::] /\ z \in cptr
    | BNZ z1 z2 => num <> [::] /\ (-1 <= z1 <= 2)%Z /\ z2 \in num
    | PSetOff z1 z2 z3 =>
      dptr <> [::] /\ num <> [::] /\
      z1 \in dptr /\ z2 \in num /\  (0 <= z3 <= (Zlength regs-1))%Z
    | BinOp BAdd z1 z2 z3 | BinOp BMult z1 z2 z3 | BinOp BEq z1 z2 z3 =>
      num <> [::] /\ z1 \in num /\ z2 \in num /\ (0 <= z3 <= (Zlength regs-1))%Z
    | BinOp BJoin z1 z2 z3 | BinOp BFlowsTo z1 z2 z3 =>
      lab <> [::] /\ z1 \in lab /\ z2 \in lab /\ (0 <= z3 <= (Zlength regs-1))%Z

  end.

Ltac discr_gen_eq :=
  match goal with
    | H : (_, liftGen ?f ?gen) = (?n, ?g),
      Hg : ?g _ |- _ =>
        move : H => [Heq1 Heq2]; subst;
        apply semLiftGenSize in Hg; move: Hg => [a [_ H]]; discriminate
    | H : (_, returnGen ?a) = (?n, ?g),
      Hg : ?g _ |- _ =>
        move : H => [Heq1 Heq2]; subst; discriminate
    | H : (_, liftGen2 ?f ?gen1 ?gen2) = (?n, ?g),
      Hg : ?g _ |- _ =>
      move : H => [Heq1 Heq2]; subst;
      apply semLiftGen2Size in Hg;
      move: Hg => [a [_ [a' [_ H]]]]; subst; discriminate
    | H : (_, liftGen3 ?f ?gen1 ?gen2 ?gen3) = (?n, ?g),
      Hg : ?g _ |- _ =>
      move : H => [Heq1 Heq2]; subst;
      apply semLiftGen3Size in Hg;
      move: Hg => [a [_ [a' [_ [a'' [ _ H]]]]]]; subst; discriminate
    | H : (_, liftGen4 _ _ _ _ _) = (_, ?g),
      Hg : ?g _ |- _ =>
      move : H => [Heq1 Heq2]; subst;
      apply semLiftGen4Size in Hg;
      move: Hg => [a [_ [a' [_ [a'' [ _ [a''' [ _ H]]]]]]]]; subst; discriminate

  end.

Ltac discr_or_first :=
  match goal with
    | HIn : ((_, _) = (_ , _) \/ _) |- _ =>  case: HIn => [Heq | HIn]; [discr_gen_eq | ]
    | HIn : (_, _) \in _ |- _ => case/orP: HIn => [Heq | HIn]; [discr_gen_eq | ]
  end.

(*
Ltac unfold_gen :=
  match goal with
    | Hg : returnGen _ _ |- _ =>
      rewrite returnGen_def in Hg; subst
    | Hg : liftGen _ _ _ |- _ =>
      rewrite liftGen_def in Hg; move: Hg => [b [H1 [Heq]]]; subst
    | Hg : liftGen2 _ _ _ _ |- _ =>
      rewrite liftGen2_def in Hg;
        move: Hg => [b [H1 [b' [H2 [Heq1 Heq2]]]]]; subst
    | Hg : liftGen3 _ _ _ _ _ |- _ =>
      rewrite liftGen3_def in Hg;
        move: Hg => [b [H1 [b' [H2 [b'' [H3 [Heq1 Heq2 Heq3]]]]]]]; subst
    | Hg : liftGen4 _ _ _ _ _ _ |- _ =>
      rewrite liftGen4_def in Hg;
       move: Hg=>[b [H1 [b' [H2 [b'' [ H3 [b''' [H4 [Heq1 Heq2 Heq3 Heq4]]]]]]]]]; subst
  end.

Ltac try_solve :=
      match goal with
        | |- _ /\ _ => split => //=; by try_solve
        | Hand : _ /\ _ |- _ => destruct Hand; by try_solve
        | Hor : _ \/ _ |- _ => destruct Hor; by try_solve
        | |- ~ _ => move => contra; subst; by try_solve
        | Hchoose : choose _ _ |- _ =>
          rewrite choose_def /= in Hchoose; by try_solve
        | Helem : elements _ _ _ |- _ =>
          move/elements_equiv : Helem => [Helem //= | [Helem1 Helem2] //=]; subst;
          by try_solve

        | HIn: In _ [] |- _ => by []
        | Hnonempty : ~ (onNonEmpty [] _ = 0) |- _ =>
           by rewrite /onNonEmpty in Hnonempty
        | Hnonempty : ~ (_ * (onNonEmpty [] _))%coq_nat = 0 |- _ =>
            by rewrite [X in (_ * X)%coq_nat]/onNonEmpty -mult_n_O in Hnonempty
        | Hif: ~ ((if ?b then _ else _ ) = _) |- ?b = true =>
            by case: b Hif
        | |- (_ <= _)%Z => by apply/Zle_bool_imp_le
        | |- _ => by []
      end.

Ltac find_instr instr lst k :=
  match lst with
    | nil => k 0 (pure Nop)
    | (?n, liftGen4 ?c ?a1 ?a2 ?a3 ?a4) :: ?lst' => (* match with liftGen4 *)
      match instr with
        | c _ _ _ _ => k n (liftGen4 c a1 a2 a3 a4)
        | _ => find_instr instr lst' k
      end
    | (?n, liftGen3 ?c ?a1 ?a2 ?a3) :: ?lst' => (* match with liftGen3 *)
      match instr with
        | c _ _ _ => k n (liftGen3 c a1 a2 a3)
        | _ => find_instr instr lst' k
      end
    | (?n, liftGen2 ?c ?a1 ?a2) :: ?lst' => (* match with liftGen2 *)
      match instr with
        | c _ _  => k n (liftGen2 c a1 a2)
        | _ => find_instr instr lst' k
      end
    | (?n, liftGen ?c ?a1) :: ?lst' => (* match with liftGen *)
      match instr with
        | c _  => k n (liftGen c a1)
        | _ => find_instr instr lst' k
      end
    | (?n, ?f ?c) :: ?lst' => (* match with pure/returnGen *)
      match instr with
        | c  => k n (f c)
        | _ => find_instr instr lst' k
      end
  end.

Ltac instantiate_exists :=
  match goal with
    | |- exists n g, In (n, g) ?lst /\ _ ?cnstr /\ _ =>
      find_instr cnstr lst ltac:(fun n g => pose cnstr; exists n; exists g);
      split; [repeat ((try by apply in_eq); apply in_cons) | split => //]
  end.

Ltac try_solve2 :=
  match goal with
    | Hand : _ /\ _ |- _ => destruct Hand; by try_solve2
    | |- _ = _ => reflexivity
    | |- _ /\ _ => split; [| by try_solve2]; by try_solve2
    | |- liftGen4 _ _ _ _ _ _ => rewrite liftGen4_def; by try_solve2
    | |- liftGen3 _ _ _ _ _ => rewrite liftGen3_def; by try_solve2
    | |- liftGen2 _ _ _ _ => rewrite liftGen2_def; by try_solve2
    | |- liftGen _ _ _ => rewrite liftGen_def; by try_solve2
    | |- elements _ _ _ => apply/elements_equiv; left; by try_solve2
    | |- choose _ _ => rewrite choose_def => /=; by try_solve2
    | |- is_true (_ <=? _)%Z => by apply/Zle_imp_le_bool
    | |- gen_from_length _ _ => rewrite /gen_from_length; try try_solve2
    | |- ~ onNonEmpty ?l _ = 0 => by destruct l
    | |- exists _, _ => eexists; by try_solve2
    | |- ~ (( _ * onNonEmpty ?c _)%coq_nat * onNonEmpty ?l _)%coq_nat = 0 =>
        by destruct c; destruct l
    | |- gen_BinOpT _ => by apply gen_BinOpT_correct
    | |- ~ (if ?b then _ else _) = 0 => by destruct b
    | _ => by []
  end.
 *)

Ltac solver :=
  match goal with
    | Hl : _ (_,_) , Hsem : semGenSize _ _ _ |- _ =>
  case : Hl => [[] * | Hl];
       [ subst; simpl in Hsem;
         match goal with
           | H : semGenSize (pure _) size _ |- _ =>
             apply semReturnSize in Hsem;
               inv Hsem
           | H : semGenSize (liftGen _ _) _ _ |- _ =>
             let x := fresh in
             move : Hsem => /semLiftGenSize [? [x H]];
             inv H
           | H : semGenSize (liftGen2 _ _ _) _ _ |- _ =>
             let x := fresh in
             move : Hsem => /semLiftGen2Size [[freq' g'] [x H]];
             rewrite /prod_curry in H; [inv H]
           | H : semGenSize (liftGen3 _ _ _ _) _ _ |- _ =>
             move : Hsem => /semLiftGen3Size [? [? [? [? [? [? ?]]]]]];
             discriminate
           | H : semGenSize (liftGen4 _ _ _ _ _) _ _ |- _ =>
             move : Hsem => /semLiftGen4Size [? [? [? [? [? [? [? [? ?]]]]]]]];
             discriminate
           | _ => idtac
         end | solver ]
    | Hl : (_,_) = (_,_) \/ _ , Hsem : semGenSize _ _ _ |- _ =>
      case : Hl => [[] * | Hl];
       [ subst; simpl in Hsem;
         match goal with
           | H : semGenSize (pure _) size _ |- _ =>
             apply semReturnSize in Hsem;
               inv Hsem
           | H : semGenSize (liftGen _ _) _ _ |- _ =>
             let x := fresh in
             move : Hsem => /semLiftGenSize [? [x H]];
             inv H
           | H : semGenSize (liftGen2 _ _ _) _ _ |- _ =>
             let x := fresh in
             move : Hsem => /semLiftGen2Size [[freq' g'] [x H]];
             rewrite /prod_curry in H; [inv H]
           | H : semGenSize (liftGen3 _ _ _ _) _ _ |- _ =>
             move : Hsem => /semLiftGen3Size [? [? [? [? [? [? ?]]]]]];
             discriminate
           | H : semGenSize (liftGen4 _ _ _ _ _) _ _ |- _ =>
             move : Hsem => /semLiftGen4Size [? [? [? [? [? [? [? [? ?]]]]]]]];
             discriminate
           | _ => idtac
         end | solver ]
    | _ => idtac
  end.

(*
Lemma gen_ainstrSSNI_correct :
  forall (st : State),
    (RandomQC.leq Z0 (Zlength (st_regs st) -1))%Z ->
    semGenSize (ainstrSSNI st) size <--> (Instruction_spec st).
Proof.
  move=> [im m stk regs pc] reg_no instr. rewrite /ainstrSSNI /Instruction_spec.
  set st := {|
             st_imem := im;
             st_mem := m;
             st_stack := stk;
             st_regs := regs;
             st_pc := pc |}.
  case: (groupRegisters st regs [] [] [] [] Z0)=> [[[dptr cptr] num] lab].
  split.
  - destruct instr;
    move =>  /semFrequencySize HSem;
    rewrite /onNonEmpty in HSem.

    destruct dptr; destruct cptr; destruct num; destruct lab; destruct (unStack stk);
    simpl in HSem;
    move : HSem => [[freq g] [Hl Hsem]];
    solver;
    try solve [
    move : H => [H1 H2]; by apply gen_from_length_correct];
    try solve [inv Hl].

    destruct dptr; destruct cptr; destruct num; destruct lab; destruct (unStack stk);
    simpl in HSem;
    move : HSem => [[freq g] [Hl Hsem]];
    solver;
    try solve [inv Hl];
    repeat match goal with
             | |- (_ <= _ <= _)%Z /\ _ => split
             | H : setX _ _ _ |- _ => move : H => [H1 H2]
           end; by apply gen_from_length_correct.
      match goal with
        | H : setX _ _ _ |- _ => move : H => [H1 H2]
      end.

      | H : False |- _ => inv H

    try solve [
    move : H => [H1 H2]; by apply gen_from_length_correct];

             move : Hsem => /semLiftGen3Size [? [? [? [? [? [? ?]]]]]];
             discriminate.
    move : Hsem => /semLiftGen4Size [? [? [? [? [? [? [? [? ?]]]]]]]];
                  discriminate.

    repeat (case : Hl => [[] * | Hl];
       [ subst; simpl in Hsem;
         match goal with
           | H : semGenSize (pure _) size _ |- _ =>
             apply semReturnSize in Hsem;
               inv Hsem
           | H : semGenSize (liftGen _ _) _ _ |- _ =>
             let x := fresh in
             move : Hsem => /semLiftGenSize [? [x H]];
             inv H
           | H : semGenSize (liftGen2 _ _ _) _ _ |- _ =>
             let x := fresh in
             move : Hsem => /semLiftGen2Size [[freq' g'] [x H]];
             rewrite /prod_curry in H; [inv H]
           | _ => idtac
         end | ]).
    rewrite /RandomQC.leq.
    by
    apply gen_from_length_correct in H2.

    rewrite /prod_curry in Hsem.
    inv Hsem.

    case : Hl => [[] * | Hl].
    subst; simpl in Hsem.
    match goal with
      | H : semGenSize (liftGen _ _) _ _ |- _ =>
        move : Hsem => /semLiftGenSize [? [? ?]] //=
    end.

    apply semReturnSize in Hsem.
    match goal with
      | HIn : (_ , _) \/ _) = (_ , _) |- _ =>  move : (HIn) => Foo
                                                                 (* case: HIn => [Heq | HIn]; [discr_gen_eq | ] *)
      | HIn : In (_, _) _ |- _ => move : (HIn) => Bar (* case: HIn => [Heq | HIn]; [discr_gen_eq | ] *)
    end.

    discr_or_first.

case: instr => [r1 r2 | r1 r2 | r | r1 r2 r3 | | r1 r2 r3 | r1 r2 r3 |
                    l r | | z r | bop r1 r2 r3 | r | z r | r1 r2 | r1 r2 |
                    r1 r2 r3 | r1 r2 r3 | r | | r1 r2 | r1 r2];
    move /frequency_equiv =>  [[n [g [HIn [Hg Hn]]]] | [[H | H] H' //=]];
    rewrite /gen_from_length /pure in HIn. repeat discr_or_first;
    (case: HIn => [[Heq1 Heq2] | HIn]; subst;
                 [by unfold_gen; try_solve | by repeat discr_or_first]).
 -  Opaque mult choose.
   case: instr => [r1 r2 | r1 r2 | r | r1 r2 r3 | | r1 r2 r3 | r1 r2 r3 |
                    l r | | z r | bop r1 r2 r3 | r | z r | r1 r2 | r1 r2 |
                    r1 r2 r3 | r1 r2 r3 | r | | r1 r2 | r1 r2];
                   move => H; apply frequency_equiv; left;
    instantiate_exists; try rewrite /gen_from_lengt; try by try_solve2.
    + rewrite liftGen2_def. eexists. split; [| try_solve2].
      by rewrite gen_label_correct.
    + rewrite liftGen2_def. eexists. split; [| try_solve2].
      rewrite /arbitrary /arbInt. by apply arbInt_correct.
Qed.
*)

(* Proofs for variations *)

(* Vary Atom *)
Lemma gen_vary_atom_correct :
  forall (l : Label) (a : Atom),
    let 'v @ la := a in
    val_spec v ->
    semGenSize (gen_vary_atom l inf a) size <--> (fun a' =>
                                    let 'v' @ la' := a' in
                                    indist l a a' /\ val_spec v').
Proof.
  move=> l a. case: a => va la.
  move=> Hspec; case => va' la'.
  rewrite /gen_vary_atom /indist /indistAtom.
  case: (isLow la l).
  + (* la lower that observability level *)
    split.
    * (* Correctness *)
      move => /semReturnSize [Heq1 Heq2]; subst.
      split => //. apply/andP; split => //.
      apply/orP. right. rewrite /indist /indistValue /val_spec in Hspec *.
      case: va' Hspec => [i' | Ptr' | lv'] Hspec; by [].

    * (* Completeness *)
      move=> [/andP [/andP [Hflows1 Hflows2] /orP [H1 //= | H1]] H2].
      rewrite /indist /indistValue in H1. apply semReturnSize.
      move: (flows_antisymm _ _ Hflows2 Hflows1) => Heq; subst.
      by move/eqP in H1; subst va'.
  + (* la higher than observable state *)
    split.
    * (* Correctness *)
      move => /semFrequencySize /=.
      case: va Hspec=> [i | ptr | lv];  case: va' => [i' | ptr' | lv'];
      move => Hpec [[freq g] [Hgen Hret]];
      case: Hgen => [[] *| [[]* | //]]; subst;
      simpl in Hret;
      try solve [
        apply semBindSize in Hret;
        move: Hret => [val [Heq1 Heq2]];
        apply gen_value_correct in Heq1;
        apply semReturnSize in Heq2;
        inversion Heq2; subst;
        by split; [ apply /andP; split => // | ]
      ];
      try solve [
        apply semLiftGen2Size in Hret;
        move: Hret => [[val lab] [[H1 H2] Heq2]];
        apply semLiftGenSize in H1;
        apply semReturnSize in H2;
        case: H1 => [x [H3 H4]];
        inv H4; inv Heq2; inv H2; inv H;
        try apply gen_int_correct in H3;
        try apply gen_pointer_correct in H3;
        try apply gen_label_correct in H3;
        simpl in *; subst;
        by split; [apply/andP; split => //= | ]
      ].
    * (* Completeness *)
      move=> [/andP[/andP [H1 H2] /orP [_| H3]]   H];
      apply semFrequencySize => //=;
      eexists; split;
      [ by left |  | by left | ];
        simpl; apply semBindSize;
        exists va'; split => //.
      - by apply gen_value_correct.
      - apply semReturnSize; by move: (flows_antisymm _ _ H2 H1) => Heq; subst.
      - by apply gen_value_correct.
      - apply semReturnSize; by move: (flows_antisymm _ _ H2 H1) => Heq; subst.
Qed.

(* Vary Ptr_atom *)
Lemma gen_vary_pc_correct:
  forall (obs: Label) (pc : Ptr_atom),
    (pc_in_bounds pc) ->
    semGenSize (gen_vary_pc obs inf pc) size <-->
    (fun pc' => (if isLow ∂pc obs then pc == pc' else isHigh ∂pc' obs) /\ pc_in_bounds pc').
Proof.
  move => obs [pc_a pc_l] Hspec pc'.
  rewrite /gen_vary_pc /pc_lab.
  remember (flows pc_l obs) as Flows.
  destruct Flows.
  - split.
    + move => /semReturnSize H.
      inv H.
      by split.
    + move => [H1 H2].
      apply semReturnSize.
      by move: H1 => /eqP ->.
  - split.
    + move => /semBindSize [xa [/gen_from_length_correct H1 H2]].
      move: H2 => /semBindSize [xl [/gen_high_label_correct H3 /semReturnSize H4]].
      apply H1 in code_len_correct; clear H1; rename code_len_correct into H1.
      rewrite /negb in HeqFlows.
      assert (isHigh pc_l obs) by by (rewrite /negb; rewrite <- HeqFlows).
      apply existsHighObsLow in H.
      apply H3 in H.
      inv H4.
      split => //=.
    + move => [H1 H2].
      apply semBindSize.
      destruct pc' as [xa xl] eqn:PC.
      exists xa; split.
      * by apply gen_from_length_correct.
      * apply semBindSize.
        exists xl; split => //=.
        - apply gen_high_label_correct => //.
          by apply (existsHighObsLow xl).
        - by apply semReturnSize.
Qed.

Lemma gen_vary_regSet_correct:
  forall regs obs,
    (regs_spec regs)->
    semGenSize (sequenceGen (map (@smart_vary _ (smart_vary_atom) obs inf) regs)) size <-->
    (fun regs' =>
       regs_spec regs' /\ indist obs regs regs').
Proof.
  Opaque gen_vary_atom.
  move => regs obs [Hlen Hspec] regs'.
  rewrite /regs_spec -{}Hlen; split.
  - (* Correctness *)
    move => /semSequenceGenSize [_ HIn].
    rewrite /indist /indistList; move: HIn; set regs'' := map _ _.
    move: {1 3}regs'' (erefl regs''); rewrite {}/regs'' => regs'' e HIn.
    elim: regs'' regs' / HIn regs Hspec e
          => /= [|_r [rv' rl'] _regs regs' Hsem _ IH] [|[rv rl] regs] //= Hspec [??].
    subst _r _regs.
    have sr: val_spec rv by apply (Hspec (rv @ rl)); rewrite inE eqxx.
    have {Hspec} srs: forall reg, reg \in regs -> atom_spec reg.
      by move=> reg in_regs; apply Hspec; rewrite inE in_regs orbT.
    have [[-> srs'] /andP [/eqP -> ->]] := IH regs srs erefl.
    move: (gen_vary_atom_correct obs (rv@rl) sr)=> V.
    move/(V (rv' @ rl')): Hsem=> [/= Hsem1 Hsem2].
    rewrite eqxx /= andbT; split=> //; first split=> //.
    move=> reg; rewrite inE=> /orP [/eqP -> {reg}|]; auto.
  - rewrite /indist /indistList.
    move => [[Hlen' Hreg] /andP [_ Hz]].
    apply semSequenceGenSize; rewrite -!size_length size_map !size_length.
    split=> //.
    elim: regs regs' Hlen' Hspec Hreg Hz
          => [|[rv rl] regs IH] [|[rv' rl'] regs'] // Hlen Hspec Hspec'.
      by constructor.
    set f := fun p => indist _ _ _.
    rewrite /= => /andP [Hinds Hall]; constructor.
      apply/(gen_vary_atom_correct obs (rv @ rl)).
        by apply: (Hspec (rv @ rl)); rewrite inE eqxx.
      split=> //.
      by apply: (Hspec' (rv' @ rl')); rewrite inE eqxx.
    apply: IH=> //.
    + by move: Hlen=> /= [->].
    + by move=> r in_r; apply: Hspec; rewrite inE in_r orbT.
    by move=> r in_r; apply: Hspec'; rewrite inE in_r orbT.
Qed.

Lemma Forall2_in_right : forall {A B} (l : list A) (l' : list B) f,
  List.Forall2 f l l' ->
  forall a', List.In a' l' ->
               exists a, List.In a l /\ f a a'.
move => A B l l' f Hforall.
induction Hforall as [ | x x' l l' Hfxx Hforall IH].
- move => ? HIn; inv HIn.
- move => a' HIn.
  case: HIn => [Hleft | Hright].
  + subst.
    exists x.
    split => //=.
    by left.
  + pose proof IH a' as H.
    apply H in Hright; clear H.
    move: Hright => [a [HIn Hf]].
    exists a; split => //=.
    by right.
Qed.

Lemma Forall2_reg_aux : forall regs regs' (reg' : Atom) obs,
  List.Forall2 (fun (y : G register) (x : Atom) => semGenSize y size x)
          (map (gen_vary_atom obs inf) regs) regs' ->
  reg' \in regs' ->
  exists reg, reg \in regs /\ semGenSize (gen_vary_atom obs inf reg) size reg'.
move => regs regs' reg' obs Hforall /seq_InP HIn.
pose proof (Forall2_in_right (map (gen_vary_atom obs inf) regs) regs'
                             (fun (y : G Atom) (x : Atom) => semGenSize y size x)
                             Hforall reg' HIn) as H.
move : H => [a [HIn' Hf]].
apply List.in_map_iff in HIn'.
move : HIn' => [reg [Hgen HIn'']]; subst.
exists reg; split => //=.
by apply/seq_InP.
Qed.

  Opaque indist join flows gen_vary_atom.
Lemma gen_vary_stack_loc_correct : forall obs loc,
   (stack_loc_spec loc) ->
   semGenSize (gen_vary_stack_loc obs inf loc) size <-->
              (fun loc' => stack_loc_spec loc'  /\
                           if isLow (pc_lab (sf_return_addr loc)) obs
                           then indist obs loc loc'
                           else isHigh (pc_lab (sf_return_addr loc')) obs).
Opaque gen_vary_pc gen_label gen_from_nat_length.
rewrite /stack_loc_spec /gen_vary_stack_loc.
move => obs [[pc_addr pc_lab] regs ptr_r lab] [Hregs [Hptr [Haddr Hg]]] loc'.
split; simpl.
+ destruct (isLow pc_lab obs) eqn:Flows.
  * {
    move => /semBindSize [regs' [/semSequenceGenSize [Hlen Hforall]
                                 /semReturnSize H2]].
    inv H2.
    repeat split => //=.
    - rewrite List.map_length in Hlen.
      rewrite /regs_spec in Hregs.
      move: Hregs => [Hlen' _].
      by rewrite Hlen.
    - move => reg' HIn'.
      rewrite /regs_spec in Hregs.
      move: Hregs => [Hlen' Hreg].
      apply (Forall2_reg_aux _ _ reg' _) in Hforall => //=.
      move: Hforall => [reg [HIn Hsem]].
      pose proof (Hreg reg HIn) as AtomSpec.
      rewrite /atom_spec in AtomSpec.
      destruct reg eqn:Reg.
      pose proof (gen_vary_atom_correct obs (v @ l)).
      simpl in H.
      apply H in AtomSpec; clear H.
      apply AtomSpec in Hsem; clear AtomSpec.
      rewrite /atom_spec.
      destruct reg' eqn:Reg'.
      by move: Hsem => [_ Hspec].
Admitted.
(*    - rewrite /indist /= orbb !eqxx /= !andbT Flows.
      rewrite /indist /indistList.
      rewrite !size_length Hlen -!size_length size_map eqxx /=.
      apply/allP=> - [/= reg reg'] HIn.
      have H : List.In (reg', gen_vary_atom obs inf reg)
                  (seq.zip regs' (map (@gen_vary_atom obs inf) regs))
         by apply/in_map_zip/in_zip_swap/seq_InP.
      apply (Forall2_combine _ _ _ Hforall _) in H.
      simpl in H.
      destruct reg eqn:Reg.
      pose proof (gen_vary_atom_correct obs (v @ l)).
      simpl in H0.
      rewrite /regs_spec in Hregs.
      move : Hregs => [? Hspec].
      move/seq_InP in HIn.
      move: (in_zip regs regs' _ _ HIn) => {HIn} [/seq_InP HIn ?].
      rewrite -Reg in HIn.
      pose proof (Hspec reg HIn) as H'.
      rewrite /atom_spec in H'.
      rewrite Reg in H'.
      apply H0 in H'; clear H0.
      apply H' in H; clear H'.
      destruct reg'; subst.
      by move : H => [? _].
  }
  * {
    move => /semBindSize [regs' [/semVectorOfSize [HLen' Hregs']
                                 /semBindSize [pc' [Hpc'
                                 /semBindSize [lab' [Hlab
                                 /semBindSize [ptr_r' [Hptr'
                                 /semReturnSize H]]
                          ]]]]]].
    inv H.
    apply gen_vary_pc_correct in Hpc'.
    rewrite Flows in Hpc'.
    apply gen_from_nat_length_correct in Hptr'.
    repeat split => //=.
    + move => reg' HIn'.
      rewrite /set_incl in Hregs'.
      move/seq_InP in HIn'; apply Hregs' in HIn'.
      by apply gen_atom_correct in HIn'.
    + destruct pc' eqn:PC'.
      by move : Hpc' => [_ ?].
    + move: Hpc' => [Flows' Hpc'].
      rewrite /negb in Flows'.
      destruct (isLow ∂(pc') obs) eqn:Flows'' => //=.
    + apply no_regs_positive.
    + by split.
  }
+ move: loc' => [[pc_addr' pc_lab'] regs' ptr_r' lab'].
  simpl in *.
  move => [[[Hlen' Hregs'] [Hvalid Haddr']] Hindist].
  destruct (isLow pc_lab obs) eqn:Flows.
  * {
    apply semBindSize.
    exists regs'; split.
    - apply semSequenceGenSize; split.
      rewrite List.map_length.
      rewrite /regs_spec in Hregs.
      by move : Hregs => [-> _].
    - {
      apply seqzip__Forall2.
      + rewrite List.map_length.
        rewrite /regs_spec in Hregs.
        move : Hregs => [-> _].
        by apply /eqP.
      + move => [reg' g] HIn //=.
        apply in_map_zip_iff in HIn.
        move : HIn => [reg [Hgen HIn]].
        subst.
        pose proof (gen_vary_atom_correct obs reg).
        destruct reg eqn:Reg.
        move : (HIn) => HInZip.
        apply in_zip in HIn.
        move : HIn =>  [HIn1 HIn2].
        rewrite /regs_spec in Hregs.
        move : Hregs => [Hlen Hregs].
        move/seq_InP in HIn2.
        pose proof (Hregs (v @ l) HIn2) as Hspec.
        rewrite /atom_spec in Hspec.
        apply H in Hspec; clear H.
        apply Hspec.
        destruct reg' eqn:Reg'.
        * split => //=.
          subst.
          rewrite /indist /= Flows /= in Hindist.
          case/and4P: Hindist => [? Hindist ? ?].
          rewrite /indist /indistList in Hindist.
          move:  Hindist => /andP [? /allP H].
          apply in_zip_swap in HInZip.
          move/seq_InP in HInZip.
          by apply H in HInZip.
        * move/seq_InP in HIn1. by apply Hregs' in HIn1.
    }
    - apply semReturnSize.
      rewrite /indist /= Flows /= in Hindist.
      case/and4P: Hindist => [/eqP Heq1 Hindist /eqP Heq2 /eqP Heq3]; subst.
      by inv Heq1.
  }
  * apply semBindSize.
    exists regs'; split => //=.
    - apply semVectorOfSize; split => //=.
      move => reg' HIn'.
      apply gen_atom_correct.
      by apply Hregs'; apply/seq_InP.
   apply semBindSize.
   exists (PAtm pc_addr' pc_lab'); split => //=.
   - apply gen_vary_pc_correct.
     + by rewrite /pc_in_bounds.
     + rewrite Flows; split => //=.
   apply semBindSize.
   exists lab'; split => //=.
   - apply gen_label_correct => //.
   apply semBindSize.
   exists ptr_r'; split => //=.
   - by apply gen_from_nat_length_correct.
   by apply semReturnSize.
Qed.
*)
Lemma gen_vary_stack_correct :
  forall (st : Stack) obs,
    stack_spec st ->
    semGenSize (gen_vary_stack obs inf st) size <-->
    (fun st' => indist obs st st' /\
                stack_spec st' /\
                length (unStack st) = length (unStack st')).
Proof.
  move=> st obs Hspec st'.
  rewrite /stack_spec in Hspec.
  move : Hspec => [Heq | [loc [Heq Hspec]]].
 (* Stack empty *)
  - split.
    + inv Heq.
      rewrite /gen_vary_stack /gen_vary_low_stack.
      move => /semLiftGenSize H.
      inv H.
      move : H0 => [/= /semSequenceGenSize [len _] H].
      inv H.
      destruct x => //=.
      do 2 split => //=.
      by left.
    + inv Heq.
      move => [H1 [H2 H3]].
      destruct st' => //=.
      rewrite /gen_vary_stack /gen_vary_low_stack.
      apply semLiftGenSize.
      simpl.
      destruct l => //=.
      eexists; split => //=.
      apply semSequenceGenSize.
      split => //=.
 (* Stack Singleton *)
  - inv Heq. split.
    {
    + rewrite /gen_vary_stack /gen_vary_low_stack.
      move => /semLiftGenSize /= [st'' [/semSequenceGenSize [Hlen Hforall] H2]].
      inv H2.
      destruct st'' eqn:EqST.
      * inv Hlen.
      * { repeat split => //=.
          + {
            inv Hlen.
            destruct l => //=.
            inv Hforall.
            apply gen_vary_stack_loc_correct in H3 => //=.
            move : H3 => [? H].
Admitted.
(*
            rewrite /indist /indistStack.
            destruct loc eqn:Loc; destruct s eqn:S;
            destruct sf_return_addr0 eqn:Ret0;
            destruct sf_return_addr1 eqn:Ret1;
            simpl in *.
            destruct (isLow l obs) eqn:Flows.
            - { (* l <: obs *)
              rewrite /indist /= Flows /= in H.
              move/and4P: H => [/eqP Heq1 Hindist /eqP Heq3 /eqP Heq4]; subst.
              inv Heq1.
              by rewrite /indist /= /indist /= Flows /= !andbT !eqxx !andbT.
              }
            - by rewrite /indist /= /indist /= Flows (negbTE H) /=.
          }
          + rewrite /stack_spec. right.
            exists s; split => //=.
            * inv Hlen.
              destruct l => //=.
            * inv Hforall.
              inv H4.
              apply gen_vary_stack_loc_correct in H2 => //=.
              by move : H2 => [? _].
        }
    }
    (* Completeness *)
    + move => [Hindist [Hspec' Hlen]].
      rewrite /gen_vary_stack /gen_vary_low_stack.
      apply semLiftGenSize.
      case: st' Hindist Hspec' Hlen=> [[|loc' [|]]] //= /andP [_ /= /andP [Hindist _]].
      case=> [|[loc'' [[<-] {loc''} Hspec']]] // _.
      exists [:: loc']; split => //=; apply semSequenceGenSize; split => //=.
      constructor => //=; apply gen_vary_stack_loc_correct => //; split => //.
      case: loc loc' Hspec Hspec' Hindist
            => [[pc pcl] rs rr rl] [[pc' pcl'] rs' rr' rl'] /=.
      move=> Hspec Hspec' Hindist; rewrite Hindist.
      move: Hindist; rewrite /indist /=.
      case: ifP => [//|/= hi_pcl] /implyP H.
      apply/negP=> l_pcl'; case/andP: (H l_pcl') => [/eqP [??] _]; subst pcl'.
      by rewrite hi_pcl in l_pcl'.
Qed.
*)
(* Vary Memory *)

Definition frame_spec (fr : frame) :=
  let 'Fr _ data := fr in
      (forall a, List.In a data -> atom_spec a).

Lemma gen_vary_frame_correct :
  forall obs fr,
    (frame_spec fr) ->
    semGenSize (gen_var_frame obs inf fr) size <-->
    (fun fr' => indist obs fr fr' /\
     (frame_spec fr') /\
     let 'Fr _ data := fr in
     let 'Fr _ data' := fr' in
     length data <= length data' <= (length data) + 1).
Proof.
  move => obs [label data] HforallIn
              [label' data'].
  Opaque indist join flows gen_vary_atom.
  split.
Admitted.
(*
  { rewrite /gen_var_frame /indist /indistFrame.
      destruct (isLow label obs) eqn:Flows'.
      { (* label <: obs *)
        simpl in *.
        move => /semBindSize [data'' [/semSequenceGenSize [Hlen Hforall]
                                      /semReturnSize [eq1 eq2]]]; subst.
        rewrite List.map_length in Hlen.
        have Hindist_spec:
          (forall x y : Atom,
             List.In (x, y) (seq.zip data data') ->
             indist obs x y = true /\ atom_spec y).
          { move => [v1 l1] [v2 l2] HIn. apply in_zip_swap in HIn.
            move: (HIn) => HIn'. apply in_zip in HIn'.
            move: HIn' => [HIn1 Hval]. apply HforallIn in Hval.
            move : (Hval) => /(gen_vary_atom_correct obs (v1 @ l1)) Hequiv.
            apply in_map_zip with (f := (@gen_vary_atom obs inf)) in HIn.
            move: (HIn) => HIn'. apply in_zip in HIn.
            apply (Forall2_combine _ _ _ Hforall _) in HIn'.
            simpl in HIn'.
            apply Hequiv in HIn'.
            case : HIn' => [Hindist Hspec].
            by split => //.
          }
          rewrite !eqxx /=; split; last split.
          - rewrite /indist /indistList.
            rewrite !size_length Hlen eqxx /=.
            by apply/allP=> - [a1 a2] /seq_InP /Hindist_spec [].
          - move => [v2 l2] HIn2.
            move : (HIn2) => HIn2'. apply List.in_split in HIn2'.
            move : HIn2' => [data'_pre [data'_post Heq]].
            destruct data as [|data_hd data_tl].
            + rewrite Heq in Hlen.  rewrite List.app_length /= in Hlen. omega.
            + remember (data_hd :: data_tl) as data. clear Heqdata.
              remember (List.nth (length data'_pre) data data_hd) as y.
              destruct y as [v1 l1].
              have/Hindist_spec [_ Hspec] :
                List.In (v1 @ l1, v2 @ l2) (seq.zip data data').
              { apply in_nth_iff. exists (length data'_pre). split.
                - rewrite -nth_seqnth seq.nth_zip //.
                  * rewrite Heq !nth_seqnth List.app_nth2 // minus_diag.
                    rewrite (nth_foralldef _ _ _ (v1 @ l1)) in Heqy.
                      by rewrite -Heqy.
                  * rewrite -Hlen Heq List.app_length. apply/ltP.
                    apply NPeano.Nat.lt_add_pos_r. simpl. omega.
                - rewrite zip_combine // List.combine_length Hlen NPeano.Nat.min_id.
                  rewrite -Hlen Heq List.app_length. apply/ltP.
                  apply NPeano.Nat.lt_add_pos_r. simpl. omega. }
              assumption.
            + by rewrite Hlen leqnn /= leq_addr. }
        { (* label <: obs = false *)
          apply Bool.negb_true_iff in Flows'.
          move => /semBindSize [data'' [/semBindSize [len [/semChooseSize Hchoose
                                                           /semVectorOfSize [Hlen Hforall]]]
                                         /semReturnSize [eq1 eq2]]]; subst.
          assert (H : RandomQC.leq (length data) (length data).+1).
          {
            rewrite /RandomQC.leq.
            simpl.
            apply/leP.
            apply le_n_Sn.
          }
          apply Hchoose in H; clear Hchoose; rename H into Hchoose.
          move: Hchoose => /andP [Hle3 Hle4].
          simpl in Hle3, Hle4.
          repeat (split => //; try apply/andP); (try by rewrite addn1);
          try by apply flows_refl.
          by move => a /Hforall/gen_atom_correct Hin. }
    }
  { rewrite /indist /indistFrame /frame_spec /gen_var_frame.
    - move=> [/andP [/eqP H1 H2] [H3 H4]].
      subst.
      remember (flows label' obs) as b''; destruct b''; simpl in *;
      symmetry in Heqb''.
      + (* label' <: obs = true *)
        {
        apply semBindSize.
        exists data'. split => //. apply semSequenceGenSize.
        rewrite /indist /indistList in H2.
        move/andP : H2 => [/eqP Hlen' /allP HforallIn'].
        split => //.
        * by rewrite List.map_length -!size_length Hlen'.
        * apply seqzip__Forall2.
          - by rewrite List.map_length -!size_length Hlen'.
          - move => [a ga] /in_map_zip_iff [[v l] [Heq HIn]].
            simpl in *.
            move: (HIn) => /in_zip_swap/seq_InP/HforallIn' HInzip.
            apply in_zip in HIn. move : HIn => [HIn1 /HforallIn Hval].
            subst.
            apply (gen_vary_atom_correct obs (v @ l) Hval).
            destruct a eqn:A.
            split => //.
            apply H3 in HIn1.
            by rewrite /atom_spec in HIn1.
        * by apply semReturnSize.
        }
      + {
        apply semBindSize.
        exists data'. split => //.
        apply semBindSize.
        exists (length data'); split.
        * apply semChooseSize.
          - rewrite /RandomQC.leq.
            simpl.
            apply/leP.
            apply le_n_Sn.
          - move : H4 => /andP [Hle1 Hle2].
            simpl => //. apply /andP. split => //=.
            by rewrite -addn1.
        * apply semVectorOfSize. split => //.
          move => a Hin.
          apply /gen_atom_correct.
          by apply H3.
        * by apply semReturnSize.
        }
      }
Qed.
*)

Definition mem_spec (m : memory) :=
  forall mf l data,
    Mem.get_frame m mf = Some (Fr l data) ->
    (C.min_frame_size <= Z.of_nat (length data) <= C.max_frame_size)%Z /\
    (forall a, List.In a data -> atom_spec a) /\
    Mem.stamp mf = ⊥.

Lemma handle_single_mframe_correct :
  forall obs m mf fr,
    mem_spec m ->
    Mem.get_frame m mf = Some fr ->
    semGenSize (handle_single_mframe obs inf m mf) size <-->
    (fun m' =>
       forall mf',
         if mf == mf' then
           exists fr', Mem.get_frame m' mf = Some fr' /\
                       indist obs fr fr' /\
                       (frame_spec fr') /\
                       let 'Fr _ data := fr in
                       let 'Fr _ data' := fr' in
                       length data <= length data' <= (length data) + 1
         else Mem.get_frame m' mf' = Mem.get_frame m mf').
Proof.
move => obs m mf fr HmemSpec Hfr m'.
split.
+ {
  rewrite /handle_single_mframe.
  rewrite Hfr.
  move => /semBindSize [fr' [Hfr' H]].
  pose proof (Mem.upd_get_frame fr' Hfr) as Hm'.
  move: Hm' => [m'' Hm''].
  rewrite Hm'' in H.
  apply semReturnSize in H.
  inv H.
  rewrite /smart_vary /smart_vary_frame in Hfr'.
  apply gen_vary_frame_correct in Hfr'.
  move : Hfr' => [Hindist [Hspec Hlen]].
  destruct fr eqn:EqFr; destruct fr' eqn:EqFr'.
  move => mf'.
  have [e|ne] := altP (mf =P mf').
  - simpl.
    move: (e) => e'.
    exists (Fr label0 l0).
    split => //=.
    have : (Mem.upd_frame m mf (Fr label0 l0) = Some m') by subst.
    move => Hm.
    pose proof (Mem.get_upd_frame Hm mf') as H.
    rewrite e eqxx in H.
    by subst.
  - simpl.
    have : (Mem.upd_frame m mf (Fr label0 l0) = Some m') by subst.
    move => Hm.
    pose proof (Mem.get_upd_frame Hm mf') as H.
    rewrite (negbTE ne) in H.
    by subst.
  rewrite /mem_spec in HmemSpec.
  destruct fr.
  pose proof (HmemSpec mf label l Hfr) as H'; clear HmemSpec.
  by move : H' => [_ [? _]].
}
+ move => H.
  rewrite /handle_single_mframe Hfr.
  apply semBindSize.
  pose proof (H mf) as Hyp.
  rewrite eqxx in Hyp.
  move : Hyp => [fr' [Hget [Hindist [Hfr' Hlen]]]].
  exists fr'.
  split => //=.
  - apply gen_vary_frame_correct.
    rewrite /mem_spec in HmemSpec.
    destruct fr; destruct fr'.
    pose proof (HmemSpec _ _ _ Hfr) as H'.
    by move : H' => [_ [? _]].
  - split => //=.
    pose proof (Mem.upd_get_frame fr' Hfr) as Hm'.
    move : Hm' => [m'' Hm''].
    rewrite Hm''.

    have : (forall block, Mem.get_frame m' block = Mem.get_frame m'' block).
    {
      move => block.
      have := H block.
      have [e|ne] := altP (mf =P block).
      + subst.
        pose proof (Mem.get_upd_frame Hm'' block) as Hyp.
        by rewrite Hyp eqxx Hget.
      + pose proof (H block) as Hb.
        pose proof (Mem.get_upd_frame Hm'' block) as Hyp.
        by move: Hb Hyp; rewrite (negbTE ne)=> ? -> ?.
    }
    move => MemExt.

    pose proof (Mem.memory_extensionality  MemExt).
    subst.
    by apply semReturnSize.
Qed.

Require Import ZArith.

Lemma gen_variation_state_correct :
  semGenSize gen_variation_state size <--> (fun b =>
                              let '(Var l s1 s2) := b in
                              indist l s1 s2 = true).
Proof.
  (* The statement is not complete as we need the states to satisfy
     some validity requirements *)
Abort.
  (* case => Lab s1 s2. split. rewrite /gen_variation_state.  *)
  (* rewrite bindGen_def.  *)
  (* move => [l1 [Htop H]].  *)
  (* rewrite bindGen_def in H.  *)
  (* move: H => [[mem mframes] [Hinit H]].  *)
  (* case: mframes Hinit H => [ | mframe1 mframes] Hinit H. *)
  (* - rewrite returnGen_def /= in H.  *)
  (*   move : H => [Heq1 Heq2 Heq3]. subst.  *)
  (*   rewrite /indist /indistState /failed_state !trace_axiom //=. *)
  (*   rewrite /label_eq /isHigh /isLow /flows. simpl.  *)
  (*   have Ht: Zset.incl Zset.empty Zset.empty = true by *)
  (*       apply/Zset.incl_spec; rewrite Zset.elements_empty.  *)
  (*   rewrite Ht -beq_nat_refl /indistMemHelper.  *)
  (*   simpl. by rewrite forallb_indist. *)
  (* - case : mframe1 Hinit H => mf1 Z1 Hinit H1. *)
  (*   rewrite bindGen_def in H1. *)
  (*   move:  H1 => [ptr_a [sgen H1]].  *)
  (*   rewrite bindGen_def in H1. *)
  (*   move:  H1 => [regset [sgen2 H1]].  *)
  (*   rewrite bindGen_def in H1. *)
  (*   move:  H1 => [st [sgen3 H1]].  *)
  (*   rewrite bindGen_def in H1. *)
  (*   move:  H1 => [memg [sgen4 H1]].  *)
  (*   rewrite bindGen_def in H1. *)
  (*   move:  H1 => [instr [sgen5 H1]].  *)
  (*   rewrite bindGen_def in H1. *)
  (*   move:  H1 => [lab [sgen6 H1]].  *)
  (*   rewrite bindGen_def in H1. *)
  (*   move:  H1 => [ST' [sgen7 H1]].      *)
  (*   rewrite returnGen_def in H1. *)
  (*   move : H1 => [Heq1 Heq2 Heq3]; subst. *)
  (*   rewrite /smart_gen in sgen, sgen2, sgen3, sgen4, sgen5, sgen6, sgen7 . *)

End WithDataLenNonEmpty.

End Sized.


From isla Require Import opsem.

Definition a0 : isla_trace :=
  Smt (DeclareConst 0%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "PC" [] (RegVal_Base (Val_Symbolic 0%Z)) Mk_annot :t:
  Smt (DefineConst 1%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 0%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "x10" [] (RegVal_Base (Val_Bits (BV 64%N 0x0%Z))) Mk_annot :t:
  WriteReg "PC" [] (RegVal_Base (Val_Symbolic 1%Z)) Mk_annot :t:
  tnil
.