(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*          Jacques-Henri Jourdan, INRIA Paris-Rocquencourt            *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Formalization of floating-point numbers, using the Flocq library. *)

Require Import Axioms.
Require Import Coqlib.
Require Import Integers.
Require Import Reals.
Require Import Fappli_IEEE.
Require Import Fappli_IEEE_bits.
Require Import Fcore.
Require Import Fcalc_round.
Require Import Fcalc_bracket.
Require Import Fprop_Sterbenz.
Require Import Program.
Require Import Omega.

Close Scope R_scope.

Definition float := binary64. (**r the type of IEE754 doubles *)

Module Float.

Definition zero: float := B754_zero _ _ false. (**r the float [+0.0] *)

Definition eq_dec: forall (f1 f2: float), {f1 = f2} + {f1 <> f2}.
Proof.
  Ltac try_not_eq := try solve [right; congruence].
  destruct f1, f2;
  try destruct b; try destruct b0;
  try solve [left; auto]; try_not_eq;
  destruct (positive_eq_dec m m0); try_not_eq;
  destruct (Z_eq_dec e e1); try solve [right; intro H; inv H; congruence];
  subst; left; rewrite (proof_irr e0 e2); auto.
Defined.

(** Arithmetic operations *)

Definition neg: float -> float := b64_opp. (**r opposite (change sign) *)
Definition abs (x: float): float := (**r absolute value (set sign to [+]) *)
  match x with
  | B754_nan => x
  | B754_infinity _ => B754_infinity _ _ false
  | B754_finite _ m e H => B754_finite _ _ false m e H
  | B754_zero _ => B754_zero _ _ false
  end.

Definition binary_normalize64 (m e:Z) (s:bool): float :=
  binary_normalize 53 1024 eq_refl eq_refl mode_NE m e s.

Definition binary_normalize64_correct (m e:Z) (s:bool) :=
  binary_normalize_correct 53 1024 eq_refl eq_refl mode_NE m e s.
Global Opaque binary_normalize64_correct.

Definition floatofbinary32 (f: binary32) : float := (**r single precision embedding in double precision *)
  match f with
    | B754_nan => B754_nan _ _
    | B754_infinity s => B754_infinity _ _ s
    | B754_zero s => B754_zero _ _ s
    | B754_finite s m e _ =>
      binary_normalize64 (cond_Zopp s (Zpos m)) e s
  end.

Definition binary32offloat (f: float) : binary32 := (**r conversion to single precision *)
  match f with
    | B754_nan => B754_nan _ _
    | B754_infinity s => B754_infinity _ _ s
    | B754_zero s => B754_zero _ _ s
    | B754_finite s m e _ =>
      binary_normalize 24 128 eq_refl eq_refl mode_NE (cond_Zopp s (Zpos m)) e s
  end.

Definition singleoffloat (f: float): float := (**r conversion to single precision, embedded in double *)
  floatofbinary32 (binary32offloat f).

Definition Zoffloat (f:float): option Z := (**r conversion to Z *)
  match f with
    | B754_finite s m (Zpos e) _ => Some (cond_Zopp s (Zpos m) * Zpower_pos radix2 e)
    | B754_finite s m 0 _ => Some (cond_Zopp s (Zpos m))
    | B754_finite s m (Zneg e) _ => Some (cond_Zopp s (Zpos m / Zpower_pos radix2 e))
    | B754_zero _ => Some 0
    | _ => None
  end.

Definition intoffloat (f:float): option int := (**r conversion to signed 32-bit int *)
  match Zoffloat f with
    | Some n =>
      if Zle_bool Int.min_signed n && Zle_bool n Int.max_signed then
        Some (Int.repr n)
      else
        None
    | None => None
  end.

Definition intuoffloat (f:float): option int := (**r conversion to unsigned 32-bit int *)
  match Zoffloat f with
    | Some n =>
      if Zle_bool 0 n && Zle_bool n Int.max_unsigned then
        Some (Int.repr n)
      else
        None
    | None => None
  end.

Definition floatofint (n:int): float := (**r conversion from signed 32-bit int *)
  binary_normalize64 (Int.signed n) 0 false.
Definition floatofintu (n:int): float:= (**r conversion from unsigned 32-bit int *)
  binary_normalize64 (Int.unsigned n) 0 false.
Definition add: float -> float -> float := b64_plus mode_NE. (**r addition *)
Definition sub: float -> float -> float := b64_minus mode_NE. (**r subtraction *)
Definition mul: float -> float -> float := b64_mult mode_NE. (**r multiplication *)
Definition div: float -> float -> float := b64_div mode_NE. (**r division *)

Definition order_float (f1 f2:float): option Datatypes.comparison :=
  match f1, f2 with
    | B754_nan,_ | _,B754_nan => None
    | B754_infinity true, B754_infinity true
    | B754_infinity false, B754_infinity false => Some Eq
    | B754_infinity true, _ => Some Lt
    | B754_infinity false, _ => Some Gt
    | _, B754_infinity true => Some Gt
    | _, B754_infinity false => Some Lt
    | B754_finite true _ _ _, B754_zero _ => Some Lt
    | B754_finite false _ _ _, B754_zero _ => Some Gt
    | B754_zero _, B754_finite true _ _ _ => Some Gt
    | B754_zero _, B754_finite false _ _ _ => Some Lt
    | B754_zero _, B754_zero _ => Some Eq
    | B754_finite s1 m1 e1 _, B754_finite s2 m2 e2 _ =>
      match s1, s2 with
        | true, false => Some Lt
        | false, true => Some Gt
        | false, false =>
          match Zcompare e1 e2 with
            | Lt => Some Lt
            | Gt => Some Gt
            | Eq => Some (Pcompare m1 m2 Eq)
          end
        | true, true =>
          match Zcompare e1 e2 with
            | Lt => Some Gt
            | Gt => Some Lt
            | Eq => Some (CompOpp (Pcompare m1 m2 Eq))
          end
      end
  end.

Definition cmp (c:comparison) (f1 f2:float) : bool := (**r comparison *)
  match c with
  | Ceq =>
      match order_float f1 f2 with Some Eq => true | _ => false end
  | Cne =>
      match order_float f1 f2 with Some Eq => false | _ => true end
  | Clt =>
      match order_float f1 f2 with Some Lt => true | _ => false end
  | Cle =>
      match order_float f1 f2 with Some(Lt|Eq) => true | _ => false end
  | Cgt =>
      match order_float f1 f2 with Some Gt => true | _ => false end
  | Cge =>
      match order_float f1 f2 with Some(Gt|Eq) => true | _ => false end
  end.

(** Conversions between floats and their concrete in-memory representation
    as a sequence of 64 bits (double precision) or 32 bits (single precision). *)

Definition bits_of_double (f: float): int64 := Int64.repr (bits_of_b64 f).
Definition double_of_bits (b: int64): float := b64_of_bits (Int64.unsigned b).

Definition bits_of_single (f: float) : int := Int.repr (bits_of_b32 (binary32offloat f)).
Definition single_of_bits (b: int): float := floatofbinary32 (b32_of_bits (Int.unsigned b)).

Definition from_words (hi lo: int) : float :=
  double_of_bits
    (Int64.or (Int64.shl (Int64.repr (Int.unsigned hi)) (Int64.repr 32))
              (Int64.repr (Int.unsigned lo))).

Lemma from_words_eq:
  forall lo hi,
  from_words hi lo =
  double_of_bits (Int64.repr (Int.unsigned hi * two_p 32 + Int.unsigned lo)).
Proof.
  intros. unfold from_words. decEq.
  rewrite Int64.shifted_or_is_add.
  apply Int64.eqm_samerepr. auto with ints.
  change (Z_of_nat Int64.wordsize) with 64. omega.
  generalize (Int.unsigned_range lo). intros [A B].
  rewrite Int64.unsigned_repr. assumption.
  assert (Int.modulus < Int64.max_unsigned). compute; auto. omega.
Qed.

(** Below are the only properties of floating-point arithmetic that we
  rely on in the compiler proof. *)

(** Some tactics **)

Ltac compute_this val :=
  let x := fresh in set val as x in *; vm_compute in x; subst x.

Ltac smart_omega :=
  simpl radix_val in *; simpl Zpower in *;
  compute_this Int.modulus; compute_this Int.half_modulus;
  compute_this Int.max_unsigned;
  compute_this Int.min_signed; compute_this Int.max_signed;
  compute_this Int64.modulus; compute_this Int64.half_modulus;
  compute_this Int64.max_unsigned;
  compute_this (Zpower_pos 2 1024); compute_this (Zpower_pos 2 53); compute_this (Zpower_pos 2 52);
  omega.

Theorem addf_commut: forall f1 f2, add f1 f2 = add f2 f1.
Proof.
  intros.
  destruct f1, f2; simpl; try reflexivity; try (destruct b, b0; reflexivity).
  rewrite Zplus_comm; rewrite Zmin_comm; reflexivity.
Qed.

Theorem subf_addf_opp: forall f1 f2, sub f1 f2 = add f1 (neg f2).
Proof.
  destruct f1, f2; reflexivity.
Qed.

Lemma floatofbinary32_exact :
  forall f, is_finite_strict _ _ f = true ->
    is_finite_strict _ _ (floatofbinary32 f) = true /\ B2R _ _ f = B2R _ _ (floatofbinary32 f).
Proof.
  destruct f as [ | | |s m e]; try discriminate; intro.
  pose proof (binary_normalize64_correct (cond_Zopp s (Zpos m)) e s).
  match goal with [H0:if Rlt_bool (Rabs ?x) _ then _ else _ |- _ /\ ?y = _] => assert (x=y)%R end.
  apply round_generic; [now apply valid_rnd_round_mode|].
  apply (generic_inclusion_ln_beta _ (FLT_exp (3 - 128 - 24) 24)).
  intro; eapply Zle_trans; [apply Zle_max_compat_l | apply Zle_max_compat_r]; omega.
  apply generic_format_canonic; apply canonic_canonic_mantissa; apply (proj1 (andb_prop _ _ e0)).
  rewrite H1, Rlt_bool_true in H0; intuition; unfold floatofbinary32, binary_normalize64.
  match goal with [ |- _ _ _ ?x = true ] => destruct x end; try discriminate.
  symmetry in H2; apply F2R_eq_0_reg in H2; destruct s; discriminate.
  reflexivity.
  eapply Rlt_trans.
  unfold B2R; rewrite <- F2R_Zabs, abs_cond_Zopp; eapply bounded_lt_emax; now apply e0.
  now apply bpow_lt.
Qed.

Lemma binary32offloatofbinary32 :
  forall f, binary32offloat (floatofbinary32 f) = f.
Proof.
  intro; pose proof (floatofbinary32_exact f); destruct f as [ | | |s m e]; try reflexivity.
  specialize (H eq_refl); destruct H.
  destruct (floatofbinary32 (B754_finite 24 128 s m e e0)) as [ | | |s1 m1 e1]; try discriminate.
  unfold binary32offloat.
  pose proof (binary_normalize_correct 24 128 eq_refl eq_refl mode_NE (cond_Zopp s1 (Zpos m1)) e1 s1).
  unfold B2R at 2 in H0; cbv iota zeta beta in H0; rewrite <- H0, round_generic in H1.
  rewrite Rlt_bool_true in H1.
  apply B2R_inj; intuition; match goal with [|- _ _ _ ?f = true] => destruct f end; try discriminate.
  symmetry in H2; apply F2R_eq_0_reg in H2; destruct s; discriminate.
  reflexivity.
  unfold B2R; rewrite <- F2R_Zabs, abs_cond_Zopp; eapply bounded_lt_emax; apply e0.
  now apply valid_rnd_round_mode.
  now apply generic_format_B2R.
Qed.

Theorem singleoffloat_idem:
  forall f, singleoffloat (singleoffloat f) = singleoffloat f.
Proof.
  intros; unfold singleoffloat; rewrite binary32offloatofbinary32; reflexivity.
Qed.

(** Properties of comparisons. *)

Theorem order_float_finite_correct:
  forall f1 f2, is_finite _ _ f1 = true -> is_finite _ _ f2 = true ->
    match order_float f1 f2 with
      | Some c => Rcompare (B2R _ _ f1) (B2R _ _ f2) = c
      | None => False
    end.
Proof.
  Ltac apply_Rcompare :=
    match goal with
      | [ |- Rcompare _ _ = Lt ] => apply Rcompare_Lt
      | [ |- Rcompare _ _ = Eq ] => apply Rcompare_Eq
      | [ |- Rcompare _ _ = Gt ] => apply Rcompare_Gt
    end.
  unfold order_float; intros.
  destruct f1, f2; try discriminate; unfold B2R, F2R, Fnum, Fexp, cond_Zopp;
    try (replace 0%R with (Z2R 0 * bpow radix2 e)%R by (simpl Z2R; ring);
         rewrite Rcompare_mult_r by (apply bpow_gt_0); rewrite Rcompare_Z2R).
  apply_Rcompare; reflexivity.
  destruct b0; reflexivity.
  destruct b; reflexivity.
  clear H H0.
  apply andb_prop in e0; destruct e0; apply (canonic_canonic_mantissa _ _ false) in H.
  apply andb_prop in e2; destruct e2; apply (canonic_canonic_mantissa _ _ false) in H1.
  pose proof (Zcompare_spec e e1); unfold canonic, Fexp in H1, H.
  assert (forall m1 m2 e1 e2,
    let x := (Z2R (Zpos m1) * bpow radix2 e1)%R in
    let y := (Z2R (Zpos m2) * bpow radix2 e2)%R in
    canonic_exp radix2 (FLT_exp (3-1024-53) 53) x < canonic_exp radix2 (FLT_exp (3-1024-53) 53) y -> (x < y)%R).
  intros; apply Rnot_le_lt; intro; apply (ln_beta_le radix2) in H5.
  apply (fexp_monotone 53 1024) in H5; unfold canonic_exp in H4; omega.
  apply Rmult_gt_0_compat; [apply (Z2R_lt 0); reflexivity|now apply bpow_gt_0].
  assert (forall m1 m2 e1 e2, (Z2R (- Zpos m1) * bpow radix2 e1 < Z2R (Zpos m2) * bpow radix2 e2)%R).
  intros; apply (Rlt_trans _ 0%R).
  replace 0%R with (0*bpow radix2 e0)%R by ring; apply Rmult_lt_compat_r;
    [apply bpow_gt_0; reflexivity|now apply (Z2R_lt _ 0)].
  apply Rmult_gt_0_compat; [apply (Z2R_lt 0); reflexivity|now apply bpow_gt_0].
  destruct b, b0; try (now apply_Rcompare; apply H5); inversion H3;
    try (apply_Rcompare; apply H4; rewrite H, H1 in H7; assumption);
    try (apply_Rcompare; do 2 rewrite Z2R_opp, Ropp_mult_distr_l_reverse;
      apply Ropp_lt_contravar; apply H4; rewrite H, H1 in H7; assumption);
    rewrite H7, Rcompare_mult_r, Rcompare_Z2R by (apply bpow_gt_0); reflexivity.
Qed.

Theorem cmp_swap:
  forall c x y, Float.cmp (swap_comparison c) x y = Float.cmp c y x.
Proof.
  destruct c, x, y; simpl; try destruct b; try destruct b0; try reflexivity;
  rewrite <- (Zcompare_antisym e e1); destruct (e ?= e1); try reflexivity;
  change Eq with (CompOpp Eq); rewrite <- (Pcompare_antisym m m0 Eq);
    simpl; destruct ((m ?= m0)%positive Eq); try reflexivity.
Qed.

Theorem cmp_ne_eq:
  forall f1 f2, cmp Cne f1 f2 = negb (cmp Ceq f1 f2).
Proof.
  unfold cmp; intros; destruct (order_float f1 f2) as [ [] | ]; reflexivity.
Qed.

Theorem cmp_lt_eq_false:
  forall f1 f2, cmp Clt f1 f2 = true -> cmp Ceq f1 f2 = true -> False.
Proof.
  unfold cmp; intros; destruct (order_float f1 f2) as [ [] | ]; discriminate.
Qed.

Theorem cmp_le_lt_eq:
  forall f1 f2, cmp Cle f1 f2 = cmp Clt f1 f2 || cmp Ceq f1 f2.
Proof.
  unfold cmp; intros; destruct (order_float f1 f2) as [ [] | ]; reflexivity.
Qed.

Corollary cmp_gt_eq_false:
  forall x y, cmp Cgt x y = true -> cmp Ceq x y = true -> False.
Proof.
  intros; rewrite <- cmp_swap in H; rewrite <- cmp_swap in H0;
  eapply cmp_lt_eq_false; now eauto.
Qed.

Corollary cmp_ge_gt_eq:
  forall f1 f2, cmp Cge f1 f2 = cmp Cgt f1 f2 || cmp Ceq f1 f2.
Proof.
  intros.
  change Cge with (swap_comparison Cle); change Cgt with (swap_comparison Clt);
    change Ceq with (swap_comparison Ceq).
  repeat rewrite cmp_swap.
  now apply cmp_le_lt_eq.
Qed.

(** Properties of conversions to/from in-memory representation.
  The double-precision conversions are bijective (one-to-one).
  The single-precision conversions lose precision exactly
  as described by [singleoffloat] rounding. *)

Theorem double_of_bits_of_double:
  forall f, double_of_bits (bits_of_double f) = f.
Proof.
  intros; unfold double_of_bits, bits_of_double, bits_of_b64, b64_of_bits.
  rewrite Int64.unsigned_repr, binary_float_of_bits_of_binary_float; [reflexivity|].
  destruct f.
  simpl; try destruct b; vm_compute; split; congruence.
  simpl; try destruct b; vm_compute; split; congruence.
  simpl; vm_compute; split; congruence.
  unfold bits_of_binary_float, join_bits.
  destruct (andb_prop _ _ e0); apply Zle_bool_imp_le in H0; apply Zeq_bool_eq in H; unfold FLT_exp in H.
  match goal with [H:Zmax ?x ?y = e|-_] => pose proof (Zle_max_l x y); pose proof (Zle_max_r x y) end.
  rewrite H, Fcalc_digits.Z_of_nat_S_digits2_Pnat in *.
  lapply (Fcalc_digits.Zpower_gt_Zdigits radix2 53 (Zpos m)). intro.
  unfold radix2, radix_val, Zabs in H3.
  pose proof (Zle_bool_spec (2 ^ 52) (Zpos m)).
  assert (Zpos m > 0); [vm_compute; exact eq_refl|].
  compute_this (2^11); compute_this (2^(11-1)).
  inversion H4; fold (2^52) in *; destruct H6; destruct b; now smart_omega.
  change Fcalc_digits.radix2 with radix2 in H1; omega.
Qed.

Theorem single_of_bits_of_single:
  forall f, single_of_bits (bits_of_single f) = singleoffloat f.
Proof.
  intros; unfold single_of_bits, bits_of_single, bits_of_b32, b32_of_bits.
  rewrite Int.unsigned_repr, binary_float_of_bits_of_binary_float; [reflexivity|].
  destruct (binary32offloat f).
  simpl; try destruct b; vm_compute; split; congruence.
  simpl; try destruct b; vm_compute; split; congruence.
  simpl; vm_compute; split; congruence.
  unfold bits_of_binary_float, join_bits.
  destruct (andb_prop _ _ e0); apply Zle_bool_imp_le in H0; apply Zeq_bool_eq in H.
  unfold FLT_exp in H.
  match goal with [H:Zmax ?x ?y = e|-_] => pose proof (Zle_max_l x y); pose proof (Zle_max_r x y) end.
  rewrite H, Fcalc_digits.Z_of_nat_S_digits2_Pnat in *.
  lapply (Fcalc_digits.Zpower_gt_Zdigits radix2 24 (Zpos m)). intro.
  unfold radix2, radix_val, Zabs in H3.
  pose proof (Zle_bool_spec (2 ^ 23) (Zpos m)).
  compute_this (2^23); compute_this (2^24); compute_this (2^8); compute_this (2^(8-1)).
  assert (Zpos m > 0); [exact eq_refl|].
  inversion H4; destruct b; now smart_omega.
  change Fcalc_digits.radix2 with radix2 in H1; omega.
Qed.

Theorem bits_of_singleoffloat:
  forall f, bits_of_single (singleoffloat f) = bits_of_single f.
Proof.
  intro; unfold singleoffloat, bits_of_single; rewrite binary32offloatofbinary32; reflexivity.
Qed.

Theorem singleoffloat_of_bits:
  forall b, singleoffloat (single_of_bits b) = single_of_bits b.
Proof.
  intro; unfold singleoffloat, single_of_bits; rewrite binary32offloatofbinary32; reflexivity.
Qed.

(** Conversions between floats and unsigned ints can be defined
  in terms of conversions between floats and signed ints.
  (Most processors provide only the latter, forcing the compiler
  to emulate the former.)   *)

Definition ox8000_0000 := Int.repr Int.half_modulus.  (**r [0x8000_0000] *)

Lemma round_exact:
  forall n, -2^52 < n < 2^52 ->
    round radix2 (FLT_exp (3 - 1024 - 53) 53)
      (round_mode mode_NE) (Z2R n) = Z2R n.
Proof.
  intros; rewrite round_generic; [reflexivity|now apply valid_rnd_round_mode|].
  apply generic_format_FLT; exists (Float radix2 n 0).
  unfold F2R, Fnum, Fexp, bpow; rewrite Rmult_1_r; intuition.
  pose proof (Zabs_spec n); now smart_omega.
Qed.

Lemma binary_normalize64_exact:
  forall n, -2^52 < n < 2^52 ->
    B2R _ _ (binary_normalize64 n 0 false) = Z2R n /\
    is_finite _ _ (binary_normalize64 n 0 false) = true.
Proof.
  intros; pose proof (binary_normalize64_correct n 0 false).
  unfold F2R, Fnum, Fexp, bpow in H0; rewrite Rmult_1_r, round_exact, Rlt_bool_true in H0; try assumption.
  rewrite <- Z2R_abs; apply Z2R_lt; pose proof (Zabs_spec n); now smart_omega.
Qed.

Theorem floatofintu_floatofint_1:
  forall x,
  Int.ltu x ox8000_0000 = true ->
  floatofintu x = floatofint x.
Proof.
  unfold floatofintu, floatofint, Int.signed, Int.ltu; intro.
  change (Int.unsigned ox8000_0000) with Int.half_modulus.
  destruct (zlt (Int.unsigned x) Int.half_modulus); now intuition.
Qed.

Theorem floatofintu_floatofint_2:
  forall x,
  Int.ltu x ox8000_0000 = false ->
  floatofintu x = add (floatofint (Int.sub x ox8000_0000))
                      (floatofintu ox8000_0000).
Proof.
  unfold floatofintu, floatofint, Int.signed, Int.ltu, Int.sub; intros.
  pose proof (Int.unsigned_range x).
  compute_this (Int.unsigned ox8000_0000).
  destruct (zlt (Int.unsigned x) 2147483648); try  discriminate.
  rewrite Int.unsigned_repr by smart_omega.
  destruct (zlt ((Int.unsigned x) - 2147483648) Int.half_modulus).
  unfold add, b64_plus.
  match goal with [|- _ = Bplus _ _ _ _ _ ?x ?y] =>
    pose proof (Bplus_correct 53 1024 eq_refl eq_refl mode_NE x y) end.
  do 2 rewrite (fun x H => proj1 (binary_normalize64_exact x H)) in H1 by smart_omega.
  do 2 rewrite (fun x H => proj2 (binary_normalize64_exact x H)) in H1 by smart_omega.
  rewrite <- Z2R_plus, round_exact in H1 by smart_omega.
  rewrite Rlt_bool_true in H1;
    replace (Int.unsigned x - 2147483648 + 2147483648) with (Int.unsigned x) in * by ring.
  apply B2R_inj.
  destruct (binary_normalize64_exact (Int.unsigned x)); [now smart_omega|].
  match goal with [|- _ _ _ ?f = _] => destruct f end; intuition.
  exfalso; simpl in H2; change 0%R with (Z2R 0) in H2; apply eq_Z2R in H2; omega.
  simpl Zcompare in *.
  match goal with [|- _ _ _ ?f = _] => destruct f end; intuition.
  exfalso; simpl in H0; change 0%R with (Z2R 0) in H0; apply eq_Z2R in H0; omega.
  rewrite (fun x H => proj1 (binary_normalize64_exact x H)) by smart_omega; now intuition.
  rewrite <- Z2R_Zpower, <- Z2R_abs by omega; apply Z2R_lt;
    pose proof (Zabs_spec (Int.unsigned x)); now smart_omega.
  exfalso; now smart_omega.
Qed.

Theorem Zoffloat_correct:
  forall f,
    match Zoffloat f with
      | Some n =>
        is_finite _ _ f = true /\
        Z2R n = round radix2 (FIX_exp 0) (round_mode mode_ZR) (B2R _ _ f)
      | None =>
        is_finite _ _ f = false
    end.
Proof.
  destruct f; try now intuition.
  simpl B2R. rewrite round_0. now intuition. now apply valid_rnd_round_mode.
  destruct e. split. reflexivity.
  rewrite round_generic. symmetry. now apply Rmult_1_r.
  now apply valid_rnd_round_mode.
  apply generic_format_FIX. exists (Float radix2 (cond_Zopp b (Zpos m)) 0). split; reflexivity.
  split; [reflexivity|].
  rewrite round_generic, Z2R_mult, Z2R_Zpower_pos, <- bpow_powerRZ;
    [reflexivity|now apply valid_rnd_round_mode|apply generic_format_F2R; discriminate].
  rewrite (inbetween_float_ZR_sign _ _ _ ((Zpos m) / Zpower_pos radix2 p)
    (new_location (Zpower_pos radix2 p) (Zpos m mod Zpower_pos radix2 p) loc_Exact)).
  unfold B2R, F2R, Fnum, Fexp, canonic_exp, bpow, FIX_exp, Zoffloat, radix2, radix_val.
  pose proof (Rlt_bool_spec (Z2R (cond_Zopp b (Zpos m)) * / Z2R (Zpower_pos 2 p)) 0).
  inversion H; rewrite <- (Rmult_0_l (bpow radix2 (Zneg p))) in H1.
  apply Rmult_lt_reg_r in H1. apply (lt_Z2R _ 0) in H1.
  destruct b; [split; [|ring_simplify];reflexivity|discriminate].
  now apply bpow_gt_0.
  apply Rmult_le_reg_r in H1. apply (le_Z2R 0) in H1.
  destruct b; [destruct H1|split; [|ring_simplify]]; reflexivity.
  now apply (bpow_gt_0 radix2 (Zneg p)).
  unfold canonic_exp, FIX_exp; replace 0 with (Zneg p + Zpos p) by apply Zplus_opp_r.
  apply (inbetween_float_new_location radix2 _ _ _ _ (Zpos p)); [reflexivity|].
  apply inbetween_Exact; unfold B2R, F2R, Fnum, Fexp; destruct b.
  rewrite  Rabs_left; [simpl; ring_simplify; reflexivity|].
  replace 0%R with (0*(bpow radix2 (Zneg p)))%R by ring; apply Rmult_gt_compat_r.
  now apply bpow_gt_0.
  apply (Z2R_lt _ 0); reflexivity.
  apply Rabs_right; replace 0%R with (0*(bpow radix2 (Zneg p)))%R by ring; apply Rgt_ge.
  apply Rmult_gt_compat_r; [now apply bpow_gt_0|apply (Z2R_lt 0); reflexivity].
Qed.

Theorem intoffloat_correct:
  forall f,
    match intoffloat f with
      | Some n =>
        is_finite _ _ f = true /\
        Z2R (Int.signed n) = round radix2 (FIX_exp 0) (round_mode mode_ZR) (B2R _ _ f)
      | None =>
        is_finite _ _ f = false \/
        (B2R _ _ f <= Z2R (Zpred Int.min_signed)\/
        Z2R (Zsucc Int.max_signed) <= B2R _ _ f)%R
    end.
Proof.
  intro; pose proof (Zoffloat_correct f); unfold intoffloat; destruct (Zoffloat f).
  pose proof (Zle_bool_spec Int.min_signed z); pose proof (Zle_bool_spec z Int.max_signed).
  compute_this Int.min_signed; compute_this Int.max_signed; destruct H.
  inversion H0; [inversion H1|].
  rewrite <- (Int.signed_repr z) in H2 by smart_omega; split; assumption.
  right; right; eapply Rle_trans; [apply Z2R_le; apply Zlt_le_succ; now apply H6|].
  rewrite H2, round_ZR_pos.
  unfold round, scaled_mantissa, canonic_exp, FIX_exp, F2R, Fnum, Fexp; simpl bpow.
  do 2 rewrite Rmult_1_r; now apply Zfloor_lb.
  apply Rnot_lt_le; intro; apply Rlt_le in H7; apply (round_le radix2 (FIX_exp 0) (round_mode mode_ZR)) in H7;
    rewrite <- H2, round_0 in H7; [apply (le_Z2R _ 0) in H7; now smart_omega|now apply valid_rnd_round_mode].
  right; left; eapply Rle_trans; [|apply (Z2R_le z); simpl; omega].
  rewrite H2, round_ZR_neg.
  unfold round, scaled_mantissa, canonic_exp, FIX_exp, F2R, Fnum, Fexp; simpl bpow.
  do 2 rewrite Rmult_1_r; now apply Zceil_ub.
  apply Rnot_lt_le; intro; apply Rlt_le in H5; apply (round_le radix2 (FIX_exp 0) (round_mode mode_ZR)) in H5.
  rewrite <- H2, round_0 in H5; [apply (le_Z2R 0) in H5; omega|now apply valid_rnd_round_mode].
  left; assumption.
Qed.

Theorem intuoffloat_correct:
  forall f,
    match intuoffloat f with
      | Some n =>
        is_finite _ _ f = true /\
        Z2R (Int.unsigned n) = round radix2 (FIX_exp 0) (round_mode mode_ZR) (B2R _ _ f)
      | None =>
        is_finite _ _ f = false \/
        (B2R _ _ f <= -1 \/
        Z2R (Zsucc Int.max_unsigned) <= B2R _ _ f)%R
    end.
Proof.
  intro; pose proof (Zoffloat_correct f); unfold intuoffloat; destruct (Zoffloat f).
  pose proof (Zle_bool_spec 0 z); pose proof (Zle_bool_spec z Int.max_unsigned).
  compute_this Int.max_unsigned; destruct H.
  inversion H0. inversion H1.
  rewrite <- (Int.unsigned_repr z) in H2 by smart_omega; split; assumption.
  right; right; eapply Rle_trans; [apply Z2R_le; apply Zlt_le_succ; now apply H6|].
  rewrite H2, round_ZR_pos.
  unfold round, scaled_mantissa, canonic_exp, FIX_exp, F2R, Fnum, Fexp; simpl bpow;
    do 2 rewrite Rmult_1_r; now apply Zfloor_lb.
  apply Rnot_lt_le; intro; apply Rlt_le in H7; eapply (round_le radix2 (FIX_exp 0) (round_mode mode_ZR)) in H7;
    rewrite <- H2, round_0 in H7; [apply (le_Z2R _ 0) in H7; now smart_omega|now apply valid_rnd_round_mode].
  right; left; eapply Rle_trans; [|change (-1)%R with (Z2R (-1)); apply (Z2R_le z); omega].
  rewrite H2, round_ZR_neg; unfold round, scaled_mantissa, canonic_exp, FIX_exp, F2R, Fnum, Fexp; simpl bpow.
  do 2 rewrite Rmult_1_r; now apply Zceil_ub.
  apply Rnot_lt_le; intro; apply Rlt_le in H5; apply (round_le radix2 (FIX_exp 0) (round_mode mode_ZR)) in H5;
    rewrite <- H2, round_0 in H5; [apply (le_Z2R 0) in H5; omega|now apply valid_rnd_round_mode].
  left; assumption.
Qed.

Lemma intuoffloat_interval:
  forall f n,
    intuoffloat f = Some n ->
    (-1 < B2R _ _ f < Z2R (Zsucc Int.max_unsigned))%R.
Proof.
  intro; pose proof (intuoffloat_correct f); destruct (intuoffloat f); try discriminate; destruct H.
  destruct f; try discriminate; intros.
  simpl B2R; change 0%R with (Z2R 0); change (-1)%R with (Z2R (-1)); split; apply Z2R_lt; reflexivity.
  pose proof (Int.unsigned_range i).
  unfold round, scaled_mantissa, B2R, F2R, Fnum, Fexp in H0 |- *; simpl bpow in H0; do 2 rewrite Rmult_1_r in H0;
    apply eq_Z2R in H0.
  split; apply Rnot_le_lt; intro.
  rewrite Ztrunc_ceil in H0;
    [apply Zceil_le in H3; change (-1)%R with (Z2R (-1)) in H3; rewrite Zceil_Z2R in H3; omega|].
  eapply Rle_trans; [now apply H3|apply (Z2R_le (-1) 0); discriminate].
  rewrite Ztrunc_floor in H0; [apply Zfloor_le in H3; rewrite Zfloor_Z2R in H3; now smart_omega|].
  eapply Rle_trans; [|now apply H3]; apply (Z2R_le 0); discriminate.
Qed.

Theorem intuoffloat_intoffloat_1:
  forall x n,
  cmp Clt x (floatofintu ox8000_0000) = true ->
  intuoffloat x = Some n ->
  intoffloat x = Some n.
Proof.
  intros; unfold cmp in H; pose proof (order_float_finite_correct x (floatofintu ox8000_0000)).
  destruct (order_float x (floatofintu ox8000_0000)); try destruct c; try discriminate.
  pose proof (intuoffloat_correct x); rewrite H0 in H2; destruct H2.
  specialize (H1 H2 eq_refl); pose proof (intoffloat_correct x); destruct (intoffloat x).
  f_equal; rewrite <- (proj2 H4) in H3; apply eq_Z2R in H3.
  pose proof (eq_refl (Int.repr (Int.unsigned n))); rewrite H3 in H5 at 1.
  rewrite Int.repr_signed, Int.repr_unsigned in H5; assumption.
  destruct H4; [rewrite H2 in H4; discriminate|].
  apply intuoffloat_interval in H0; exfalso; destruct H0, H4.
  eapply Rlt_le_trans in H0; [|now apply H4]; apply (lt_Z2R (-1)) in H0; discriminate.
  apply Rcompare_Lt_inv in H1; eapply Rle_lt_trans in H1; [|now apply H4].
  unfold floatofintu in H1; rewrite (fun x H => proj1 (binary_normalize64_exact x H)) in H1;
    [apply lt_Z2R in H1; discriminate|split; reflexivity].
Qed.

Lemma Zfloor_minus :
  forall x n, Zfloor(x-Z2R n) = Zfloor(x)-n.
Proof.
  intros; apply Zfloor_imp; replace (Zfloor x - n + 1) with (Zfloor x + 1 - n) by ring; do 2 rewrite Z2R_minus.
  split;
    [apply Rplus_le_compat_r; now apply Zfloor_lb|
     apply Rplus_lt_compat_r; rewrite Z2R_plus; now apply Zfloor_ub].
Qed.

Theorem intuoffloat_intoffloat_2:
  forall x n,
  cmp Clt x (floatofintu ox8000_0000) = false ->
  intuoffloat x = Some n ->
  intoffloat (sub x (floatofintu ox8000_0000)) = Some (Int.sub n ox8000_0000).
Proof.
  assert (B2R _ _ (floatofintu ox8000_0000) = Z2R (Int.unsigned ox8000_0000)).
  apply (fun x H => proj1 (binary_normalize64_exact x H)); split; reflexivity.
  intros; unfold cmp in H0; pose proof (order_float_finite_correct x (floatofintu ox8000_0000)).
  destruct (order_float x (floatofintu ox8000_0000)); try destruct c; try discriminate;
  pose proof (intuoffloat_correct x); rewrite H1 in H3; destruct H3; specialize (H2 H3 eq_refl).
  apply Rcompare_Eq_inv in H2; apply B2R_inj in H2.
  subst x; vm_compute in H1; injection H1; intro; subst n; vm_compute; reflexivity.
  destruct x; try discriminate H3;
    [rewrite H in H2; simpl B2R in H2; apply (eq_Z2R 0) in H2; discriminate|reflexivity].
  reflexivity.
  rewrite H in H2; apply Rcompare_Gt_inv in H2; pose proof (intuoffloat_interval _ _ H1).
  unfold sub, b64_minus.
  exploit (Bminus_correct 53 1024 eq_refl eq_refl mode_NE x (floatofintu ox8000_0000)); [assumption|reflexivity|]; intro.
  rewrite H, round_generic in H6.
  match goal with [H6:if Rlt_bool ?x ?y then _ else _|-_] =>
    pose proof (Rlt_bool_spec x y); destruct (Rlt_bool x y) end.
  destruct H6.
  match goal with [|- _ ?y = _] => pose proof (intoffloat_correct y); destruct (intoffloat y) end.
  destruct H9.
  f_equal; rewrite <- (Int.repr_signed i); unfold Int.sub; f_equal; apply eq_Z2R.
  rewrite Z2R_minus, H10, H4.
  unfold round, scaled_mantissa, F2R, Fexp, Fnum, round_mode; simpl bpow; repeat rewrite Rmult_1_r;
    rewrite <- Z2R_minus; f_equal.
  rewrite (Ztrunc_floor (B2R _ _ x)), <- Zfloor_minus, <- Ztrunc_floor;
    [f_equal; assumption|apply Rle_0_minus; left; assumption|].
  left; eapply Rlt_trans; [|now apply H2]; apply (Z2R_lt 0); reflexivity.
  exfalso; simpl Zcompare in H6, H8; rewrite H6, H8 in H9.
  destruct H9 as [|[]]; [discriminate|..].
  eapply Rle_trans in H9; [|apply Rle_0_minus; left; assumption]; apply (le_Z2R 0) in H9; apply H9; reflexivity.
  eapply Rle_lt_trans in H9; [|apply Rplus_lt_compat_r; now apply (proj2 H5)].
  rewrite <- Z2R_opp, <- Z2R_plus in H9; apply lt_Z2R in H9; discriminate.
  exfalso; inversion H7; rewrite Rabs_right in H8.
  eapply Rle_lt_trans in H8. apply Rle_not_lt in H8; [assumption|apply (bpow_le _ 31); discriminate].
  change (bpow radix2 31) with (Z2R(Zsucc Int.max_unsigned - Int.unsigned ox8000_0000)); rewrite Z2R_minus.
  apply Rplus_lt_compat_r; exact (proj2 H5).
  apply Rle_ge; apply Rle_0_minus; left; assumption.
  now apply valid_rnd_round_mode.
  apply Fprop_Sterbenz.sterbenz_aux; [now apply fexp_monotone|now apply generic_format_B2R| |].
  rewrite <- H; now apply generic_format_B2R.
  destruct H5; split; left; assumption.
  now destruct H2.
Qed.

(** Conversions from ints to floats can be defined as bitwise manipulations
  over the in-memory representation.  This is what the PowerPC port does.
  The trick is that [from_words 0x4330_0000 x] is the float
  [2^52 + floatofintu x]. *)

Definition ox4330_0000 := Int.repr 1127219200.        (**r [0x4330_0000] *)

Lemma split_bits_or:
  forall x,
  split_bits 52 11
  (Int64.unsigned
    (Int64.or
      (Int64.shl (Int64.repr (Int.unsigned ox4330_0000)) (Int64.repr 32))
      (Int64.repr (Int.unsigned x)))) = (false, Int.unsigned x, 1075).
Proof.
intro; pose proof (Int.unsigned_range x); unfold split_bits; f_equal; f_equal.
apply Zle_bool_false.
match goal with [|-_ ?x < _] =>
  pose proof (Int64.sign_bit_of_Z x);
  destruct (zlt (Int64.unsigned x) Int64.half_modulus)
end.
assumption.
unfold Int64.or, Int64.bitwise_binop in H0.
rewrite Int64.unsigned_repr, Int64.bits_of_Z_of_bits in H0.
rewrite orb_false_intro in H0; [discriminate|reflexivity|].
rewrite Int64.sign_bit_of_Z.
match goal with [|- ((if ?c then _ else _) = _)] => destruct c end.
reflexivity.
rewrite Int64.unsigned_repr in z0; [exfalso|]; now smart_omega.
vm_compute; split; congruence.
now apply Int64.Z_of_bits_range_2.
change (2^52) with (two_p 52).
rewrite <- Int64.zero_ext_mod, Int64.zero_ext_and by (vm_compute; intuition).
rewrite Int64.and_commut, Int64.and_or_distrib.
match goal with [|- _ (_ ?o _) = _] => change o with Int64.zero end.
rewrite Int64.or_commut, Int64.or_zero, Int64.and_commut.
rewrite <- Int64.zero_ext_and, Int64.zero_ext_mod by (compute; intuition).
rewrite Int64.unsigned_repr; [apply Zmod_small; compute_this (two_p 52)|]; now smart_omega.
match goal with [|- ?x mod _ = _] => rewrite <- (Int64.unsigned_repr x) end.
change (2^52) with (two_p (Int64.unsigned (Int64.repr 52))). rewrite <- Int64.shru_div_two_p.
change (2^11) with (two_p 11). rewrite <- Int64.or_shru.
replace (Int64.shru (Int64.repr (Int.unsigned x)) (Int64.repr 52)) with Int64.zero;
  [vm_compute; reflexivity|].
rewrite Int64.shru_div_two_p, Int64.unsigned_repr by smart_omega.
unfold Int64.zero; f_equal; rewrite Zdiv_small; [reflexivity|].
simpl; compute_this (two_power_pos 52); now smart_omega.
apply Zdiv_interval_2; try smart_omega; now apply Int64.unsigned_range_2.
Qed.

Lemma from_words_value:
  forall x,
    B2R _ _ (from_words ox4330_0000 x) =
    (bpow radix2 52 + Z2R (Int.unsigned x))%R /\
    is_finite _ _ (from_words ox4330_0000 x) = true.
Proof.
  intros; unfold from_words, double_of_bits, b64_of_bits, binary_float_of_bits.
  rewrite B2R_FF2B; unfold is_finite; rewrite match_FF2B;
  unfold binary_float_of_bits_aux; rewrite split_bits_or; simpl; pose proof (Int.unsigned_range x).
  destruct (Int.unsigned x + Zpower_pos 2 52) as []_eqn.
  exfalso; now smart_omega.
  simpl; rewrite <- Heqz;  unfold F2R; simpl.
  rewrite <- (Z2R_plus 4503599627370496), Rmult_1_r.
  split; [f_equal; compute_this (Zpower_pos 2 52); ring | reflexivity].
  assert (Zneg p < 0) by reflexivity.
  exfalso; now smart_omega.
Qed.

Theorem floatofintu_from_words:
  forall x,
  floatofintu x =
    sub (from_words ox4330_0000 x) (from_words ox4330_0000 Int.zero).
Proof.
  intros; destruct (Int.eq_dec x Int.zero); [subst; vm_compute; reflexivity|].
  assert (Int.unsigned x <> 0).
  intro; destruct n; rewrite <- (Int.repr_unsigned x), H; reflexivity.
  pose proof (Int.unsigned_range x).
  pose proof (binary_normalize64_exact (Int.unsigned x)). destruct H1; [smart_omega|].
  unfold floatofintu, sub, b64_minus.
  match goal with [|- _ = Bminus _ _ _ _ _ ?x ?y] =>
    pose proof (Bminus_correct 53 1024 eq_refl eq_refl mode_NE x y) end.
  apply (fun f x y => f x y) in H3; try apply (fun x => proj2 (from_words_value x)).
  do 2 rewrite (fun x => proj1 (from_words_value x)) in H3.
  replace (bpow radix2 52 + Z2R (Int.unsigned x) -
    (bpow radix2 52 + Z2R (Int.unsigned Int.zero)))%R with (Z2R (Int.unsigned x)) in H3 by (simpl; ring).
  rewrite round_exact in H3 by smart_omega.
  match goal with [H3:if Rlt_bool ?x ?y then _ else _ |- _] =>
    pose proof (Rlt_bool_spec x y); destruct (Rlt_bool x y) end; destruct H3.
  simpl Zcompare in *; apply B2R_inj;
    try match goal with [H':B2R _ _ ?f = _ , H'':is_finite _ _ ?f = true |- is_finite_strict _ _ ?f = true] =>
      destruct f; [
        simpl in H'; change 0%R with (Z2R 0) in H'; apply eq_Z2R in H'; now destruct (H (eq_sym H')) |
        discriminate H'' | discriminate H'' | reflexivity
      ]
    end.
  rewrite H3; assumption.
  inversion H4; change (bpow radix2 1024) with (Z2R (radix2 ^ 1024)) in H6; rewrite <- Z2R_abs in H6.
  apply le_Z2R in H6; pose proof (Zabs_spec (Int.unsigned x));
    exfalso; now smart_omega.
Qed.

Lemma ox8000_0000_signed_unsigned:
  forall x,
    Int.unsigned (Int.add x ox8000_0000) = Int.signed x + Int.half_modulus.
Proof.
  intro; unfold Int.signed, Int.add; pose proof (Int.unsigned_range x).
  destruct (zlt (Int.unsigned x) Int.half_modulus).
  rewrite Int.unsigned_repr; compute_this (Int.unsigned ox8000_0000); now smart_omega.
  rewrite (Int.eqm_samerepr _ (Int.unsigned x + -2147483648)).
  rewrite Int.unsigned_repr; now smart_omega.
  apply Int.eqm_add; [now apply Int.eqm_refl|exists 1;reflexivity].
Qed.

Theorem floatofint_from_words:
  forall x,
  floatofint x =
    sub (from_words ox4330_0000 (Int.add x ox8000_0000))
        (from_words ox4330_0000 ox8000_0000).
Proof.
  intros; destruct (Int.eq_dec x Int.zero); [subst; vm_compute; reflexivity|].
  assert (Int.signed x <> 0).
  intro; destruct n; rewrite <- (Int.repr_signed x), H; reflexivity.
  pose proof (Int.signed_range x).
  pose proof (binary_normalize64_exact (Int.signed x)); destruct H1; [now smart_omega|].
  unfold floatofint, sub, b64_minus.
  match goal with [|- _ = Bminus _ _ _ _ _ ?x ?y] =>
    pose proof (Bminus_correct 53 1024 eq_refl eq_refl mode_NE x y) end.
  apply (fun f x y => f x y) in H3; try apply (fun x => proj2 (from_words_value x)).
  do 2 rewrite (fun x => proj1 (from_words_value x)) in H3.
  replace (bpow radix2 52 + Z2R (Int.unsigned (Int.add x ox8000_0000)) -
    (bpow radix2 52 + Z2R (Int.unsigned ox8000_0000)))%R with (Z2R (Int.signed x)) in H3
  by (rewrite ox8000_0000_signed_unsigned; rewrite Z2R_plus; simpl; ring).
  rewrite round_exact in H3 by smart_omega.
  match goal with [H3:if Rlt_bool ?x ?y then _ else _ |- _] =>
    pose proof (Rlt_bool_spec x y); destruct (Rlt_bool x y) end; destruct H3.
  simpl Zcompare in *; apply B2R_inj;
    try match goal with [H':B2R _ _ ?f = _ , H'':is_finite _ _ ?f = true |- is_finite_strict _ _ ?f = true] =>
      destruct f; [
        simpl in H'; change 0%R with (Z2R 0) in H'; apply eq_Z2R in H'; now destruct (H (eq_sym H')) |
        discriminate H'' | discriminate H'' | reflexivity
      ]
    end.
  rewrite H3; assumption.
  inversion H4; unfold bpow in H6; rewrite <- Z2R_abs in H6;
    apply le_Z2R in H6; pose proof (Zabs_spec (Int.signed x)); exfalso; now smart_omega.
Qed.

Global Opaque
  zero eq_dec neg abs singleoffloat intoffloat intuoffloat floatofint floatofintu
  add sub mul div cmp bits_of_double double_of_bits bits_of_single single_of_bits from_words.

End Float.


(* This program 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 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import Le.
Require Import Gt.
Require Export List.

Unset Standard Proposition Elimination Names.
Global Set Asymmetric Patterns.

Section Listes.

  Variable A : Set.

  Let List := list A.

  Inductive In (x : A) : List -> Prop :=
    | In_hd : forall l : List, In x (x :: l)
    | In_tl : forall (y : A) (l : List), In x l -> In x (y :: l).

  Hint Resolve In_hd In_tl: coc.

  Lemma In_app :
   forall (x : A) (l1 l2 : List), In x (l1 ++ l2) -> In x l1 \/ In x l2.
simple induction l1; simpl in |- *; intros;
 auto with coc core arith datatypes.

inversion_clear H0; auto with coc core arith datatypes.
elim H with l2; auto with coc core arith datatypes.
Qed.

  Definition incl (l1 l2 : List) : Prop := forall x : A, In x l1 -> In x l2.

  Hint Unfold incl: coc.

  Lemma incl_app_sym : forall l1 l2 : List, incl (l1 ++ l2) (l2 ++ l1).
red in |- *; intros.
elim In_app with x l1 l2; intros; auto with coc core arith datatypes.
elim l2; simpl in |- *; auto with coc core arith datatypes.

elim H0; simpl in |- *; auto with coc core arith datatypes.
Qed.

  Inductive item (x : A) : List -> nat -> Prop :=
    | item_hd : forall l : List, item x (x :: l) 0
    | item_tl :
        forall (l : List) (n : nat) (y : A),
        item x l n -> item x (y :: l) (S n).

  Lemma fun_item :
   forall (u v : A) (e : List) (n : nat), item u e n -> item v e n -> u = v.
simple induction 1; intros.
inversion_clear H0; auto with coc core arith datatypes.

inversion_clear H2; auto with coc core arith datatypes.
Qed.

  Fixpoint nth_def (d : A) (l : List) {struct l} :
   nat -> A :=
    fun n : nat =>
    match l, n with
    | nil, _ => d
    | x :: _, O => x
    | _ :: tl, S k => nth_def d tl k
    end.

  Lemma nth_sound :
   forall (x : A) (l : List) (n : nat),
   item x l n -> forall d : A, nth_def d l n = x.
simple induction 1; simpl in |- *; auto with coc core arith datatypes.
Qed.

  Lemma inv_nth_nl : forall (x : A) (n : nat), ~ item x nil n.
unfold not in |- *; intros.
inversion_clear H.
Qed.

  Lemma inv_nth_cs :
   forall (x y : A) (l : List) (n : nat), item x (y :: l) (S n) -> item x l n.
intros.
inversion_clear H; auto with coc core arith datatypes.
Qed.

  Inductive insert (x : A) : nat -> List -> List -> Prop :=
    | insert_hd : forall l : List, insert x 0 l (x :: l)
    | insert_tl :
        forall (n : nat) (l il : List) (y : A),
        insert x n l il -> insert x (S n) (y :: l) (y :: il).

  Inductive trunc : nat -> List -> List -> Prop :=
    | trunc_O : forall e : List, trunc 0 e e
    | trunc_S :
        forall (k : nat) (e f : List) (x : A),
        trunc k e f -> trunc (S k) (x :: e) f.

  Hint Resolve trunc_O trunc_S: coc.

  Lemma item_trunc :
   forall (n : nat) (e : List) (t : A),
   item t e n -> exists f : List, trunc (S n) e f.
simple induction n; intros.
inversion_clear H.
exists l; auto with coc core arith datatypes.

inversion_clear H0.
elim H with l t; intros; auto with coc core arith datatypes.
exists x; auto with coc core arith datatypes.
Qed.

  Lemma ins_le :
   forall (k : nat) (f g : List) (d x : A),
   insert x k f g ->
   forall n : nat, k <= n -> nth_def d f n = nth_def d g (S n).
simple induction 1; auto with coc core arith datatypes.
simple destruct n0; intros.
inversion_clear H2.

simpl in |- *.
auto with coc core arith datatypes.
Qed.

  Lemma ins_gt :
   forall (k : nat) (f g : List) (d x : A),
   insert x k f g -> forall n : nat, k > n -> nth_def d f n = nth_def d g n.
simple induction 1; auto with coc core arith datatypes.
intros.
inversion_clear H0.

simple destruct n0; intros.
auto with coc core arith datatypes.

simpl in |- *; auto with coc core arith datatypes.
Qed.

  Lemma ins_eq :
   forall (k : nat) (f g : List) (d x : A),
   insert x k f g -> nth_def d g k = x.
simple induction 1; simpl in |- *; auto with coc core arith datatypes.
Qed.

Definition list_item :
 forall (e : List) (n : nat),
 {t : A | item t e n} + {(forall t : A, ~ item t e n)}.

simple induction e.
right.
red in |- *; intros t H; inversion_clear H.
intros h f itemf n.
case n.
left; exists h; constructor.
intro k; case (itemf k).
simple destruct 1; intro u; left; exists u; constructor; trivial.
intros; right.
red in |- *; intros.
inversion_clear H.
apply (n0 t); auto.
Defined.

  Definition list_disjoint (l1 l2 : List) : Prop :=
    forall x : A, In x l1 -> In x l2 -> False.

  Inductive first_item (x : A) : List -> nat -> Prop :=
    | fit_hd : forall l : List, first_item x (x :: l) 0
    | fit_tl :
        forall (l : List) (y : A) (n : nat),
        first_item x l n -> x <> y -> first_item x (y :: l) (S n).

  Hint Resolve fit_hd fit_tl: coc.

  Lemma first_item_is_item :
   forall (x : A) (l : List) (n : nat), first_item x l n -> item x l n.
simple induction 1; intros.
apply item_hd.

apply item_tl; trivial with coc core arith datatypes.
Qed.

  Lemma first_item_unique :
   forall (x : A) (l : List) (n : nat),
   first_item x l n -> forall m : nat, first_item x l m -> m = n.
simple induction 1; intros; auto with coc core arith datatypes.
inversion_clear H0; auto with coc core arith datatypes.

elim H2; auto with coc core arith datatypes.

generalize H2.
inversion_clear H3; intros.
elim H3; auto with coc core arith datatypes.

elim H1 with n1; auto with coc core arith datatypes.
Qed.

  Hypothesis eq_dec : forall x y : A, {x = y} + {x <> y}.

  Definition list_index :
   forall (x : A) (l : List), {n : nat | first_item x l n} + {~ In x l}.

refine
 (fix list_index (x : A) (l : List) {struct l} :
    {n : nat | first_item x l n} + {~ In x l} :=
    match l return ({n : nat | first_item x l n} + {~ In x l}) with
    | nil => inright _ _
    | y :: l1 =>
        match eq_dec x y with
        | left found => inleft _ (exist _ 0 _)
        | right notfound =>
            match list_index x l1 with
            | inleft (exist k in_tail) => inleft _ (exist _ (S k) _)
            | inright not_tail => inright _ _
            end
        end
    end); auto with coc.

red in |- *; intros.
inversion H.

elim found; auto with coc.

red in |- *; intros; apply not_tail.
inversion H; auto with coc.
elim notfound; trivial.
Defined.

End Listes.

  Hint Resolve item_hd item_tl insert_hd insert_tl trunc_O trunc_S: coc.
  Hint Resolve In_hd In_tl fit_hd fit_tl trunc_O trunc_S: coc.
  Hint Unfold incl: coc.


From st.STLCmuVS Require Import lang typing contexts scopedness.
From st.STLCmu Require Import types.
From st.backtranslations.un_syn Require Import universe.base expressions typed.

(* Reserved Notation "<[ Ci ]>" (at level 4, Ci at next level). *)
Definition universe_back_ctx_item (Ci : ctx_item) : ctx :=
  match Ci with
  | CTX_Lam => [CTX_AppR (inject TCArrow); CTX_Lam]
  | CTX_AppL e2 => [CTX_AppL <<e2>>; CTX_AppR (extract TCArrow)]
  | CTX_AppR e1 => [CTX_AppR (extract TCArrow <<e1>>)]
  | CTX_LetInL e2 => [CTX_LetInL <<e2>>]
  | CTX_LetInR e1 => [CTX_LetInR <<e1>>]
  | CTX_PairL e2 =>  [CTX_AppR (inject TCProd); CTX_PairL <<e2>>]
  | CTX_PairR e1 => [CTX_AppR (inject TCProd); CTX_PairR <<e1>>]
  | CTX_Fst => [CTX_Fst; CTX_AppR (extract TCProd)]
  | CTX_Snd => [CTX_Snd; CTX_AppR (extract TCProd)]
  | CTX_InjL => [CTX_AppR (inject TCSum); CTX_InjL]
  | CTX_InjR => [CTX_AppR (inject TCSum); CTX_InjR]
  | CTX_CaseL e1 e2 => [CTX_CaseL <<e1>> <<e2>>; CTX_AppR (extract TCSum)]
  | CTX_CaseM e0 e2 => [CTX_CaseM (extract TCSum <<e0>>) <<e2>>]
  | CTX_CaseR e0 e1 => [CTX_CaseR (extract TCSum <<e0>>) <<e1>>]
  | CTX_BinOpL op e2 => [CTX_AppR (inject match op with
                                         | PlusOp => TCInt
                                         | MinusOp => TCInt
                                         | LeOp => TCBool
                                         | LtOp => TCBool
                                         | EqOp => TCBool
                                         end) ; CTX_BinOpL op (extract TCInt <<e2>>); CTX_AppR (extract TCInt)]
  | CTX_BinOpR op e1 => [CTX_AppR (inject match op with
                                         | PlusOp => TCInt
                                         | MinusOp => TCInt
                                         | LeOp => TCBool
                                         | LtOp => TCBool
                                         | EqOp => TCBool
                                         end) ; CTX_BinOpR op (extract TCInt <<e1>>); CTX_AppR (extract TCInt)]
  | CTX_IfL e1 e2 => [CTX_IfL <<e1>> <<e2>>; CTX_AppR (extract TCBool)]
  | CTX_IfM e0 e2 => [CTX_IfM (extract TCBool <<e0>>) <<e2>>]
  | CTX_IfR e0 e1 => [CTX_IfR (extract TCBool <<e0>>) <<e1>>]
  | CTX_Fold => [CTX_AppR (inject TCRec); CTX_Fold]
  | CTX_Unfold => [CTX_Unfold ; CTX_AppR (extract TCRec)]
  | CTX_VirtStep => []
  end.

Lemma universe_back_ctx_item_typed (Ci : ctx_item) n m :
    |sCi> n ⊢ₙₒ Ci ☾ m ☽ →
    |C> replicate n TUniverse ⊢ₙₒ (universe_back_ctx_item Ci) ☾ replicate m TUniverse ; TUniverse ☽ : TUniverse.
Proof.
  Ltac blaa := lazymatch goal with
           | |- typed _ (universe_back_expr ?e) TUniverse => apply back_typed
           | |- typed _ (of_val (inject ?tc)) _ => apply (inject_typed tc)
           | |- typed _ (of_val (extract ?tc)) _ => apply (extract_typed tc)
           | |- _ => econstructor
           end.
  intro H. destruct H; repeat blaa; try rewrite -replicate_S; try blaa; try done.
  destruct op; repeat blaa; try blaa; try done.
  destruct op; repeat blaa; try blaa; try done.
Qed.

Fixpoint universe_back_ctx (C : ctx) : ctx :=
  match C with
  | nil => []
  | cons Ci Ctl => universe_back_ctx_item Ci ++ (universe_back_ctx Ctl)
  end.

Lemma universe_back_ctx_typed (C : ctx) n m :
    |sC> n ⊢ₙₒ C ☾ m ☽ →
    |C> replicate n TUniverse ⊢ₙₒ (universe_back_ctx C) ☾ replicate m TUniverse ; TUniverse ☽ : TUniverse.
Proof.
  intro H. induction H.
  - constructor.
  - simpl. eapply typed_ctx_app; [by apply universe_back_ctx_item_typed | auto].
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

(*i $Id: DoubleLift.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Set Implicit Arguments.

Require Import ZArith.
Require Import BigNumPrelude.
Require Import DoubleType.
Require Import DoubleBase.

Local Open Scope Z_scope.

Section DoubleLift.
 Variable w : Type.
 Variable w_0 : w.
 Variable w_WW : w -> w -> zn2z w.
 Variable w_W0 : w ->  zn2z w.
 Variable w_0W : w ->  zn2z w.
 Variable w_compare : w -> w -> comparison.
 Variable ww_compare : zn2z w -> zn2z w -> comparison.
 Variable w_head0 : w -> w.
 Variable w_tail0 : w -> w.
 Variable w_add: w -> w -> zn2z w.
 Variable w_add_mul_div : w -> w -> w -> w.
 Variable ww_sub: zn2z w -> zn2z w -> zn2z w.
 Variable w_digits : positive.
 Variable ww_Digits : positive.
 Variable w_zdigits : w.
 Variable ww_zdigits : zn2z w.
 Variable low: zn2z w -> w.

 Definition ww_head0 x :=
  match x with
  | W0 => ww_zdigits
  | WW xh xl =>
    match w_compare w_0 xh with
    | Eq => w_add w_zdigits (w_head0 xl)
    | _ => w_0W (w_head0 xh)
    end
  end.

 Definition ww_tail0 x :=
  match x with
  | W0 => ww_zdigits
  | WW xh xl =>
    match w_compare w_0 xl with
    | Eq => w_add w_zdigits (w_tail0 xh)
    | _ => w_0W (w_tail0 xl)
    end
  end.

  (* 0 < p < ww_digits *)
 Definition ww_add_mul_div p x y :=
  let zdigits := w_0W w_zdigits in
  match x, y with
  | W0, W0 => W0
  | W0, WW yh yl =>
    match ww_compare p zdigits with
    | Eq => w_0W yh
    | Lt => w_0W (w_add_mul_div (low p) w_0 yh)
    | Gt =>
      let n := low (ww_sub p zdigits) in
      w_WW (w_add_mul_div n w_0 yh) (w_add_mul_div n yh yl)
    end
  | WW xh xl, W0 =>
    match ww_compare p zdigits with
    | Eq => w_W0 xl
    | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl w_0)
    | Gt =>
      let n := low (ww_sub p zdigits) in
      w_W0 (w_add_mul_div n xl w_0)
    end
  | WW xh xl, WW yh yl =>
    match ww_compare p zdigits with
    | Eq => w_WW xl yh
    | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl yh)
    | Gt =>
      let n := low (ww_sub p zdigits) in
      w_WW (w_add_mul_div n xl yh) (w_add_mul_div n yh yl)
    end
  end.

 Section DoubleProof.
  Variable w_to_Z : w -> Z.

  Notation wB  := (base w_digits).
  Notation wwB := (base (ww_digits w_digits)).
  Notation "[| x |]" := (w_to_Z x)  (at level 0, x at level 99).
  Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99).

  Variable spec_w_0   : [|w_0|] = 0.
  Variable spec_to_Z  : forall x, 0 <= [|x|] < wB.
  Variable spec_to_w_Z  : forall x, 0 <= [[x]] < wwB.
  Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|].
  Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB.
  Variable spec_w_0W : forall l, [[w_0W l]] = [|l|].
  Variable spec_compare : forall x y,
       match w_compare x y with
       | Eq => [|x|] = [|y|]
       | Lt => [|x|] < [|y|]
       | Gt => [|x|] > [|y|]
       end.
  Variable spec_ww_compare : forall x y,
       match ww_compare x y with
       | Eq => [[x]] = [[y]]
       | Lt => [[x]] < [[y]]
       | Gt => [[x]] > [[y]]
       end.
  Variable spec_ww_digits : ww_Digits = xO w_digits.
  Variable spec_w_head00  : forall x, [|x|] = 0 -> [|w_head0 x|] = Zpos w_digits.
  Variable spec_w_head0  : forall x,  0 < [|x|] ->
	 wB/ 2 <= 2 ^ ([|w_head0 x|]) * [|x|] < wB.
  Variable spec_w_tail00  : forall x, [|x|] = 0 -> [|w_tail0 x|] = Zpos w_digits.
  Variable spec_w_tail0 : forall x, 0 < [|x|] ->
         exists y, 0 <= y /\ [|x|] = (2* y + 1) * (2 ^ [|w_tail0 x|]).
  Variable spec_w_add_mul_div : forall x y p,
       [|p|] <= Zpos w_digits ->
       [| w_add_mul_div p x y |] =
         ([|x|] * (2 ^ [|p|]) +
          [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB.
 Variable spec_w_add: forall x y,
   [[w_add x y]] = [|x|] + [|y|].
 Variable spec_ww_sub: forall x y,
   [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB.

 Variable spec_zdigits : [| w_zdigits |] = Zpos w_digits.
 Variable spec_low: forall x, [| low x|] = [[x]] mod wB.

 Variable spec_ww_zdigits : [[ww_zdigits]] = Zpos ww_Digits.

  Hint Resolve div_le_0 div_lt w_to_Z_wwB: lift.
  Ltac zarith := auto with zarith lift.

  Lemma spec_ww_head00  : forall x, [[x]] = 0 -> [[ww_head0 x]] = Zpos ww_Digits.
  Proof.
  intros x; case x; unfold ww_head0.
    intros HH; rewrite spec_ww_zdigits; auto.
  intros xh xl; simpl; intros Hx.
  case (spec_to_Z xh); intros Hx1 Hx2.
  case (spec_to_Z xl); intros Hy1 Hy2.
  assert (F1: [|xh|] = 0).
    case (Zle_lt_or_eq _ _ Hy1); auto; intros Hy3.
    absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith.
    apply Zlt_le_trans with (1 := Hy3); auto with zarith.
    pattern [|xl|] at 1; rewrite <- (Zplus_0_l [|xl|]).
    apply Zplus_le_compat_r; auto with zarith.
    case (Zle_lt_or_eq _ _ Hx1); auto; intros Hx3.
    absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith.
    rewrite <- Hy3; rewrite Zplus_0_r; auto with zarith.
    apply Zmult_lt_0_compat; auto with zarith.
  generalize (spec_compare w_0 xh); case w_compare.
    intros H; simpl.
    rewrite spec_w_add; rewrite spec_w_head00.
    rewrite spec_zdigits; rewrite spec_ww_digits.
    rewrite Zpos_xO; auto with zarith.
  rewrite F1 in Hx; auto with zarith.
  rewrite spec_w_0; auto with zarith.
  rewrite spec_w_0; auto with zarith.
  Qed.

  Lemma spec_ww_head0  : forall x,  0 < [[x]] ->
	 wwB/ 2 <= 2 ^ [[ww_head0 x]] * [[x]] < wwB.
  Proof.
   clear spec_ww_zdigits.
   rewrite wwB_div_2;rewrite Zmult_comm;rewrite wwB_wBwB.
   assert (U:= lt_0_wB w_digits); destruct x as [ |xh xl];simpl ww_to_Z;intros H.
   unfold Zlt in H;discriminate H.
   assert (H0 := spec_compare w_0 xh);rewrite spec_w_0 in H0.
   destruct (w_compare w_0 xh).
   rewrite <- H0. simpl Zplus. rewrite <- H0 in H;simpl in H.
   case (spec_to_Z w_zdigits);
     case (spec_to_Z (w_head0 xl)); intros HH1 HH2 HH3 HH4.
   rewrite spec_w_add.
   rewrite spec_zdigits; rewrite Zpower_exp; auto with zarith.
   case (spec_w_head0 H); intros H1 H2.
   rewrite Zpower_2; fold wB; rewrite <- Zmult_assoc; split.
     apply Zmult_le_compat_l; auto with zarith.
   apply Zmult_lt_compat_l; auto with zarith.
   assert (H1 := spec_w_head0 H0).
   rewrite spec_w_0W.
   split.
   rewrite Zmult_plus_distr_r;rewrite Zmult_assoc.
   apply Zle_trans with (2 ^ [|w_head0 xh|] * [|xh|] * wB).
   rewrite Zmult_comm; zarith.
   assert (0 <= 2 ^ [|w_head0 xh|] * [|xl|]);zarith.
   assert (H2:=spec_to_Z xl);apply Zmult_le_0_compat;zarith.
   case (spec_to_Z (w_head0 xh)); intros H2 _.
   generalize ([|w_head0 xh|]) H1 H2;clear H1 H2;
     intros p H1 H2.
   assert (Eq1 : 2^p < wB).
     rewrite <- (Zmult_1_r (2^p));apply Zle_lt_trans with (2^p*[|xh|]);zarith.
   assert (Eq2: p < Zpos w_digits).
    destruct (Zle_or_lt (Zpos w_digits) p);trivial;contradict  Eq1.
   apply Zle_not_lt;unfold base;apply Zpower_le_monotone;zarith.
   assert (Zpos w_digits = p + (Zpos w_digits - p)). ring.
   rewrite Zpower_2.
   unfold base at 2;rewrite H3;rewrite Zpower_exp;zarith.
   rewrite <- Zmult_assoc; apply Zmult_lt_compat_l; zarith.
   rewrite <- (Zplus_0_r (2^(Zpos w_digits - p)*wB));apply beta_lex_inv;zarith.
   apply Zmult_lt_reg_r with (2 ^ p); zarith.
   rewrite <- Zpower_exp;zarith.
   rewrite Zmult_comm;ring_simplify (Zpos w_digits - p + p);fold wB;zarith.
   assert (H1 := spec_to_Z xh);zarith.
  Qed.

  Lemma spec_ww_tail00  : forall x, [[x]] = 0 -> [[ww_tail0 x]] = Zpos ww_Digits.
  Proof.
  intros x; case x; unfold ww_tail0.
    intros HH; rewrite spec_ww_zdigits; auto.
  intros xh xl; simpl; intros Hx.
  case (spec_to_Z xh); intros Hx1 Hx2.
  case (spec_to_Z xl); intros Hy1 Hy2.
  assert (F1: [|xh|] = 0).
    case (Zle_lt_or_eq _ _ Hy1); auto; intros Hy3.
    absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith.
    apply Zlt_le_trans with (1 := Hy3); auto with zarith.
    pattern [|xl|] at 1; rewrite <- (Zplus_0_l [|xl|]).
    apply Zplus_le_compat_r; auto with zarith.
    case (Zle_lt_or_eq _ _ Hx1); auto; intros Hx3.
    absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith.
    rewrite <- Hy3; rewrite Zplus_0_r; auto with zarith.
    apply Zmult_lt_0_compat; auto with zarith.
  assert (F2: [|xl|] = 0).
    rewrite F1 in Hx; auto with zarith.
  generalize (spec_compare w_0 xl); case w_compare.
    intros H; simpl.
    rewrite spec_w_add; rewrite spec_w_tail00; auto.
    rewrite spec_zdigits; rewrite spec_ww_digits.
    rewrite Zpos_xO; auto with zarith.
  rewrite spec_w_0; auto with zarith.
  rewrite spec_w_0; auto with zarith.
  Qed.

  Lemma spec_ww_tail0  : forall x,  0 < [[x]] ->
	 exists y, 0 <= y /\ [[x]] = (2 * y + 1) * 2 ^ [[ww_tail0 x]].
  Proof.
   clear spec_ww_zdigits.
   destruct x as [ |xh xl];simpl ww_to_Z;intros H.
   unfold Zlt in H;discriminate H.
   assert (H0 := spec_compare w_0 xl);rewrite spec_w_0 in H0.
   destruct (w_compare w_0 xl).
   rewrite <- H0; rewrite Zplus_0_r.
   case (spec_to_Z (w_tail0 xh)); intros HH1 HH2.
   generalize H; rewrite <- H0; rewrite Zplus_0_r; clear H; intros H.
   case (@spec_w_tail0 xh).
     apply Zmult_lt_reg_r with wB; auto with zarith.
     unfold base; auto with zarith.
   intros z (Hz1, Hz2); exists z; split; auto.
   rewrite spec_w_add; rewrite (fun x => Zplus_comm [|x|]).
   rewrite spec_zdigits; rewrite Zpower_exp; auto with zarith.
   rewrite Zmult_assoc; rewrite <- Hz2; auto.

   case (spec_to_Z (w_tail0 xh)); intros HH1 HH2.
   case (spec_w_tail0 H0); intros z (Hz1, Hz2).
   assert (Hp: [|w_tail0 xl|] < Zpos w_digits).
     case (Zle_or_lt (Zpos w_digits) [|w_tail0 xl|]); auto; intros H1.
     absurd (2 ^  (Zpos w_digits) <= 2 ^ [|w_tail0 xl|]).
       apply Zlt_not_le.
       case (spec_to_Z xl); intros HH3 HH4.
       apply Zle_lt_trans with (2 := HH4).
       apply Zle_trans with (1 * 2 ^ [|w_tail0 xl|]); auto with zarith.
       rewrite Hz2.
       apply Zmult_le_compat_r; auto with zarith.
     apply Zpower_le_monotone; auto with zarith.
   exists ([|xh|] * (2 ^ ((Zpos w_digits - [|w_tail0 xl|]) - 1)) + z); split.
     apply Zplus_le_0_compat; auto.
     apply Zmult_le_0_compat; auto with zarith.
     case (spec_to_Z xh); auto.
   rewrite spec_w_0W.
   rewrite (Zmult_plus_distr_r 2); rewrite <- Zplus_assoc.
   rewrite Zmult_plus_distr_l; rewrite <- Hz2.
   apply f_equal2 with (f := Zplus); auto.
   rewrite (Zmult_comm 2).
   repeat rewrite <- Zmult_assoc.
   apply f_equal2 with (f := Zmult); auto.
   case (spec_to_Z (w_tail0 xl)); intros HH3 HH4.
   pattern 2 at 2; rewrite <- Zpower_1_r.
   lazy beta; repeat rewrite <- Zpower_exp; auto with zarith.
   unfold base; apply f_equal with (f := Zpower 2); auto with zarith.

   contradict H0; case (spec_to_Z xl); auto with zarith.
  Qed.

  Hint Rewrite Zdiv_0_l Zmult_0_l Zplus_0_l Zmult_0_r Zplus_0_r
    spec_w_W0 spec_w_0W spec_w_WW spec_w_0
    (wB_div w_digits w_to_Z spec_to_Z)
    (wB_div_plus w_digits w_to_Z spec_to_Z) : w_rewrite.
  Ltac w_rewrite := autorewrite with w_rewrite;trivial.

  Lemma spec_ww_add_mul_div_aux : forall xh xl yh yl p,
   let zdigits := w_0W w_zdigits in
    [[p]] <= Zpos (xO w_digits) ->
      [[match ww_compare p zdigits with
        | Eq => w_WW xl yh
        | Lt => w_WW (w_add_mul_div (low p) xh xl)
                     (w_add_mul_div (low p) xl yh)
        | Gt =>
              let n := low (ww_sub p zdigits) in
            w_WW (w_add_mul_div n xl yh) (w_add_mul_div n yh yl)
        end]] =
      ([[WW xh xl]] * (2^[[p]]) +
       [[WW yh yl]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB.
  Proof.
   clear spec_ww_zdigits.
   intros xh xl yh yl p zdigits;assert (HwwB := wwB_pos w_digits).
   case (spec_to_w_Z p); intros Hv1 Hv2.
   replace (Zpos (xO w_digits)) with (Zpos w_digits + Zpos w_digits).
   2 : rewrite Zpos_xO;ring.
   replace (Zpos w_digits + Zpos w_digits - [[p]]) with
     (Zpos w_digits + (Zpos w_digits - [[p]])). 2:ring.
   intros Hp; assert (Hxh := spec_to_Z xh);assert (Hxl:=spec_to_Z xl);
   assert (Hx := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl));
   simpl in Hx;assert (Hyh := spec_to_Z yh);assert (Hyl:=spec_to_Z yl);
   assert (Hy:=spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW yh yl));simpl in Hy.
   generalize (spec_ww_compare p zdigits); case ww_compare; intros H1.
   rewrite H1; unfold zdigits; rewrite spec_w_0W.
   rewrite spec_zdigits; rewrite Zminus_diag; rewrite Zplus_0_r.
   simpl ww_to_Z; w_rewrite;zarith.
   fold wB.
   rewrite Zmult_plus_distr_l;rewrite <- Zmult_assoc;rewrite <- Zplus_assoc.
   rewrite <- Zpower_2.
   rewrite <- wwB_wBwB;apply Zmod_unique with [|xh|].
   exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xl yh)). ring.
   simpl ww_to_Z; w_rewrite;zarith.
   assert (HH0: [|low p|] = [[p]]).
     rewrite spec_low.
     apply Zmod_small.
     case (spec_to_w_Z p); intros HH1 HH2; split; auto.
     generalize H1; unfold zdigits; rewrite spec_w_0W;
      rewrite spec_zdigits; intros tmp.
     apply Zlt_le_trans with (1 := tmp).
     unfold base.
     apply Zpower2_le_lin; auto with zarith.
   2: generalize H1; unfold zdigits; rewrite spec_w_0W;
      rewrite spec_zdigits; auto with zarith.
   generalize H1; unfold zdigits; rewrite spec_w_0W;
      rewrite spec_zdigits; auto; clear H1; intros H1.
   assert (HH: [|low p|] <= Zpos w_digits).
     rewrite HH0; auto with zarith.
   repeat rewrite spec_w_add_mul_div with (1 := HH).
   rewrite HH0.
   rewrite Zmult_plus_distr_l.
   pattern ([|xl|] * 2 ^ [[p]]) at 2;
   rewrite shift_unshift_mod with (n:= Zpos w_digits);fold wB;zarith.
   replace ([|xh|] * wB * 2^[[p]]) with ([|xh|] * 2^[[p]] * wB). 2:ring.
   rewrite Zplus_assoc;rewrite <- Zmult_plus_distr_l. rewrite <- Zplus_assoc.
   unfold base at 5;rewrite <- Zmod_shift_r;zarith.
   unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits));
   fold wB;fold wwB;zarith.
   rewrite wwB_wBwB;rewrite Zpower_2; rewrite  Zmult_mod_distr_r;zarith.
   unfold ww_digits;rewrite Zpos_xO;zarith. apply Z_mod_lt;zarith.
   split;zarith. apply Zdiv_lt_upper_bound;zarith.
   rewrite <- Zpower_exp;zarith.
   ring_simplify ([[p]] + (Zpos w_digits - [[p]]));fold wB;zarith.
   assert (Hv: [[p]] > Zpos w_digits).
     generalize H1; clear H1.
     unfold zdigits; rewrite spec_w_0W; rewrite spec_zdigits; auto.
   clear H1.
   assert (HH0: [|low (ww_sub p zdigits)|] = [[p]] - Zpos w_digits).
     rewrite spec_low.
     rewrite spec_ww_sub.
     unfold zdigits; rewrite spec_w_0W; rewrite spec_zdigits.
     rewrite <- Zmod_div_mod; auto with zarith.
     rewrite Zmod_small; auto with zarith.
     split; auto with zarith.
     apply Zle_lt_trans with (Zpos w_digits); auto with zarith.
     unfold base; apply Zpower2_lt_lin; auto with zarith.
     exists wB; unfold base.
     unfold ww_digits; rewrite (Zpos_xO w_digits).
     rewrite <- Zpower_exp; auto with zarith.
     apply f_equal with (f := fun x => 2 ^ x); auto with zarith.
   assert (HH: [|low (ww_sub p zdigits)|] <= Zpos w_digits).
     rewrite HH0; auto with zarith.
   replace (Zpos w_digits + (Zpos w_digits - [[p]])) with
       (Zpos w_digits - ([[p]] - Zpos w_digits)); zarith.
   lazy zeta; simpl ww_to_Z; w_rewrite;zarith.
   repeat rewrite spec_w_add_mul_div;zarith.
   rewrite HH0.
   pattern wB at 5;replace wB with
    (2^(([[p]] - Zpos w_digits)
         + (Zpos w_digits - ([[p]] - Zpos w_digits)))).
   rewrite Zpower_exp;zarith. rewrite Zmult_assoc.
   rewrite Z_div_plus_l;zarith.
   rewrite shift_unshift_mod with (a:= [|yh|]) (p:= [[p]] - Zpos w_digits)
    (n := Zpos w_digits);zarith. fold wB.
   set (u := [[p]] - Zpos w_digits).
   replace [[p]] with (u + Zpos w_digits);zarith.
   rewrite Zpower_exp;zarith. rewrite Zmult_assoc. fold wB.
   repeat rewrite Zplus_assoc. rewrite <- Zmult_plus_distr_l.
   repeat rewrite <- Zplus_assoc.
   unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits));
   fold wB;fold wwB;zarith.
   unfold base;rewrite Zmod_shift_r with (a:= Zpos w_digits)
   (b:= Zpos w_digits);fold wB;fold wwB;zarith.
   rewrite wwB_wBwB; rewrite Zpower_2; rewrite  Zmult_mod_distr_r;zarith.
   rewrite Zmult_plus_distr_l.
   replace ([|xh|] * wB * 2 ^ u) with
     ([|xh|]*2^u*wB). 2:ring.
   repeat rewrite <- Zplus_assoc.
   rewrite (Zplus_comm ([|xh|] * 2 ^ u * wB)).
   rewrite Z_mod_plus;zarith. rewrite Z_mod_mult;zarith.
   unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith.
   unfold u; split;zarith.
   split;zarith. unfold u; apply Zdiv_lt_upper_bound;zarith.
   rewrite <- Zpower_exp;zarith.
   fold u.
   ring_simplify (u + (Zpos w_digits - u)); fold
   wB;zarith. unfold ww_digits;rewrite Zpos_xO;zarith.
   unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith.
   unfold u; split;zarith.
   unfold u; split;zarith.
   apply Zdiv_lt_upper_bound;zarith.
   rewrite <- Zpower_exp;zarith.
   fold u.
   ring_simplify (u + (Zpos w_digits - u)); fold wB; auto with zarith.
   unfold u;zarith.
   unfold u;zarith.
   set (u := [[p]] - Zpos w_digits).
   ring_simplify (u + (Zpos w_digits - u)); fold wB; auto with zarith.
  Qed.

  Lemma spec_ww_add_mul_div : forall x y p,
       [[p]] <= Zpos (xO w_digits) ->
       [[ ww_add_mul_div p x y ]] =
         ([[x]] * (2^[[p]]) +
          [[y]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB.
  Proof.
   clear spec_ww_zdigits.
   intros x y p H.
   destruct x as [ |xh xl];
   [assert (H1 := @spec_ww_add_mul_div_aux w_0 w_0)
   |assert (H1 := @spec_ww_add_mul_div_aux xh xl)];
   (destruct y as [ |yh yl];
    [generalize (H1 w_0 w_0 p H) | generalize (H1 yh yl p H)];
    clear H1;w_rewrite);simpl ww_add_mul_div.
   replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial].
   intros Heq;rewrite <- Heq;clear Heq; auto.
   generalize (spec_ww_compare p (w_0W w_zdigits));
     case ww_compare; intros H1; w_rewrite.
   rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith.
   generalize H1; w_rewrite; rewrite spec_zdigits; clear H1; intros H1.
   assert (HH0: [|low p|] = [[p]]).
     rewrite spec_low.
     apply Zmod_small.
     case (spec_to_w_Z p); intros HH1 HH2; split; auto.
     apply Zlt_le_trans with (1 := H1).
     unfold base; apply Zpower2_le_lin; auto with zarith.
   rewrite HH0; auto with zarith.
   replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial].
   intros Heq;rewrite <- Heq;clear Heq.
   generalize (spec_ww_compare p (w_0W w_zdigits));
     case ww_compare; intros H1; w_rewrite.
   rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith.
   rewrite Zpos_xO in H;zarith.
   assert (HH: [|low (ww_sub p (w_0W w_zdigits)) |] = [[p]] - Zpos w_digits).
     generalize H1; clear H1.
     rewrite spec_low.
     rewrite spec_ww_sub; w_rewrite; intros H1.
     rewrite <- Zmod_div_mod; auto with zarith.
     rewrite Zmod_small; auto with zarith.
     split; auto with zarith.
     apply Zle_lt_trans with (Zpos w_digits); auto with zarith.
     unfold base; apply Zpower2_lt_lin; auto with zarith.
     unfold base; auto with zarith.
     unfold base; auto with zarith.
     exists wB; unfold base.
     unfold ww_digits; rewrite (Zpos_xO w_digits).
     rewrite <- Zpower_exp; auto with zarith.
     apply f_equal with (f := fun x => 2 ^ x); auto with zarith.
  case (spec_to_Z xh); auto with zarith.
  Qed.

 End DoubleProof.

End DoubleLift.


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 A B C H AB Cprime Hprime : Universe, ((wd_ O E /\ (wd_ AB O /\ (wd_ H A /\ (wd_ C A /\ (wd_ H C /\ (wd_ A Cprime /\ (wd_ A Hprime /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ Hprime Cprime /\ (wd_ A B /\ (wd_ C B /\ (col_ O E AB /\ (col_ A C Hprime /\ (col_ A Cprime Hprime /\ (col_ A H Hprime /\ col_ A H Cprime)))))))))))))))) -> col_ H A C)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coqlib.
Require Import Asm.
Require Import Integers.
Require Import PeekTactics.
Require Import PeepsLib.
Require Import PregTactics.
Require Import StepIn.
Require Import AsmBits.
Require Import Values.
Require Import ValEq.
Require Import Integers.
Require Import PeepsTactics.

Definition peep_sub_neg_1_to_inc_example := Psub_ri EAX (Int.neg Int.one) :: nil.

Section SUB_NEG_1_TO_INC.

  Variable concrete : code.
  Variable r1 : ireg.

  Definition peep_sub_neg_1_to_inc_defs : rewrite_defs := {|
    fnd :=
     Psub_ri r1 (Int.neg Int.one)
      :: nil
    ; rpl :=
      Pinc r1
      :: nil
    ; lv_in := IR r1 :: PC :: nil
    ; lv_out := IR r1 :: PC :: nil
    ; clobbered := flags
  |}.

  Lemma peep_sub_neg_1_to_inc_selr :
    StepEquiv.step_through_equiv_live (fnd peep_sub_neg_1_to_inc_defs) (rpl peep_sub_neg_1_to_inc_defs) (lv_in peep_sub_neg_1_to_inc_defs) (lv_out peep_sub_neg_1_to_inc_defs).
  Proof.
    prep_l.
    step_l.
    prep_r.
    step_r.
    finish_r.
    prep_eq'.
    - subst.
      preg_simpl.
      unfold Val.sub.
      unfold Val.add.
      unfold Val.neg.
      simpl.
      repeat (break_match; P0 _simpl val_eq; repeat inv_vint; simpl; try congruence).
      f_equal.
      ring.
    - subst.
      preg_simpl.
      repeat find_rewrite_goal.
      simpl.
      f_equal.
  Qed.

  Definition peep_sub_neg_1_to_inc_proofs : rewrite_proofs :=
    {|
      defs := peep_sub_neg_1_to_inc_defs
      ; selr := peep_sub_neg_1_to_inc_selr
    |}.

  Definition peep_sub_neg_1_to_inc :
    concrete = fnd peep_sub_neg_1_to_inc_defs ->
    StepEquiv.rewrite.
  Proof.
    intros.
    peep_tac_mk_rewrite peep_sub_neg_1_to_inc_defs peep_sub_neg_1_to_inc_proofs.
  Qed.

End SUB_NEG_1_TO_INC.

Definition peep_sub_neg_1_to_inc_rewrite (c : code) : option StepEquiv.rewrite.
  name peep_sub_neg_1_to_inc p.
  unfold peep_sub_neg_1_to_inc_defs in p.
  simpl in p.
  specialize (p c).
  do 1 set_code_cons c.
  set_code_nil c.
  set_instr_eq i 0%nat peep_sub_neg_1_to_inc_example.
  set_int_eq n (Int.neg Int.one).
  specialize (p _ eq_refl). exact (Some p).
Defined.

Definition sub_neg_1_to_inc (c : code) : list StepEquiv.rewrite :=
  collect (map peep_sub_neg_1_to_inc_rewrite (ParamSplit.matched_pat peep_sub_neg_1_to_inc_example c)).


Require Import VST.floyd.proofauto.
From Coq Require Import Psatz.
Require Import cprogs.dlinklist_prog.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Definition t_struct_list := Tstruct _list noattr.

Fixpoint listrep_pre (sigma: list Z) (x: val) (t:val): mpred :=
 match sigma with
 | nil =>
    !! (x = nullval)&& emp
 | h::hs =>
    EX y:val,
      data_at Tsh t_struct_list (Vint (Int.repr h),(y,t)) x  *  listrep_pre hs y x
 end.
Definition listrep (sigma: list Z) (x: val) : mpred :=
listrep_pre sigma x nullval.
Arguments listrep sigma x : simpl never.

Fixpoint lseg_pre (sigma: list Z) (x y: val)(t s:val) : mpred :=
  match sigma with
  | nil => !! (x = y) &&!! (t = s)&& emp
  | h::hs => EX u:val, data_at Tsh t_struct_list (Vint (Int.repr h) , (u,t)) x * lseg_pre hs u y x s
  end.

Definition lseg (sigma: list Z) (x y: val) : mpred := EX t:val,
lseg_pre sigma x y nullval t.
Arguments lseg sigma x : simpl never.

Definition sum_Z (sigma: list Z): Z :=
  fold_right Z.add Z.zero sigma.

Lemma listrep_local_facts:
  forall sigma p q,
   listrep_pre sigma p q |--
   !! (is_pointer_or_null p /\ (p=nullval <-> sigma=nil)).
Proof.
induction sigma.
+ intros. unfold listrep. unfold listrep_pre. entailer!.
split. intros. auto. intros. auto.
+ intros. unfold listrep. unfold listrep_pre;fold listrep_pre. Intros y.
entailer!.
split; intro. subst p. destruct H; contradiction. inv H2.
Qed.

Hint Resolve listrep_local_facts : saturate_local.

Lemma listrep_valid_pointer:
  forall sigma p q,
   listrep_pre sigma p q|-- valid_pointer p.
Proof.
 destruct sigma; unfold listrep;unfold listrep_pre; fold listrep_pre;
 intros; normalize.
 auto with valid_pointer.
 apply sepcon_valid_pointer1.
 apply data_at_valid_ptr; auto.
 simpl;  computable.
Qed.

Hint Resolve listrep_valid_pointer : valid_pointer.

Lemma singleton_lseg: forall (a: Z) (x y z: val),
  data_at Tsh t_struct_list (Vint (Int.repr a), (y,z)) x |-- lseg_pre [a] x y z x .
Proof.
  intros. unfold lseg_pre. Exists y.
  entailer!.
Qed.

Lemma lseg_nullval_pre: forall sigma x y z,
  lseg_pre sigma x nullval y z|-- listrep_pre sigma x y.
Proof.
  intros.
  revert x y z; induction sigma; intros.
  + unfold listrep_pre;unfold lseg_pre.
    entailer!.
  + unfold lseg_pre;unfold listrep_pre.
    fold lseg_pre; fold listrep_pre.
    Intros u.
    Exists u. entailer!.
Qed.

Lemma lseg_nullval: forall sigma x,
  lseg sigma x nullval|-- listrep sigma x.
Proof.
  intros.
  unfold lseg. Intros t. apply lseg_nullval_pre.
Qed.

Lemma lseg_lseg_pre: forall (s1 s2: list Z) (x y z w u v: val),
  lseg_pre s1 x y w u* lseg_pre s2 y z u v|-- lseg_pre (s1 ++ s2) x z w v.
Proof.
  intros. revert x y z w u v. induction s1.
- simpl. intros. unfold lseg_pre;fold lseg_pre. entailer!.
- simpl. intros. Intros u0. Exists u0. unfold lseg. unfold lseg_pre;fold lseg_pre. entailer!.
  entailer!.
Qed.
Lemma lseg_listrep_pre :forall s1 p s t,lseg_pre s1 p nullval t s |-- listrep_pre s1 p t.
Proof.
  induction s1.
  - intros. simpl. entailer!.
  - intros. simpl. Intros u. Exists u.
  entailer!.
Qed.
Lemma sum_Z_snoc:
  forall a b, sum_Z (a++b :: nil) = Z.add (sum_Z a) b.
Proof.
  intros. unfold sum_Z. induction a.
- simpl. omega.
- simpl. rewrite IHa. omega.
Qed.

Fixpoint min_Z (sigma: list Z): Z :=
match sigma with
|nil => Int.max_unsigned
|h::t =>Z.min h (min_Z t)
end.

Fixpoint max_Z (sigma: list Z): Z :=
match sigma with
|nil => Z.zero
|h::t =>Z.max h (max_Z t)
end.
Lemma zero_le:0 <= Z.zero <= Int.max_unsigned.
Proof.
  split.
  + apply Z.le_refl.
  + apply Z.le_trans with  (Int.unsigned Int.zero).
  apply  Int.unsigned_range_2. apply  Int.unsigned_range_2.
Qed.
Lemma umax_le:0 <= Int.max_unsigned <= Int.max_unsigned.
Proof.
  split.
  + apply Z.le_trans with  (Int.unsigned Int.zero).
  apply  Int.unsigned_range_2. apply  Int.unsigned_range_2.
  + apply Z.le_refl.
Qed.

Lemma max_min1:forall s,s<>nil->min_Z s<=max_Z s.
Proof.
  induction s.
  + intros. destruct H. auto.
  + intros. unfold min_Z;unfold max_Z;fold min_Z;fold max_Z.
  apply Z.le_trans with a.
  ++ apply Z.le_min_l.
  ++ apply Z.le_max_l.
Qed.
Lemma max_min2:forall s1 z,max_Z (s1 ++ [z])=Z.max(max_Z s1) z.
Proof.
  induction s1.
  + intros. rewrite app_nil_l. unfold max_Z. apply computable_theorems.Zmax_comm.
  + intros. assert((a :: s1) ++ [z]=a :: (s1 ++ [z])).
  { simpl. auto. } rewrite H. unfold max_Z;fold max_Z.
  rewrite IHs1. apply Z.max_assoc.
Qed.
Lemma max_min3:forall s1 z,min_Z (s1 ++ [z])=Z.min(min_Z s1) z.
Proof.
  induction s1.
  + intros. rewrite app_nil_l. unfold min_Z. apply Z.min_comm.
  + intros. assert((a :: s1) ++ [z]=a :: (s1 ++ [z])).
  { simpl. auto. } rewrite H. unfold min_Z;fold min_Z.
  rewrite IHs1. apply Z.min_assoc.
Qed.
Lemma max_min4:forall s1 z s2,z<=max_Z (s1++[z]++s2).
Proof.
  induction s1.
  - intros. rewrite app_nil_l. simpl. apply Z.le_max_l.
  - simpl. intros. apply Z.le_trans with (max_Z (s1 ++ [z] ++ s2)). auto. apply Z.le_max_r.
Qed.
Lemma max_min5:forall s1 z s2,min_Z (s1++[z]++s2)<=z.
Proof.
  induction s1.
  - intros. rewrite app_nil_l. simpl. apply Z.le_min_l.
  - simpl. intros. apply Z.le_trans with (min_Z (s1 ++ [z] ++ s2)). apply Z.le_min_r. apply IHs1.
Qed.
Lemma max_min6_pre:forall s,Z.zero<=max_Z s.
Proof.
  intros.
  induction s.
  - simpl. omega.
  - unfold max_Z;fold max_Z. apply Z.le_trans with (max_Z s).
  auto. apply Z.le_max_r.
Qed.
Lemma max_min6:forall s1 z s2,max_Z s1<=max_Z (s1++[z]++s2).
Proof.
  intros. induction s1.
- simpl. apply Z.le_trans with (max_Z s2). apply max_min6_pre. apply Z.le_max_r.
- simpl. apply Z.max_le_compat_l. auto.
Qed.
Lemma max_min7_pre:forall s,min_Z s<=Int.max_unsigned.
Proof.
  intros.
  induction s.
  - simpl. omega.
  - unfold min_Z;fold min_Z. apply Z.le_trans with (min_Z s).
  auto. apply Z.le_min_r. auto.
Qed.
Lemma max_min7:forall s1 z s2,min_Z (s1++[z]++s2)<=min_Z s1.
Proof.
  intros. induction s1.
- simpl. apply Z.le_trans with (min_Z s2). apply Z.le_min_r. apply max_min7_pre.
- simpl. apply Z.min_le_compat_l. auto.
Qed.

Lemma lemmaforappend:forall s1 p t s z y r,
lseg_pre s1 p t r s * data_at Tsh t_struct_list (Vint (Int.repr z), (y, s)) t
|-- lseg_pre (s1 ++ [z]) p y r t.
Proof.
  simpl. intros. sep_apply (singleton_lseg z t y s).
  sep_apply (lseg_lseg_pre s1 [z] p t y r s t). entailer!.
Qed.

Lemma lseg_listrep_app:forall s1 s2 a b c d,
lseg_pre s1 a b c d*listrep_pre s2 b d |--listrep_pre (s1++s2) a c.
Proof.
  induction s1.
  + intros. unfold lseg_pre at 1.  simpl. entailer!.
  + intros. unfold lseg_pre;fold lseg_pre.
  Intros u. simpl. Exists u. entailer!. apply IHs1.
Qed.

Lemma temmp:forall sigma a u v q  p t,
data_at Tsh t_struct_list (Vint (Int.repr a), (u, v)) q * lseg_pre sigma u p q t
|-- !! is_pointer_or_null t.
Proof.
simpl. induction sigma.
+ intros. unfold lseg_pre. Intros. subst q. entailer!.
+ intros. unfold lseg_pre;fold lseg_pre. Intros u0.
sep_apply (IHsigma a u0 q u p t). entailer!.
Qed.
Lemma lsegpre_local_facts':
  forall sigma p q t,
   lseg_pre sigma q p nullval t|-- !! is_pointer_or_null t.
Proof.
 induction sigma; unfold lseg_pre;unfold lseg_pre; fold lseg_pre;
 intros.
 - entailer!.
 - Intros u.
  apply temmp.
Qed.

Hint Resolve lsegpre_local_facts' : saturate_local.
(* Definition Delete_spec :=
 DECLARE _Delete
  WITH s1 : list Z,s2:list Z, p: val, q:val, t:val,z:Z,r:val
  PRE  [ _p OF (tptr t_struct_list),_q OF (tptr t_struct_list) ]
     PROP ()
     LOCAL (temp _p p;temp _q q)
     SEP (lseg_pre s1 p q nullval t;lseg_pre [z] q r t q;listrep_pre s2 r q)
  POST [ (tptr t_struct_list) ]
     PROP ()
     LOCAL (temp ret_temp p)
     SEP (lseg_pre s1 q p nullval t;listrep_pre s2 p t).

Lemma body_Delete: semax_body Vprog Gprog f_Delete Delete_spec.
Proof.
start_function. forward_if (
     PROP ()
     LOCAL (temp ret_temp p)
     SEP (lseg_pre s1 q p nullval t;listrep_pre s2 p t)).
  + admit.
  + forward_if (
     PROP ()
     LOCAL (temp ret_temp p)
     SEP (lseg_pre s1 q p nullval t;listrep_pre s2 p t)).
  ++ destruct s1.
  +++ unfold lseg_pre. Intros u. entailer!.
  +++ unfold lseg_pre;fold lseg_pre. Intros u. Intros u0. entailer!.
  ++ simpl. Intros u. destruct s1.
  +++ unfold lseg_pre. Intros. admit.
  +++ unfold lseg_pre;fold lseg_pre. Intros u0. forward.
  ++++ entailer!. admit.
  ++++ admit.
Admitted. *)


Require Import RelationClasses.
Require Import PropX PropXTac.
Require Import MirrorShard.SepTheory.
Require Import MirrorShard.Heaps.
Require IL.

Set Implicit Arguments.
Set Strict Implicit.

Module Type PcSt.
  Parameter pcType : Type.
  Parameter stateType : Type.
End PcSt.

(** We make this transparent, so that clients can get at
 ** [ihprop] and it associated lemmas
 **)
Module SepTheoryPropX_Kernel (SM : SeparationMemory) (PC_ST : PcSt) <:
  SepTheory_Kernel
  with Definition hprop :=
         IL.settings -> SM.smem -> PropX PC_ST.pcType PC_ST.stateType
  with Definition himp :=
         fun (gl gr : IL.settings -> SM.smem -> PropX PC_ST.pcType PC_ST.stateType) =>
           forall cs stn m, interp cs (gl stn m ---> gr stn m).

  Import PC_ST.

  Definition ihprop (sos : list Type) : Type :=
    IL.settings -> SM.smem -> propX PC_ST.pcType PC_ST.stateType sos.

  Definition hprop : Type := ihprop nil.

  Definition himp : ihprop nil -> ihprop nil -> Prop :=
    fun gl gr =>
      forall cs stn m, interp cs (gl stn m ---> gr stn m).

  Global Instance Refl_himp : Reflexive himp.
  Proof.
    red; unfold himp; intros.
    eapply Imply_I; eauto.
  Qed.
  Global Instance Trans_himp : Transitive himp.
  Proof.
    red; unfold himp; firstorder.
    eapply Imply_I. eapply Imply_E. eapply valid_weaken. eapply H0. firstorder.
    eapply Imply_E. eapply valid_weaken. eapply H. firstorder. eauto.
  Qed.

  Section with_sos.
    Variable sos : list Type.

    (* Definitions *)
    Definition iinjX (p : propX pcType stateType sos) : ihprop sos :=
      fun _ m => PropX.And p (PropX.Inj (m = SM.smem_emp)).

    Definition iinj (p : Prop) : ihprop sos := iinjX (PropX.Inj p).

    Definition iemp : ihprop sos := iinj True.

    Definition istar (l r : ihprop sos) : ihprop sos :=
      fun s m => PropX.Exists (fun ml : SM.smem => PropX.Exists (fun mr : SM.smem =>
        PropX.And (PropX.Inj (SM.split m ml mr)) (And (l s ml) (r s mr)))).

    Definition iex (T : Type) (p : T -> ihprop sos) : ihprop sos :=
      fun s h => PropX.Exists (fun t => p t s h).

    Definition ihptsto (p : SM.M.addr) (v : SM.M.value) : ihprop sos :=
      fun s h =>
        PropX.Inj (SM.smem_get p h = Some v /\ forall p', p' <> p -> SM.smem_get p' h = None).
  End with_sos.

  (* Definitions *)
  Definition injX := @iinjX nil.

  Definition inj := @iinj nil.

  Definition emp := @iemp nil.

  Definition star := @istar nil.

  Definition ex := @iex nil.

  Definition hptsto := @ihptsto nil.

  Ltac unfold_all :=
    unfold ex, star, emp, inj, injX, iex, istar, iemp, iinj, iinjX, himp, interp.

  Require Import PropXRel.

  Hint Immediate SM.split_comm : heaps.
  Hint Resolve SM.split_assoc : heaps.

  Lemma himp_star_comm : forall P Q, himp (star P Q) (star Q P).
  Proof.
    unfold_all; intros; propxIntuition.
    do 2 eapply Exists_I. propxIntuition; eauto using SM.split_comm.
  Qed.

  Theorem himp_star_assoc : forall P Q R,
    himp (star (star P Q) R) (star P (star Q R)).
  Proof.
    unfold_all; intros; propxIntuition.
    destruct (SM.split_assoc _ _ _ _ _ H H0). clear H H0. destruct H1.
    do 2 eapply Exists_I; propxIntuition. eauto. do 2 eapply Exists_I. propxIntuition. eauto.
  Qed.

  Theorem himp_star_emp_p : forall P : hprop, himp (star emp P) P.
  Proof.
    unfold_all; intros; propxIntuition.
    subst. eapply SM.split_emp in H. subst; propxIntuition.
  Qed.

  Theorem himp_star_emp_c : forall P : hprop, himp P (star emp P).
  Proof.
    unfold_all; intros; propxIntuition.
    do 2 eapply Exists_I. instantiate (1 := m). instantiate (1 := SM.smem_emp).
    propxIntuition; auto. eapply SM.split_emp; auto.
  Qed.

  Theorem himp_star_frame : forall P Q R S,
    himp P Q -> himp R S -> himp (star P R) (star Q S).
  Proof.
    unfold_all; intros; propxIntuition.
    do 2 eapply Exists_I. propxIntuition. eassumption.
    eapply Imply_E. eapply valid_weaken. eapply H. firstorder. propxIntuition.
    eapply Imply_E. eapply valid_weaken. eapply H0. firstorder. propxIntuition.
  Qed.

  Theorem himp_star_pure_p :
    forall (P Q : hprop) (F : Prop),
      himp (star (inj F) P) Q -> F -> himp P Q.
  Proof.
    unfold_all; intros; propxIntuition.
    specialize (H cs stn m).
    eapply Imply_E. eapply valid_weaken. eapply H. firstorder.
    do 2 eapply Exists_I; propxIntuition. eapply SM.split_emp; auto. auto. reflexivity.
  Qed.

  Theorem himp_star_pure_c :
    forall (P Q : hprop) (F : Prop),
      (F -> himp P Q) -> himp (star (inj F) P) Q.
  Proof.
    unfold_all; intros; propxIntuition.
    propxIntuition. eapply Imply_E.
    eapply valid_weaken. eapply H; auto. firstorder.
    subst. eapply SM.split_emp in H0. subst.
    constructor; firstorder.
  Qed.

  Theorem himp_star_pure_cc :
    forall (P Q : hprop) (p : Prop),
      p -> himp P Q -> himp P (star (inj p) Q).
  Proof.
    unfold_all; intros; propxIntuition.
    do 2 eapply Exists_I; propxIntuition.
    2: eauto. 2: reflexivity. eapply SM.split_emp; reflexivity.
    eapply Imply_E. eapply valid_weaken. eapply H0. firstorder.
    constructor; firstorder.
  Qed.

  Theorem himp_ex_p :
    forall (T : Type) (P : T -> hprop) (Q : hprop),
      (forall v : T, himp (P v) Q) -> himp (ex P) Q.
  Proof.
    unfold_all; intros; propxIntuition.
    eapply Imply_E. eapply valid_weaken. eapply H. firstorder. constructor; firstorder.
  Qed.

  Theorem himp_ex_c :
    forall (T : Type) (P : T -> hprop) (Q : hprop),
      (exists v : T, himp Q (P v)) -> himp Q (ex P).
  Proof.
    unfold_all; intros; propxIntuition.
    destruct H. eapply Exists_I.
    instantiate (1 := x). eapply Imply_E.
    eapply valid_weaken; try eapply H. firstorder. constructor; firstorder.
  Qed.

  Theorem himp_ex_star : forall T (P : T -> _) Q,
    himp (star (ex P) Q) (ex (fun x => star (P x) Q)).
  Proof.
    unfold_all; intros; propxIntuition.
    eapply Exists_I with (B := x1). do 2 eapply Exists_I. propxIntuition; auto.
  Qed.

  Theorem himp_star_ex : forall T (P : T -> _) Q,
    himp (ex (fun x => star (P x) Q)) (star (ex P) Q).
  Proof.
    unfold_all; intros; propxIntuition.
    do 2 eapply Exists_I; propxIntuition; eauto.
    eapply Exists_I; propxIntuition.
  Qed.

  (** Interp **)
  Lemma interp_himp : forall cs stn sm P Q,
    interp cs (P stn sm) ->
    himp P Q ->
    interp cs (Q stn sm).
  Proof.
    unfold himp; intros.
    eapply Imply_E. eapply H0. auto.
  Qed.

  Theorem interp_star : forall cs stn sm P Q,
    interp cs ((star P Q) stn sm) ->
    exists sm1 sm2, SM.split sm sm1 sm2 /\
      interp cs (P stn sm1) /\ interp cs (Q stn sm2).
  Proof.
    unfold star. intros; propxFo; eauto.
  Qed.

  Theorem interp_pure : forall cs stn sm P,
    interp cs ((inj P) stn sm) ->
    P /\ sm = SM.smem_emp.
  Proof.
    unfold inj, iinj, iinjX. intros. propxFo.
  Qed.

  Theorem interp_ex : forall cs stn sm T (P : T -> _),
    interp cs ((ex P) stn sm) ->
    exists x, interp cs ((P x) stn sm).
  Proof.
    unfold ex. intros. propxFo; eauto.
  Qed.

End SepTheoryPropX_Kernel.


(*interface (e) to show the difference
between SME-NI and the extended SIR-NNI*)

Require Export refine.
Require Export parser.

Definition expr2e: IA := parse
"IA [s1,s2,s3,s4,s5] (s1) [h1,h2] [m1,m2] []
 [s1->(h1)s2, s1->(h2)s3, s2->(m1)s4, s3->(m2)s5]".

(*at m1: false*)
Definition expr2e_m1_res: IA :=
 IAutomaton.hiding
 ( IAutomaton.restriction expr2e (ASet.GenActs [&"h1",&"h2"]) )
 (ASet.GenActs [&"m2"]).

Definition expr2e_m1_hid: IA :=
IAutomaton.hiding expr2e (ASet.GenActs [&"h1",&"h2",&"m2"]).

Eval compute in RNNI_refinement expr2e_m1_res expr2e_m1_hid.

(*at m2: false*)
Definition expr2e_m2_res: IA :=
 IAutomaton.hiding
 ( IAutomaton.restriction expr2e (ASet.GenActs [&"h1",&"h2"]) )
 (ASet.GenActs [&"m1"]).

Definition expr2e_m2_hid: IA :=
IAutomaton.hiding expr2e (ASet.GenActs [&"h1",&"h2",&"m1"]).

Eval compute in RNNI_refinement expr2e_m2_res expr2e_m2_hid.

(*at l: true*)
Definition expr2e_l_res: IA :=
 IAutomaton.hiding
 ( IAutomaton.restriction expr2e (ASet.GenActs [&"h1",&"h2"]) )
 (ASet.GenActs [&"m1",&"m2"]).
(*Eval compute in IAutomaton.display expr2e_l_res.*)

Definition expr2e_l_hid: IA :=
IAutomaton.hiding expr2e (ASet.GenActs [&"h1",&"h2",&"m1",&"m2"]).

Eval compute in RNNI_refinement expr2e_l_res expr2e_l_hid.