(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2010-2011 Sylvie Boldo
#<br />#
Copyright (C) 2010-2011 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.
*)

(** * Locations: where a real number is positioned with respect to its rounded-down value in an arbitrary format. *)

Require Import Fcore_Raux.
Require Import Fcore_defs.
Require Import Fcore_float_prop.

Section Fcalc_bracket.

Variable d u : R.
Hypothesis Hdu : (d < u)%R.

Inductive location := loc_Exact | loc_Inexact : comparison -> location.

Variable x : R.

Definition inbetween_loc :=
  match Rcompare x d with
  | Gt => loc_Inexact (Rcompare x ((d + u) / 2))
  | _ => loc_Exact
  end.

(** Locates a real number with respect to the middle of two other numbers. *)

Inductive inbetween : location -> Prop :=
  | inbetween_Exact : x = d -> inbetween loc_Exact
  | inbetween_Inexact l : (d < x < u)%R -> Rcompare x ((d + u) / 2)%R = l -> inbetween (loc_Inexact l).

Theorem inbetween_spec :
  (d <= x < u)%R -> inbetween inbetween_loc.
Proof.
intros Hx.
unfold inbetween_loc.
destruct (Rcompare_spec x d) as [H|H|H].
now elim Rle_not_lt with (1 := proj1 Hx).
now constructor.
constructor.
now split.
easy.
Qed.

Theorem inbetween_unique :
  forall l l',
  inbetween l -> inbetween l' -> l = l'.
Proof.
intros l l' Hl Hl'.
inversion_clear Hl ; inversion_clear Hl'.
apply refl_equal.
rewrite H in H0.
elim Rlt_irrefl with (1 := proj1 H0).
rewrite H1 in H.
elim Rlt_irrefl with (1 := proj1 H).
apply f_equal.
now rewrite <- H0.
Qed.

Section Fcalc_bracket_any.

Variable l : location.

Theorem inbetween_bounds :
  inbetween l ->
  (d <= x < u)%R.
Proof.
intros [Hx|l' Hx Hl] ; clear l.
rewrite Hx.
split.
apply Rle_refl.
exact Hdu.
now split ; try apply Rlt_le.
Qed.

Theorem inbetween_bounds_not_Eq :
  inbetween l ->
  l <> loc_Exact ->
  (d < x < u)%R.
Proof.
intros [Hx|l' Hx Hl] H.
now elim H.
exact Hx.
Qed.

End Fcalc_bracket_any.

Theorem inbetween_distance_inexact :
  forall l,
  inbetween (loc_Inexact l) ->
  Rcompare (x - d) (u - x) = l.
Proof.
intros l Hl.
inversion_clear Hl as [|l' Hl' Hx].
now rewrite Rcompare_middle.
Qed.

Theorem inbetween_distance_inexact_abs :
  forall l,
  inbetween (loc_Inexact l) ->
  Rcompare (Rabs (d - x)) (Rabs (u - x)) = l.
Proof.
intros l Hl.
rewrite Rabs_left1.
rewrite Rabs_pos_eq.
rewrite Ropp_minus_distr.
now apply inbetween_distance_inexact.
apply Rle_0_minus.
apply Rlt_le.
apply (inbetween_bounds _ Hl).
apply Rle_minus.
apply (inbetween_bounds _ Hl).
Qed.

End Fcalc_bracket.

Theorem inbetween_ex :
  forall d u l,
  (d < u)%R ->
  exists x,
  inbetween d u x l.
Proof.
intros d u [|l] Hdu.
exists d.
now constructor.
exists (d + match l with Lt => 1 | Eq => 2 | Gt => 3 end / 4 * (u - d))%R.
constructor.
(* *)
set (v := (match l with Lt => 1 | Eq => 2 | Gt => 3 end / 4)%R).
assert (0 < v < 1)%R.
split.
unfold v, Rdiv.
apply Rmult_lt_0_compat.
case l.
now apply (Z2R_lt 0 2).
now apply (Z2R_lt 0 1).
now apply (Z2R_lt 0 3).
apply Rinv_0_lt_compat.
now apply (Z2R_lt 0 4).
unfold v, Rdiv.
apply Rmult_lt_reg_r with 4%R.
now apply (Z2R_lt 0 4).
rewrite Rmult_assoc, Rinv_l.
rewrite Rmult_1_r, Rmult_1_l.
case l.
now apply (Z2R_lt 2 4).
now apply (Z2R_lt 1 4).
now apply (Z2R_lt 3 4).
apply Rgt_not_eq.
now apply (Z2R_lt 0 4).
split.
apply Rplus_lt_reg_r with (d * (v - 1))%R.
ring_simplify.
rewrite Rmult_comm.
now apply Rmult_lt_compat_l.
apply Rplus_lt_reg_r with (-u * v)%R.
replace (- u * v + (d + v * (u - d)))%R with (d * (1 - v))%R by ring.
replace (- u * v + u)%R with (u * (1 - v))%R by ring.
apply Rmult_lt_compat_r.
apply Rplus_lt_reg_r with v.
now ring_simplify.
exact Hdu.
(* *)
set (v := (match l with Lt => 1 | Eq => 2 | Gt => 3 end)%R).
rewrite <- (Rcompare_plus_r (- (d + u) / 2)).
rewrite <- (Rcompare_mult_r 4).
2: now apply (Z2R_lt 0 4).
replace (((d + u) / 2 + - (d + u) / 2) * 4)%R with ((u - d) * 0)%R by field.
replace ((d + v / 4 * (u - d) + - (d + u) / 2) * 4)%R with ((u - d) * (v - 2))%R by field.
rewrite Rcompare_mult_l.
2: now apply Rlt_Rminus.
rewrite <- (Rcompare_plus_r 2).
ring_simplify (v - 2 + 2)%R (0 + 2)%R.
unfold v.
case l.
exact (Rcompare_Z2R 2 2).
exact (Rcompare_Z2R 1 2).
exact (Rcompare_Z2R 3 2).
Qed.

Section Fcalc_bracket_step.

Variable start step : R.
Variable nb_steps : Z.
Variable Hstep : (0 < step)%R.

Lemma ordered_steps :
  forall k,
  (start + Z2R k * step < start + Z2R (k + 1) * step)%R.
Proof.
intros k.
apply Rplus_lt_compat_l.
apply Rmult_lt_compat_r.
exact Hstep.
apply Z2R_lt.
apply Zlt_succ.
Qed.

Lemma middle_range :
  forall k,
  ((start + (start + Z2R k * step)) / 2 = start + (Z2R k / 2 * step))%R.
Proof.
intros k.
field.
Qed.

Hypothesis (Hnb_steps : (1 < nb_steps)%Z).

Lemma inbetween_step_not_Eq :
  forall x k l l',
  inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l ->
  (0 < k < nb_steps)%Z ->
  Rcompare x (start + (Z2R nb_steps / 2 * step))%R = l' ->
  inbetween start (start + Z2R nb_steps * step) x (loc_Inexact l').
Proof.
intros x k l l' Hx Hk Hl'.
constructor.
(* . *)
assert (Hx' := inbetween_bounds _ _ (ordered_steps _) _ _ Hx).
split.
apply Rlt_le_trans with (2 := proj1 Hx').
rewrite <- (Rplus_0_r start) at 1.
apply Rplus_lt_compat_l.
apply Rmult_lt_0_compat.
now apply (Z2R_lt 0).
exact Hstep.
apply Rlt_le_trans with (1 := proj2 Hx').
apply Rplus_le_compat_l.
apply Rmult_le_compat_r.
now apply Rlt_le.
apply Z2R_le.
omega.
(* . *)
now rewrite middle_range.
Qed.

Theorem inbetween_step_Lo :
  forall x k l,
  inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l ->
  (0 < k)%Z -> (2 * k + 1 < nb_steps)%Z ->
  inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Lt).
Proof.
intros x k l Hx Hk1 Hk2.
apply inbetween_step_not_Eq with (1 := Hx).
omega.
apply Rcompare_Lt.
assert (Hx' := inbetween_bounds _ _ (ordered_steps _) _ _ Hx).
apply Rlt_le_trans with (1 := proj2 Hx').
apply Rcompare_not_Lt_inv.
rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_l.
apply Rcompare_not_Lt.
change 2%R with (Z2R 2).
rewrite <- Z2R_mult.
apply Z2R_le.
omega.
exact Hstep.
Qed.

Theorem inbetween_step_Hi :
  forall x k l,
  inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l ->
  (nb_steps < 2 * k)%Z -> (k < nb_steps)%Z ->
  inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Gt).
Proof.
intros x k l Hx Hk1 Hk2.
apply inbetween_step_not_Eq with (1 := Hx).
omega.
apply Rcompare_Gt.
assert (Hx' := inbetween_bounds _ _ (ordered_steps _) _ _ Hx).
apply Rlt_le_trans with (2 := proj1 Hx').
apply Rcompare_Lt_inv.
rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_l.
apply Rcompare_Lt.
change 2%R with (Z2R 2).
rewrite <- Z2R_mult.
apply Z2R_lt.
omega.
exact Hstep.
Qed.

Theorem inbetween_step_Lo_not_Eq :
  forall x l,
  inbetween start (start + step) x l ->
  l <> loc_Exact ->
  inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Lt).
Proof.
intros x l Hx Hl.
assert (Hx' := inbetween_bounds_not_Eq _ _ _ _ Hx Hl).
constructor.
(* . *)
split.
apply Hx'.
apply Rlt_trans with (1 := proj2 Hx').
apply Rplus_lt_compat_l.
rewrite <- (Rmult_1_l step) at 1.
apply Rmult_lt_compat_r.
exact Hstep.
now apply (Z2R_lt 1).
(* . *)
apply Rcompare_Lt.
apply Rlt_le_trans with (1 := proj2 Hx').
rewrite middle_range.
apply Rcompare_not_Lt_inv.
rewrite <- (Rmult_1_l step) at 2.
rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_l.
rewrite Rmult_1_r.
apply Rcompare_not_Lt.
apply (Z2R_le 2).
now apply (Zlt_le_succ 1).
exact Hstep.
Qed.

Lemma middle_odd :
  forall k,
  (2 * k + 1 = nb_steps)%Z ->
  (((start + Z2R k * step) + (start + Z2R (k + 1) * step))/2 = start + Z2R nb_steps /2 * step)%R.
Proof.
intros k Hk.
rewrite <- Hk.
rewrite 2!Z2R_plus, Z2R_mult.
simpl. field.
Qed.

Theorem inbetween_step_any_Mi_odd :
  forall x k l,
  inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x (loc_Inexact l) ->
  (2 * k + 1 = nb_steps)%Z ->
  inbetween start (start + Z2R nb_steps * step) x (loc_Inexact l).
Proof.
intros x k l Hx Hk.
apply inbetween_step_not_Eq with (1 := Hx).
omega.
inversion_clear Hx as [|l' _ Hl].
now rewrite (middle_odd _ Hk) in Hl.
Qed.

Theorem inbetween_step_Lo_Mi_Eq_odd :
  forall x k,
  inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x loc_Exact ->
  (2 * k + 1 = nb_steps)%Z ->
  inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Lt).
Proof.
intros x k Hx Hk.
apply inbetween_step_not_Eq with (1 := Hx).
omega.
inversion_clear Hx as [Hl|].
rewrite Hl.
rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_r.
apply Rcompare_Lt.
change 2%R with (Z2R 2).
rewrite <- Z2R_mult.
apply Z2R_lt.
rewrite <- Hk.
apply Zlt_succ.
exact Hstep.
Qed.

Theorem inbetween_step_Hi_Mi_even :
  forall x k l,
  inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l ->
  l <> loc_Exact ->
  (2 * k = nb_steps)%Z ->
  inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Gt).
Proof.
intros x k l Hx Hl Hk.
apply inbetween_step_not_Eq with (1 := Hx).
omega.
apply Rcompare_Gt.
assert (Hx' := inbetween_bounds_not_Eq _ _ _ _ Hx Hl).
apply Rle_lt_trans with (2 := proj1 Hx').
apply Rcompare_not_Lt_inv.
rewrite Rcompare_plus_l, Rcompare_mult_r, Rcompare_half_r.
change 2%R with (Z2R 2).
rewrite <- Z2R_mult.
apply Rcompare_not_Lt.
apply Z2R_le.
rewrite Hk.
apply Zle_refl.
exact Hstep.
Qed.

Theorem inbetween_step_Mi_Mi_even :
  forall x k,
  inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x loc_Exact ->
  (2 * k = nb_steps)%Z ->
  inbetween start (start + Z2R nb_steps * step) x (loc_Inexact Eq).
Proof.
intros x k Hx Hk.
apply inbetween_step_not_Eq with (1 := Hx).
omega.
apply Rcompare_Eq.
inversion_clear Hx as [Hx'|].
rewrite Hx', <- Hk, Z2R_mult.
simpl (Z2R 2).
field.
Qed.

(** Computes a new location when the interval containing a real
    number is split into nb_steps subintervals and the real is
    in the k-th one. (Even radix.) *)

Definition new_location_even k l :=
  if Zeq_bool k 0 then
    match l with loc_Exact => l | _ => loc_Inexact Lt end
  else
    loc_Inexact
    match Zcompare (2 * k) nb_steps with
    | Lt => Lt
    | Eq => match l with loc_Exact => Eq | _ => Gt end
    | Gt => Gt
    end.

Theorem new_location_even_correct :
  Zeven nb_steps = true ->
  forall x k l, (0 <= k < nb_steps)%Z ->
  inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l ->
  inbetween start (start + Z2R nb_steps * step) x (new_location_even k l).
Proof.
intros He x k l Hk Hx.
unfold new_location_even.
destruct (Zeq_bool_spec k 0) as [Hk0|Hk0].
(* k = 0 *)
rewrite Hk0 in Hx.
rewrite Rmult_0_l, Rplus_0_r, Rmult_1_l in Hx.
set (l' := match l with loc_Exact => l | _ => loc_Inexact Lt end).
assert ((l = loc_Exact /\ l' = loc_Exact) \/ (l <> loc_Exact /\ l' = loc_Inexact Lt)).
unfold l' ; case l ; try (now left) ; right ; now split.
destruct H as [(H1,H2)|(H1,H2)] ; rewrite H2.
constructor.
rewrite H1 in Hx.
now inversion_clear Hx.
now apply inbetween_step_Lo_not_Eq with (2 := H1).
(* k <> 0 *)
destruct (Zcompare_spec (2 * k) nb_steps) as [Hk1|Hk1|Hk1].
(* . 2 * k < nb_steps *)
apply inbetween_step_Lo with (1 := Hx).
omega.
destruct (Zeven_ex nb_steps).
rewrite He in H.
omega.
(* . 2 * k = nb_steps *)
set (l' := match l with loc_Exact => Eq | _ => Gt end).
assert ((l = loc_Exact /\ l' = Eq) \/ (l <> loc_Exact /\ l' = Gt)).
unfold l' ; case l ; try (now left) ; right ; now split.
destruct H as [(H1,H2)|(H1,H2)] ; rewrite H2.
rewrite H1 in Hx.
now apply inbetween_step_Mi_Mi_even with (1 := Hx).
now apply inbetween_step_Hi_Mi_even with (1 := Hx).
(* . 2 * k > nb_steps *)
apply inbetween_step_Hi with (1 := Hx).
exact Hk1.
apply Hk.
Qed.

(** Computes a new location when the interval containing a real
    number is split into nb_steps subintervals and the real is
    in the k-th one. (Odd radix.) *)

Definition new_location_odd k l :=
  if Zeq_bool k 0 then
    match l with loc_Exact => l | _ => loc_Inexact Lt end
  else
    loc_Inexact
    match Zcompare (2 * k + 1) nb_steps with
    | Lt => Lt
    | Eq => match l with loc_Inexact l => l | loc_Exact => Lt end
    | Gt => Gt
    end.

Theorem new_location_odd_correct :
  Zeven nb_steps = false ->
  forall x k l, (0 <= k < nb_steps)%Z ->
  inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l ->
  inbetween start (start + Z2R nb_steps * step) x (new_location_odd k l).
Proof.
intros Ho x k l Hk Hx.
unfold new_location_odd.
destruct (Zeq_bool_spec k 0) as [Hk0|Hk0].
(* k = 0 *)
rewrite Hk0 in Hx.
rewrite Rmult_0_l, Rplus_0_r, Rmult_1_l in Hx.
set (l' := match l with loc_Exact => l | _ => loc_Inexact Lt end).
assert ((l = loc_Exact /\ l' = loc_Exact) \/ (l <> loc_Exact /\ l' = loc_Inexact Lt)).
unfold l' ; case l ; try (now left) ; right ; now split.
destruct H as [(H1,H2)|(H1,H2)] ; rewrite H2.
constructor.
rewrite H1 in Hx.
now inversion_clear Hx.
now apply inbetween_step_Lo_not_Eq with (2 := H1).
(* k <> 0 *)
destruct (Zcompare_spec (2 * k + 1) nb_steps) as [Hk1|Hk1|Hk1].
(* . 2 * k + 1 < nb_steps *)
apply inbetween_step_Lo with (1 := Hx) (3 := Hk1).
omega.
(* . 2 * k + 1 = nb_steps *)
destruct l.
apply inbetween_step_Lo_Mi_Eq_odd with (1 := Hx) (2 := Hk1).
apply inbetween_step_any_Mi_odd with (1 := Hx) (2 := Hk1).
(* . 2 * k + 1 > nb_steps *)
apply inbetween_step_Hi with (1 := Hx).
destruct (Zeven_ex nb_steps).
rewrite Ho in H.
omega.
apply Hk.
Qed.

Definition new_location :=
  if Zeven nb_steps then new_location_even else new_location_odd.

Theorem new_location_correct :
  forall x k l, (0 <= k < nb_steps)%Z ->
  inbetween (start + Z2R k * step) (start + Z2R (k + 1) * step) x l ->
  inbetween start (start + Z2R nb_steps * step) x (new_location k l).
Proof.
intros x k l Hk Hx.
unfold new_location.
generalize (refl_equal nb_steps) (Zle_lt_trans _ _ _ (proj1 Hk) (proj2 Hk)).
pattern nb_steps at 2 3 5 ; case nb_steps.
now intros _.
(* . *)
intros [p|p|] Hp _.
apply new_location_odd_correct with (2 := Hk) (3 := Hx).
now rewrite Hp.
apply new_location_even_correct with (2 := Hk) (3 := Hx).
now rewrite Hp.
now rewrite Hp in Hnb_steps.
(* . *)
now intros p _.
Qed.

End Fcalc_bracket_step.

Section Fcalc_bracket_scale.

Lemma inbetween_mult_aux :
  forall x d s,
  ((x * s + d * s) / 2 = (x + d) / 2 * s)%R.
Proof.
intros x d s.
field.
Qed.

Theorem inbetween_mult_compat :
  forall x d u l s,
  (0 < s)%R ->
  inbetween x d u l ->
  inbetween (x * s) (d * s) (u * s) l.
Proof.
intros x d u l s Hs [Hx|l' Hx Hl] ; constructor.
now rewrite Hx.
now split ; apply Rmult_lt_compat_r.
rewrite inbetween_mult_aux.
now rewrite Rcompare_mult_r.
Qed.

Theorem inbetween_mult_reg :
  forall x d u l s,
  (0 < s)%R ->
  inbetween (x * s) (d * s) (u * s) l ->
  inbetween x d u l.
Proof.
intros x d u l s Hs [Hx|l' Hx Hl] ; constructor.
apply Rmult_eq_reg_r with (1 := Hx).
now apply Rgt_not_eq.
now split ; apply Rmult_lt_reg_r with s.
rewrite <- Rcompare_mult_r with (1 := Hs).
now rewrite inbetween_mult_aux in Hl.
Qed.

End Fcalc_bracket_scale.

Section Fcalc_bracket_generic.

Variable beta : radix.
Notation bpow e := (bpow beta e).

(** Specialization of inbetween for two consecutive floating-point numbers. *)

Definition inbetween_float m e x l :=
  inbetween (F2R (Float beta m e)) (F2R (Float beta (m + 1) e)) x l.

Theorem inbetween_float_bounds :
  forall x m e l,
  inbetween_float m e x l ->
  (F2R (Float beta m e) <= x < F2R (Float beta (m + 1) e))%R.
Proof.
intros x m e l [Hx|l' Hx Hl].
rewrite Hx.
split.
apply Rle_refl.
apply F2R_lt_compat.
apply Zlt_succ.
split.
now apply Rlt_le.
apply Hx.
Qed.

(** Specialization of inbetween for two consecutive integers. *)

Definition inbetween_int m x l :=
  inbetween (Z2R m) (Z2R (m + 1)) x l.

Theorem inbetween_float_new_location :
  forall x m e l k,
  (0 < k)%Z ->
  inbetween_float m e x l ->
  inbetween_float (Zdiv m (Zpower beta k)) (e + k) x (new_location (Zpower beta k) (Zmod m (Zpower beta k)) l).
Proof.
intros x m e l k Hk Hx.
unfold inbetween_float in *.
assert (Hr: forall m, F2R (Float beta m (e + k)) = F2R (Float beta (m * Zpower beta k) e)).
clear -Hk. intros m.
rewrite (F2R_change_exp beta e).
apply (f_equal (fun r => F2R (Float beta (m * Zpower _ r) e))).
ring.
omega.
assert (Hp: (Zpower beta k > 0)%Z).
apply Zlt_gt.
apply Zpower_gt_0.
now apply Zlt_le_weak.
(* . *)
rewrite 2!Hr.
rewrite Zmult_plus_distr_l, Zmult_1_l.
unfold F2R at 2. simpl.
rewrite Z2R_plus, Rmult_plus_distr_r.
apply new_location_correct.
apply bpow_gt_0.
now apply Zpower_gt_1.
now apply Z_mod_lt.
rewrite <- 2!Rmult_plus_distr_r, <- 2!Z2R_plus.
rewrite Zmult_comm, Zplus_assoc.
now rewrite <- Z_div_mod_eq.
Qed.

Theorem inbetween_float_new_location_single :
  forall x m e l,
  inbetween_float m e x l ->
  inbetween_float (Zdiv m beta) (e + 1) x (new_location beta (Zmod m beta) l).
Proof.
intros x m e l Hx.
replace (radix_val beta) with (Zpower beta 1).
now apply inbetween_float_new_location.
apply Zmult_1_r.
Qed.

Theorem inbetween_float_ex :
  forall m e l,
  exists x,
  inbetween_float m e x l.
Proof.
intros m e l.
apply inbetween_ex.
apply F2R_lt_compat.
apply Zlt_succ.
Qed.

Theorem inbetween_float_unique :
  forall x e m l m' l',
  inbetween_float m e x l ->
  inbetween_float m' e x l' ->
  m = m' /\ l = l'.
Proof.
intros x e m l m' l' H H'.
refine ((fun Hm => conj Hm _) _).
rewrite <- Hm in H'. clear -H H'.
apply inbetween_unique with (1 := H) (2 := H').
destruct (inbetween_float_bounds x m e l H) as (H1,H2).
destruct (inbetween_float_bounds x m' e l' H') as (H3,H4).
cut (m < m' + 1 /\ m' < m + 1)%Z. clear ; omega.
now split ; apply F2R_lt_reg with beta e ; apply Rle_lt_trans with x.
Qed.

End Fcalc_bracket_generic.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 This tests the dynamic semantics of statements and expressions, pg. 58, 59.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.

Require Export FormalSyntax.
Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.
Require Export DynamicSemantics.
Require Export Tacticals.

Require Export TestUtilities.

(* Test the S judgement. *)

(* ?TODO Let's make these tests more meaninful. *)

(* Let's make some e->e' transitions that actually evaluate something to test this stuff. *)

Definition s  := (if_s (i_e (i_i 0))
                       (e_s (i_e (i_i 0)))
                       (e_s (i_e (i_i 1)))).
Definition s' := (e_s (i_e (i_i 0))).

Definition e  := (dot (cpair (i_e (i_i 0)) (i_e (i_i 1))) (i_i 0)).
Definition e' := (i_e (i_i 0)).

Definition hxv := [(x,v)].

Example S_Let_3_1_test :
  S [] (letx x v s) [(x,v)] s.
Proof.
  apply S_let_3_1;
  eauto 10 with Chapter3.
Qed.

Example S_seq_3_2_test :
  S [] (seq (e_s v) s) [] s.
Proof.
  apply S_seq_3_2.
  eauto 10 with Chapter3.
Qed.

Example S_return_3_3_test :
 S [] (seq (retn v) s) [] (retn v).
Proof.
  apply S_return_3_3.
  eauto 10 with Chapter3.
Qed.

Example S_if0_3_4_test :
 S [] (if_s (i_e (i_i 0)) s1 s2)
   [] s1.
Proof.
  apply S_if0_3_4.
Qed.

Example S_if_ne_0_3_5_test :
  S [] (if_s vi1 s1 s2) [] s2.
Proof.
  apply S_if_ne_0_3_5.
  eauto 10 with Chapter3.
Qed.

Example S_while_3_6_test :
 S [] (while e s)
   [] (if_s e (seq s (while e s)) (e_s (i_e (i_i 0)))).
Proof.
  apply S_while_3_6.
Qed.

(* Bug 8, just naming in two constructors. *)

(* TODO Questionable test? *)
Example S_open_3_7_test :
  S [] (open (pack tau' v (etype aliases alpha k tau)) alpha x s)
    [] (letx x' v (subst_St s tau alpha)).
Proof.
  apply S_open_3_7.
  eauto 10 with Chapter3.
Qed.

(* TODO Questionable test? *)
Definition etau := (etype aliases alpha A tau).
Definition H38 := [(x,(pack etau v etau))].
Example pack_value:
  (getH H38 x) = Some v' ->
  Value v'.
Proof.
  intros H.
  compute in H.
  compute.
  eauto 10 with Chapter3.
Qed.

(* Okay so H evaluates right and is a value. *)
(* Bug 20, State unbound. *)
(* Bug 21, Pack not in Values! *)
(* Is this a bug with get or is this just not syntax directed without
  some Tacticals. At least need Tactical for adding nil. *)
(* Bug 22, why is this not syntax directed ? Automation bug really. *)
Example S_openstar_3_8_test :
  S H38 (openstar (p_e x []) alpha x' s)
    H38 (letx x'  (amp (p_e x ([] ++ [u_pe])))
                          (subst_St s tau alpha)).
Proof.
  apply S_openstar_3_8 with
  (tau':= etau) (v:= v) (q:= aliases) (k:=A)
  (v':= (pack etau v etau));
  eauto 10 with Chapter3.
Qed.

Example S_exp_3_9_1_test :
  S [] (e_s e) [] (e_s e').
Proof.
  apply S_exp_3_9_1.
  eauto 10 with Chapter3.
Qed.

Example S_ret_3_9_2_test :
  S [] (retn e) [] (retn e').
Proof.
  apply S_ret_3_9_2.
  eauto 10 with Chapter3.
Qed.

Example S_if_3_9_3_test :
  S [] (if_s e s1 s2) [] (if_s e' s1 s2).
Proof.
  apply S_if_3_9_3.
  eauto 10 with Chapter3.
Qed.

Example S_letx_3_9_4_test :
  S [] (letx x e s) [] (letx x e' s).
Proof.
  apply S_letx_3_9_4.
  eauto 10 with Chapter3.
Qed.

(* ? TODO e not a value.*)
Example S_open_3_9_5_test :
  S [] (open e alpha x s) [] (open e' alpha x s).
Proof.
  apply S_open_3_9_5.
  eauto 10 with Chapter3.
Qed.

(* Bug 9 - extra tvar. *)
(* Bug 10. If returning the wrong clause. *)
Example S_seq_3_10_test :
  S [] (seq s s2) [] (seq s' s2).
Proof.
  apply S_seq_3_10.
  eauto 10 with Chapter3.
Qed.

Example S_openstar_3_11_test :
 S [] (openstar (dot (p_e x []) (i_i 0))    alpha x s)
   [] (openstar      (p_e x [i_pe (i_i 0)]) alpha x s).
Proof.
  apply S_openstar_3_11.
  eauto 10 with Chapter3.
  apply L_xpi_3_1.
Qed.

(* Test R. *)

Example R_get_3_1_test:
  R [(x,v)]  (e_s (p_e x nil))
    [(x,v)]  (e_s v).
Proof.
  (* I don't care because eauto can find this v'. *)
  apply R_get_3_1 with (v':=v);
  eauto 10 with Chapter3.
Qed.

(* Dan Bug,  Set rule 1 should be set(v',[],v,v'') ? *)
Definition h32xv   := ([] ++ [(x,v')]  ++ []).
Definition h32xv'' := ([] ++ [(x,v'')] ++ []).
(* Definition h32xv'' := [(x,v'')]. *)
Example R_read_heap_3_2_test:
  R h32xv   (e_s (assign (p_e x []) (i_e (i_i 3))))
    h32xv'' (e_s (i_e (i_i 3))).
Proof.
  apply R_assign_3_2;
  eauto 10 with Chapter3.
Qed.

Example R_star_3_3_test:
  R hxv (e_s (star (amp (p_e x nil))))
    hxv (e_s (p_e x nil)).
Proof.
  apply R_star_3_3.
Qed.

Example R_dot_3_4_0_test:
  R [] (e_s (dot (cpair v0 v1) (i_i 0)))
    [] (e_s v0).
Proof.
  apply R_dot_3_4_0.
Qed.

Example R_dot_3_4_1_test:
  R [] (e_s (dot (cpair v0 v1) (i_i 1)))
    [] (e_s v1).
Proof.
  apply R_dot_3_4_1.
Qed.

Example R_appl_3_5_test:
  R [] (e_s (appl (f_e (dfun tau x tau' s)) v))
    [] (e_s (call (letx x v s))).
Proof.
  apply R_appl_3_5.
  eauto 10 with Chapter3.
Qed.

Example R_call_3_6_test:
  R [] (e_s (call (retn v)))
    [] (e_s v).
Proof.
  apply R_call_3_6.
  eauto 10 with Chapter3.
Qed.

Example R_inst_3_7_test:
  R [] (e_s (inst (f_e (ufun alpha k f)) tau))
    [] (e_s (f_e (subst_F f tau alpha))).
Proof.
  apply R_inst_3_7.
Qed.

(* Bug 12, R instead of S in the precondition. *)

Example R_call_3_8_test:
  R [] (e_s (call s)) [] (e_s (call s')).
Proof.
  apply R_call_3_8.
  eauto 10 with Chapter3.
Qed.

(* Originally I had an invalid left expression here. *)

Example R_amp_3_9_1_test:
  R hxv (e_s (amp (dot (p_e x nil) (i_i 0))))
    hxv (e_s (amp (p_e x [i_pe (i_i 0)]))).
Proof.
  apply R_amp_3_9_1.
  apply L_xpi_3_1.
Qed.

Example R_assign_3_9_2_test:
  R [] (e_s (assign (star (amp (p_e x nil))) v0))
    [] (e_s (assign (p_e x nil) v0)).
Proof.
  apply R_assign_3_9_2.
  eauto 10 with Chapter3.
Qed.

(* These would be nice for test but I can't make a statement into an expression. Even an If. *)

(* TODO It would be better if I went from h to h' here. *)
Example R_star_3_10_1_test:
  R [] (e_s (star (star (amp (p_e x [])))))
    [] (e_s (star (p_e x []))).
Proof.
  apply R_star_3_10_1.
  eauto 10 with Chapter3.
Qed.

Example R_dot_3_10_2_test:
  R [] (e_s (dot (star (amp (p_e x [])))  (i_i 0)))
    [] (e_s (dot (p_e x [])               (i_i 0))).
Proof.
  apply R_dot_3_10_2.
  eauto 10 with Chapter3.
Qed.

(* TODO I should really make these change h to h' under e's evaluation. *)

Example Bug14_e_e':
 ~ R [] (e_s (i_e (i_i 0)))
     [] (e_s (i_e (i_i 1))).
Proof.
  compute.
  intros H.
  inversion H.
Qed.

(* Bug 17, L's instead of R's on precondition to 3.10 rules. *)
Example R_assign_3_10_3_test:
  R h (e_s (assign (p_e x pdot) e))
    h (e_s (assign (p_e x pdot) e')).
Proof.
  apply R_assign_3_10_3.
  eauto 10 with Chapter3.
Qed.

Example R_inst_3_10_4_test:
  R h  (e_s (inst e tau))
    h (e_s (inst e' tau)).
Proof.
  apply R_inst_3_10_4.
  eauto 10 with Chapter3.
Qed.

Example R_pack_3_10_5_test:
  R h  (e_s (pack tau' e  (etype nowitnesschange alpha k tau)))
    h  (e_s (pack tau' e' (etype nowitnesschange alpha k tau))).
Proof.
  apply R_pack_3_10_5.
  eauto 10 with Chapter3.
Qed.

(* Bug 18, Tau unquantified in three rules. *)
Example R_cpair_3_10_6_test:
  R h (e_s (cpair e e2))
    h (e_s (cpair e' e2)).
Proof.
  apply R_cpair_3_10_6.
  eauto 10 with Chapter3.
Qed.

Example R_cpair_3_10_7_test:
  R h (e_s (cpair v e))
    h (e_s (cpair v e')).
Proof.
  apply R_cpair_3_10_7;
  eauto 10 with Chapter3.
Qed.

Example R_cpair_3_10_8_test:
  R h (e_s (cpair e e2))
    h (e_s (cpair e' e2)).
Proof.
  apply R_cpair_3_10_8.
  eauto 10 with Chapter3.
Qed.

Example R_appl_3_10_9_test:
  R h (e_s (appl e e2))
    h (e_s (appl e' e2)).
Proof.
  apply R_appl_3_10_9.
  eauto 10 with Chapter3.
Qed.

Example R_appl_3_10_10_test:
  R h (e_s (appl v e))
    h (e_s (appl v e')).
Proof.
  apply R_appl_3_10_10;
  eauto 10 with Chapter3.
Qed.

(* Test L *)

Example L_xpi_3_1_test:
  L h (e_s (dot (p_e x nil) (i_i Z0)))
    h (e_s (p_e x [(i_pe (i_i Z0))])).
Proof.
 apply L_xpi_3_1.
Qed.

Example L_staramp_3_2_test:
  L h (e_s (star (amp (p_e x nil)))) h (e_s (p_e x nil)).
Proof.
 apply L_staramp_3_2.
Qed.

(* Bug 11, h should have been h'. *)
(* Bug 14, extra e in quantification. *)
Example L_star_3_3_test:
  L h (e_s (star e)) h (e_s (star e')) .
Proof.
 eapply L_star_3_3.
 eauto 10 with Chapter3.
Qed.

(* Bug 19, extra quantified variable. *)
Example L_ei_3_4_test:
  L [] (e_s (dot (dot (p_e x []) (i_i 0)) (i_i 0)))
    [] (e_s (dot (p_e x ([] ++ [i_pe (i_i 0)])) (i_i 0))).
Proof.
 apply L_ei_3_4.
 eauto 10 with Chapter3.
Qed.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import String.
Require Import List.
Require Import Compare_dec.
Require Import Program.
Require Import Utils.
Require Import DataSystem.
Require Import NRA.

Section TNRA.
  (** Typing for NRA *)
  Section typ.
    Context {m:basic_model}.
    Context (τconstants:tbindings).

    Inductive nra_type : nra -> rtype -> rtype -> Prop :=
    | type_NRAGetConstant {τin τout} s :
        tdot τconstants s = Some τout ->
        nra_type (NRAGetConstant s) τin τout
    | type_NRAID {τ} :
        nra_type NRAID τ τ
    | type_NRAConst {τin τout} c :
        data_type (normalize_data brand_relation_brands c) τout ->
        nra_type (NRAConst c) τin τout
    | type_NRABinop {τin τ₁ τ₂ τout} b op1 op2 :
        (* b : (τ₁,τ₂) -> τout
           op₁ : τin -> τ₁
           op₂ : τin -> τ₂
           ==========================
           b (op₁,op₂) : τin -> τout *)
        binary_op_type b τ₁ τ₂ τout ->
        nra_type op1 τin τ₁ ->
        nra_type op2 τin τ₂ ->
        nra_type (NRABinop b op1 op2) τin τout
    | type_NRAUnop {τin τ τout} u op :
        unary_op_type u τ τout ->
        nra_type op τin τ ->
        nra_type (NRAUnop u op) τin τout
    | type_NRAMap {τin τ₁ τ₂} op1 op2 :
        nra_type op1 τ₁ τ₂ ->
        nra_type op2 τin (Coll τ₁) ->
        nra_type (NRAMap op1 op2) τin (Coll τ₂)
    | type_NRAMapProduct {τin τ₁ τ₂ τ₃} op1 op2 pf1 pf2 pf3 :
        nra_type op1 (Rec Closed τ₁ pf1) (Coll (Rec Closed τ₂ pf2)) ->
        nra_type op2 τin (Coll (Rec Closed τ₁ pf1)) ->
        rec_concat_sort τ₁ τ₂ = τ₃ ->
        nra_type (NRAMapProduct op1 op2) τin (Coll (Rec Closed τ₃ pf3))
    | type_NRAProduct {τin τ₁ τ₂ τ₃} op1 op2 pf1 pf2 pf3 :
        nra_type op1 τin (Coll (Rec Closed τ₁ pf1)) ->
        nra_type op2 τin (Coll (Rec Closed τ₂ pf2)) ->
        rec_concat_sort τ₁ τ₂ = τ₃ ->
        nra_type (NRAProduct op1 op2) τin (Coll (Rec Closed τ₃ pf3))
    | type_NRASelect {τin τ} op1 op2 :
        nra_type op1 τ Bool ->
        nra_type op2 τin (Coll τ) ->
        nra_type (NRASelect op1 op2) τin (Coll τ)
    | type_NRADefault {τin τ} op1 op2 :
        nra_type op1 τin (Coll τ) ->
        nra_type op2 τin (Coll τ) ->
        nra_type (NRADefault op1 op2) τin (Coll τ)
    | type_NRAEither {τl τr τout} opl opr :
        nra_type opl τl τout ->
        nra_type opr τr τout ->
        nra_type (NRAEither opl opr) (Either τl τr) τout
    | type_NRAEitherConcat {τin rll pfl rlr pfr rlo pfo lo ro} op1 op2 pflo pfro :
        nra_type op1 τin (Either (Rec Closed rll pfl) (Rec Closed rlr pfr)) ->
        nra_type op2 τin (Rec Closed rlo pfo) ->
        rec_concat_sort rll rlo = lo ->
        rec_concat_sort rlr rlo = ro ->
        nra_type (NRAEitherConcat op1 op2) τin (Either (Rec Closed lo pflo) (Rec Closed ro pfro))
    | type_NRAApp {τin τ1 τ2} op1 op2 :
        nra_type op2 τin τ1 ->
        nra_type op1 τ1 τ2 ->
        nra_type (NRAApp op1 op2) τin τ2.

  End typ.

  Notation "Op ▷ A >=> B ⊣ C" := (nra_type C Op A B) (at level 70) (* \Vdash *).

  (** Type lemmas for individual algebraic expressions *)
  Context {m:basic_model}.

  Lemma lift_map_typed {τc} {τ₁ τ₂ : rtype} c (op1 : nra) (dl : list data) :
    (bindings_type c τc) ->
    (Forall (fun d : data => data_type d τ₁) dl) ->
    (op1 ▷ τ₁ >=> τ₂ ⊣ τc) ->
    (forall d : data,
        data_type d τ₁ -> exists x : data, brand_relation_brands ⊢ op1 @ₐ d ⊣ c = Some x /\ data_type x τ₂) ->
    exists x : list data, (lift_map (nra_eval brand_relation_brands c op1) dl = Some x) /\ data_type (dcoll x) (Coll τ₂).
  Proof.
    intros Hcenv.
    intros.
    induction dl; simpl; intros.
    - exists (@nil data); split; [reflexivity|apply dtcoll;apply Forall_nil].
    - inversion H; clear H.
      elim (H1 a H4); intros.
      elim H; intros; clear H.
      rewrite H6; clear H6.
      specialize (IHdl H5); clear H5.
      elim IHdl; intros; clear IHdl.
      elim H; intros; clear H.
      dependent induction H6.
      rewrite H5.
      exists (x0 :: x1).
      split; try reflexivity.
      apply dtcoll.
      apply Forall_cons; try assumption.
      assert (r = τ₂) by (apply rtype_fequal; assumption).
      rewrite <- H2; assumption.
  Qed.

  Lemma recover_rec k d r τ pf:
    data_type d r ->
    ` r =
    Rec₀ k
      (map
         (fun x : string * {τ₀ : rtype₀ | wf_rtype₀ τ₀ = true} =>
            (fst x, ` (snd x))) τ) ->
    data_type d (Rec k τ pf).
  Proof.
    intros.
    assert (Rec k τ pf = r).
    unfold Rec.
    apply rtype_fequal.
    rewrite H0.
    reflexivity.
    rewrite H1; assumption.
  Qed.

  Lemma recover_rec_forall k l r τ pf:
    Forall (fun d : data => data_type d r) l ->
    ` r =
    Rec₀ k
      (map
         (fun x : string * {τ₀ : rtype₀ | wf_rtype₀ τ₀ = true} =>
            (fst x, ` (snd x))) τ) ->
    Forall (fun d : data => data_type d (Rec k τ pf)) l.
  Proof.
    intros; rewrite Forall_forall in *; intros.
    specialize (H x H1).
    apply (recover_rec k x r τ pf); assumption.
  Qed.

  Lemma omap_concat_typed
        (τ₁ τ₂ τ₃: list (string * rtype)) (dl2: list data)
        (x : list (string * data)) pf1 pf2 pf3:
    (forall x : data, In x dl2 -> data_type x (Rec Closed τ₂ pf2)) ->
    rec_concat_sort τ₁ τ₂ = τ₃ ->
    data_type (drec x) (Rec Closed τ₁ pf1) ->
    (exists y : list data,
       lift_map (fun x1 : data => orecconcat (drec x) x1) dl2
       = Some y /\ data_type (dcoll y) (Coll (Rec Closed τ₃ pf3))).
  Proof.
    intros; induction dl2; simpl.
    exists (@nil data); split; [reflexivity|apply dtcoll; apply Forall_nil].
    simpl in H.
    assert (data_type a (Rec Closed τ₂ pf2))
      by (apply (H a); left; reflexivity).
    destruct (data_type_Rec_inv H2); subst.
    apply dtrec_closed_inv in H2.
    assert (H':forall x : data, In x dl2 -> data_type x (Rec Closed τ₂ pf2)) by
        (eapply forall_in_weaken; eassumption).
    specialize (IHdl2 H'); clear H'.
    destruct IHdl2 as [? [??]].
    revert H0; elim (lift_map (fun x2 : data => orecconcat (drec x) x2) dl2); intros; try discriminate.
    inversion H0; subst; clear H0.
    unfold lift.
    induction dl2.
    - simpl.
      exists (drec (rec_concat_sort x x0) :: nil); split; try reflexivity.
      apply dtcoll. rewrite Forall_forall in *; intros.
      simpl in H0. intuition.
      destruct x2; try congruence. inversion H4; subst; clear H4.
      apply dtrec_full.
      apply rec_concat_with_drec_concat_well_typed; try assumption.
      apply dtrec_closed_inv in H1. trivial.
    - simpl in *.
      generalize (H a). intuition.
      destruct (data_type_Rec_inv H5); subst.
      apply dtrec_closed_inv in H5.
      destruct IHdl2; [intuition | ].
      unfold lift.
      destruct H0 as [eq1 dt1].
      case_option_in eq1; try discriminate.
      eexists; split; [reflexivity | ].
      constructor.
      inversion eq1; subst; clear eq1.
      inversion dt1; subst.
      generalize (recover_rec_forall _ _ _ _ pf3 H8 H7).
      inversion 1; simpl; subst.
      constructor; simpl; trivial.
      constructor; trivial.
      apply dtrec_full.
      apply dtrec_closed_inv in H1.
      apply rec_sort_Forall2.
      + repeat rewrite domain_app.
        rewrite (sorted_forall_same_domain H1).
        rewrite (sorted_forall_same_domain H5). trivial.
      + apply Forall2_app; trivial.
  Qed.

  Lemma oproduct_typed {τ₁ τ₂ τ₃: list (string * rtype)} (dl dl0: list data) pf1 pf2 pf3:
    Forall (fun d : data => data_type d (Rec Closed τ₂ pf2)) dl0 ->
    Forall (fun d : data => data_type d (Rec Closed τ₁ pf1)) dl ->
    rec_concat_sort τ₁ τ₂ = τ₃ ->
    exists x : list data, (oproduct dl dl0 = Some x) /\ data_type (dcoll x) (Coll (Rec Closed τ₃ pf3)).
  Proof.
    intros; rewrite Forall_forall in *.
    induction dl; simpl in *.
    - exists (@nil data); split; [reflexivity| apply dtcoll; apply Forall_nil].
    - assert (exists r, a = drec r /\ data_type (drec r) (Rec Closed τ₁ pf1)).
      + clear IHdl H; assert (data_type a (Rec Closed τ₁ pf1))
                    by (specialize (H0 a); apply H0; left; reflexivity).
         destruct (data_type_Rec_inv H); subst.
         apply dtrec_closed_inv in H.
         eexists; split; [reflexivity | ].
         apply dtrec_full; trivial.
      + destruct H2 as [? [??]]; subst.
      assert (forall x : data, In x dl -> data_type x (Rec Closed τ₁ pf1))
        by (apply forall_in_weaken with (P := (fun x0 => (drec x) = x0)); assumption).
      specialize (IHdl H1).
      destruct IHdl as [? [??]].
      unfold oproduct.
      simpl.
      assert (exists y, (omap_concat (drec x) dl0) = Some y /\ (data_type  (dcoll y) (Coll (Rec Closed  (rec_concat_sort τ₁ τ₂) pf3))))
        by (eapply omap_concat_typed; eauto).
      destruct H5 as [? [??]].
      generalize (oproduct_cons _ _ _ _ _ H2 H5).
      unfold oproduct; simpl.
      rewrite H5. intros eqq.
      exists (x1 ++ x0).
      split; trivial.
      inversion H6; subst.
      inversion H4; subst.
      generalize (recover_rec_forall _ _ _ _ pf3 H9 H8); intros.
      generalize (recover_rec_forall _ _ _ _ pf3 H11 H10); intros.
      constructor. apply Forall_app; trivial.
  Qed.

  Lemma data_type_concat l1 l2 τ:
    data_type (dcoll l1) (Coll τ) ->
    data_type (dcoll l2) (Coll τ) ->
    data_type (dcoll (l1 ++ l2)) (Coll τ).
  Proof.
    intros.
    dependent induction H.
    dependent induction H0.
    apply dtcoll.
    apply Forall_app; rewrite Forall_forall in *;
    assert (r = τ) by (apply rtype_fequal; assumption);
    assert (r0 = τ) by (apply rtype_fequal; assumption);
    rewrite H1 in H; rewrite H2 in H0; assumption.
  Qed.

  Lemma omap_product_typed {τc} {τ₁ τ₂ τ₃ : list (string * rtype)} (op1 : nra) c (dl: list data) pf1 pf2 pf3:
    bindings_type c τc ->
    rec_concat_sort τ₁ τ₂ = τ₃ ->
    Forall (fun d : data => data_type d (Rec Closed τ₁ pf1)) dl ->
    (op1 ▷ Rec Closed τ₁ pf1 >=> Coll (Rec Closed τ₂ pf2) ⊣ τc) ->
    (forall d : data,
                data_type d (Rec Closed τ₁ pf1) ->
                exists x : data,
                   brand_relation_brands ⊢ op1 @ₐ d ⊣ c = Some x /\ data_type x (Coll (Rec Closed τ₂ pf2))) ->
    exists x : list data, (omap_product (nra_eval brand_relation_brands c op1) dl = Some x) /\ data_type (dcoll x) (Coll (Rec Closed τ₃ pf3)).
  Proof.
    intros Hcenv.
    intros; rewrite Forall_forall in *.
    induction dl; simpl in *; unfold omap_product in *; simpl.
    exists (@nil data); split; [reflexivity|apply dtcoll; apply Forall_nil].
    assert (forall x : data, In x dl -> data_type x (Rec Closed τ₁ pf1))
      by (apply forall_in_weaken with (P := (fun x => a = x)); assumption).
    elim (IHdl H3); intros; elim H4; intros; clear IHdl H4.
    assert (data_type a (Rec Closed τ₁ pf1))
      by (apply (H0 a); left; reflexivity).
    rewrite H5; clear H5.
    destruct (data_type_Rec_inv H4); subst.
    apply dtrec_closed_inv in H4.
    assert (data_type (drec x0) (Rec Closed τ₁ pf1))
      by (apply (H0 (drec x0)); left; reflexivity).
    unfold oncoll_map_concat.
    elim (H2 (drec x0) H); intros; clear H2.
    elim H5; intros; clear H5.
    rewrite H2; clear H2.
    dtype_inverter.
    rename x1 into dl0.
    apply Col_inv in H7.
    assert (exists y, (omap_concat (drec x0) dl0) = Some y /\ (data_type (dcoll y) (Coll (Rec Closed (rec_concat_sort τ₁ τ₂) pf3)))).
    unfold omap_concat.
    eapply (omap_concat_typed τ₁ τ₂ (rec_concat_sort τ₁ τ₂)); eauto.
    apply Forall_forall; eauto.

    destruct H2 as [?[??]].
    rewrite H2; clear H2.
    simpl.
    exists (x1++x).
    split. reflexivity.
    apply data_type_concat; assumption.
  Qed.

  Lemma omap_product_typed2 {τc} {τ₁ τ₂ τ₃ : list (string * rtype)} τin (op1 : nra) c y (dl: list data) pf1 pf2 pf3:
    bindings_type c τc ->
    rec_concat_sort τ₁ τ₂ = τ₃ ->
    Forall (fun d : data => data_type d (Rec Closed τ₁ pf1)) dl ->
    (op1 ▷ τin >=> Coll (Rec Closed τ₂ pf2) ⊣ τc) ->
    (forall d : data,
                data_type d (Rec Closed τ₁ pf1) ->
                exists x : data,
                   brand_relation_brands ⊢ op1 @ₐ y  ⊣ c = Some x /\ data_type x (Coll (Rec Closed τ₂ pf2))) ->
    exists x : list data, (omap_product (fun z =>  brand_relation_brands ⊢ op1@ₐ y ⊣ c) dl = Some x) /\ data_type (dcoll x) (Coll (Rec Closed τ₃ pf3)).
  Proof.
    intros Hcenv.
    intros; rewrite Forall_forall in *.
    induction dl; simpl in *; unfold omap_product in *; simpl.
    exists (@nil data); split; [reflexivity|apply dtcoll; apply Forall_nil].
    assert (forall x : data, In x dl -> data_type x (Rec Closed τ₁ pf1))
      by (apply forall_in_weaken with (P := (fun x => a = x)); assumption).
    elim (IHdl H3); intros; elim H4; intros; clear IHdl H4.
    assert (data_type a (Rec Closed τ₁ pf1))
      by (apply (H0 a); left; reflexivity).
    rewrite H5; clear H5.
    destruct (data_type_Rec_inv H4); subst.
    apply dtrec_closed_inv in H4.
    rename x0 into dl0.
    assert (data_type (drec dl0) (Rec Closed τ₁ pf1))
      by (apply (H0 (drec dl0)); left; reflexivity).
    unfold oncoll_map_concat.
    elim (H2 (drec dl0) H); intros; clear H2.
    elim H5; intros; clear H5.
    rewrite H2; clear H2.
    dtype_inverter.
    rename x0 into dl1.
    apply Col_inv in H7.
    assert (exists y, (omap_concat (drec dl0) dl1) = Some y /\ (data_type  (dcoll y) (Coll (Rec Closed (rec_concat_sort τ₁ τ₂) pf3)))).
    unfold omap_concat.
    apply (omap_concat_typed τ₁ τ₂ (rec_concat_sort τ₁ τ₂) dl1 dl0 pf1 pf2 pf3); trivial.
    intros.
    rewrite Forall_forall in H7; specialize (H7 _ H2); trivial.
    destruct H2 as [?[eqq ?]].
    rewrite eqq; clear eqq. simpl.
    exists (x0++x).
    split. reflexivity.
    apply data_type_concat; assumption.
  Qed.

  (** Main typing soundness theorem for the NRA *)

  Theorem typed_nra_yields_typed_data {τc} {τin τout} cenv (d:data) (op:nra):
    bindings_type cenv τc ->
    (data_type d τin) -> (op ▷ τin >=> τout ⊣ τc) ->
    (exists x, brand_relation_brands ⊢ op @ₐ d ⊣ cenv = Some x /\ (data_type x τout)).
  Proof.
    intros Hcenv.
    intros.
    revert d H.
    nra_cases (dependent induction H0) Case; simpl; intros.
    - Case "NRAGetConstant"%string.
      unfold tdot in *.
      unfold edot in *.
      destruct (Forall2_lookupr_some Hcenv H) as [? [eqq1 eqq2]].
      rewrite eqq1.
      eauto.
    - Case "NRAID"%string.
      exists d; split; [reflexivity|assumption].
    - Case "NRAConst"%string.
      exists (normalize_data brand_relation_brands c); split; try reflexivity.
      assumption.
    - Case "NRABinop"%string.
      elim (IHnra_type1 d H0); elim (IHnra_type2 d H0); intros.
      elim H1; elim H2; intros; clear H1 H2.
      rewrite H3; simpl.
      rewrite H5; simpl.
      apply (typed_binary_op_yields_typed_data x0 x b H4 H6); assumption.
    - Case "NRAUnop"%string.
      elim (IHnra_type d H1); intros.
      elim H2; intros; clear H2.
      rewrite H3.
      apply (typed_unary_op_yields_typed_data x u H4); assumption.
    - Case "NRAMap"%string.
      elim (IHnra_type2 d H); intros; clear H IHnra_type2.
      elim H0; intros; clear H0.
      rewrite H; clear H.
      invcs H1; rtype_equalizer.
      subst.
      assert (exists x : list data, (lift_map (nra_eval brand_relation_brands cenv op1) dl = Some x)
                                    /\ data_type (dcoll x) (Coll τ₂)).
      apply (lift_map_typed cenv op1 dl Hcenv H2); assumption.
      destruct H as [? [eqq dt]].
      autorewrite with alg; rewrite eqq.
      exists (dcoll x); split; [reflexivity|assumption].
    - Case "NRAMapProduct"%string.
      elim (IHnra_type2 d H0); intros; clear IHnra_type2 H0.
      elim H1; intros; clear H1.
      destruct (data_type_Col_inv H2); subst.
      inversion H2; subst.
      generalize (recover_rec_forall _ _ _ _ pf1 H3 H1); intros.

      rewrite H0; clear H0. simpl.

      assert (exists x : list data, (omap_product (nra_eval brand_relation_brands cenv op1) x0 = Some x) /\ data_type (dcoll x) (Coll (Rec Closed (rec_concat_sort τ₁ τ₂) pf3))).
      apply (omap_product_typed op1 cenv x0 pf1 pf2 pf3 Hcenv); try assumption; try reflexivity.
      elim H0; intros; clear H0.
      elim H4; intros; clear H4.
      autorewrite with alg; rewrite H0. simpl.
      exists (dcoll x); split; [reflexivity|assumption].
    - Case "NRAProduct"%string.
      elim (IHnra_type1 d H0); intros; clear IHnra_type1.
      elim H1; intros; clear H1.
      rewrite H2; clear H2.
      invcs H3.
      assert (exists x : list data, (omap_product (fun _ : data =>  brand_relation_brands ⊢ op2 @ₐ d ⊣ cenv) dl = Some x) /\ data_type (dcoll x) (Coll (Rec Closed (rec_concat_sort τ₁ τ₂) pf3))).
      apply (omap_product_typed2 τin op2 cenv d dl pf1 pf2 pf3 Hcenv); try assumption; try reflexivity.
      apply (recover_rec_forall _ _ _ _ pf1 H4); trivial.
      destruct (IHnra_type2 d H0) as [? [eqq dt]]; intros.
      rewrite eqq; clear eqq.
      exists x; split; [reflexivity|assumption].
      destruct H as [? [eqq dt]].
      simpl; rewrite eqq; exists (dcoll x); simpl.
      split; [reflexivity|assumption].
    - Case "NRASelect"%string.
      elim (IHnra_type2 d H); intros; clear IHnra_type2.
      elim H0; intros; clear H0.
      rewrite H1; clear H1 H0_0.
      invcs H2; rtype_equalizer.
      subst.
      assert (exists c2,
          (lift_filter
             (fun x' : data =>
              match brand_relation_brands  ⊢ op1 @ₐ x' ⊣ cenv with
              | Some (dbool b) => Some b
              | _ => None
              end) dl) = Some c2 /\ Forall (fun d : data => data_type d τ) c2).
      + induction dl.
        * exists (@nil data). split. reflexivity. apply Forall_nil.
        * rewrite Forall_forall in *; intros.
          simpl in H3.
          assert (forall x : data, In x dl -> data_type x τ)
                 by intuition.
          assert (data_type a τ)
            by (apply (H3 a); left; reflexivity).
          destruct (IHnra_type1 a H1) as [? [eqq dt]]; intros.
          simpl.
          rewrite eqq.
          dtype_inverter.
          destruct (IHdl H0) as [? [eqq2 dt2]].
          rewrite eqq2.
          { destruct x0.
            - eexists; split; try reflexivity.
              eauto.
            - eexists; split; try reflexivity.
              eauto.
          }
      + simpl.
        destruct H0 as [? [eqq dt]].
        rewrite eqq.
        simpl.
        eexists; split; try reflexivity.
        constructor; trivial.
    - Case "NRADefault"%string.
      elim (IHnra_type1 d H); elim (IHnra_type2 d H); intros.
      elim H0; elim H1; intros; clear H0 H1 H.
      rewrite H2. rewrite H4. clear H2 H4.
      simpl.
      invcs H3.
      invcs H5.
      rtype_equalizer.
      subst.
      destruct dl.
      + eexists; split; try reflexivity.
        constructor; trivial.
      + eexists; split; try reflexivity.
        constructor; trivial.
    - Case "NRAEither"%string.
      inversion H; rtype_equalizer.
      + subst; eauto.
      + subst; eauto.
    - Case "NRAEitherConcat"%string.
      destruct (IHnra_type1 _ H1) as [x[xeval xtyp]].
      destruct (IHnra_type2 _ H1) as [y[yeval ytyp]].
      rewrite xeval, yeval.
      destruct (data_type_Rec_inv ytyp); subst.
      destruct (data_type_Either_inv xtyp) as [[dd[? ddtyp]]|[dd[? ddtyp]]]; subst.
      + destruct (data_type_Rec_inv ddtyp); subst.
         eexists; split; try reflexivity.
         econstructor.
         eapply dtrec_rec_concat_sort; eauto.
      + destruct (data_type_Rec_inv ddtyp); subst.
         eexists; split; try reflexivity.
         econstructor.
         eapply dtrec_rec_concat_sort; eauto.
    - Case "NRAApp"%string.
      elim (IHnra_type1 d H); intros.
      elim H0; intros; clear H0 H.
      rewrite H1; simpl.
      elim (IHnra_type2 x H2); intros.
      elim H; intros; clear H.
      rewrite H0; simpl.
      exists x0;split;[reflexivity|assumption].
  Qed.

  (* Evaluation into single value for typed algebra *)

  (** Corrolaries of the main type soudness theorem *)

  Definition typed_nra_total {τc} {τin τout} (op:nra) (HOpT: op ▷ τin >=> τout ⊣ τc) c (d:data)
    (dt_c: bindings_type c τc) :
    (data_type d τin) -> { x:data | data_type x τout }.
  Proof.
    intros HdT.
    generalize (typed_nra_yields_typed_data c d op dt_c HdT HOpT).
    intros.
    destruct (brand_relation_brands ⊢ op@ₐd ⊣ c).
    assert (data_type d0 τout).
    - inversion H. inversion H0. inversion H1. trivial.
    - exists d0. trivial.
    - cut False. intuition. inversion H.
      destruct H0. inversion H0.
  Defined.

  Lemma typed_nra_total_eq_matches_eval {τc} {τin τout} (op:nra) (HOpT: op ▷ τin >=> τout ⊣ τc) c (d:data)
    (dt_c: bindings_type c τc)
        (pf: data_type d τin) :
    (brand_relation_brands ⊢ op @ₐd ⊣ c) = Some (proj1_sig (typed_nra_total op HOpT c d dt_c pf)).
  Proof.
    unfold typed_nra_total.
    generalize (typed_nra_yields_typed_data c d op dt_c pf HOpT); intros.
    destruct e; simpl.
    destruct a; simpl.
    rewrite e.
    reflexivity.
  Qed.

  Definition tnra_eval {τc} {τin τout} (op:nra) (HOpT: op ▷ τin >=> τout ⊣ τc) c (d:data) (dt_c: bindings_type c τc):
    (data_type d τin) -> data.
  Proof.
    intros HdT.
    destruct (typed_nra_total op HOpT c d dt_c HdT).
    exact x.
  Defined.

End TNRA.

(* Typed algebraic plan *)
Notation "Op ▷ A >=> B ⊣ C" := (nra_type C Op A B) (at level 70): nra_scope.


(** * cwp on cotrees. *)

Set Implicit Arguments.

From Coq Require Import
  Basics
  QArith
.

Local Open Scope program_scope.

From zar Require Import
  aCPO
  cotree
  cpGCL
  cpo
  misc
  order
  eR
  tree
.

Create HintDb cocwp.

Definition cotree_loop_F {A B} (e : A -> bool) (g : A -> cotree bool (unit + A))
  (f : A -> cotree bool (unit + B))
  : (A -> cotree bool (unit + B)) -> A -> cotree bool (unit + B) :=
  fun k x => if e x then
            cotree_bind (g x) (fun y => match y with
                                     | inl _ => coleaf (inl tt)
                                     | inr z => cotau (k z)
                                     end)
          else
            f x.

(** Used for building cotrees corresponding to fix nodes in CF trees. *)
Definition cotree_loop_approx {A B} (x : A) (e : A -> bool)
  (g : A -> cotree bool (unit + A))
  (f : A -> cotree bool (unit + B)) (n : nat)
  : cotree bool (unit + B) :=
  iter_n (cotree_loop_F e g f) (const cobot) n x.

(** Designed to match the itree construction. *)
Definition cotree_loop {A B} (e : A -> bool) (g : A -> cotree bool (unit + A))
  (f : A -> cotree bool (unit + B)) (x : A) : cotree bool (unit + B) :=
  cotree_iter (fun y => if e y then
                       cotree_bind (g y) (fun lr => match lr with
                                                 | inl _ => coleaf (inr (inl tt))
                                                 | inr z => coleaf (inl z)
                                                 end)
                     else cotree_map inr (f y)) x.

(** Old version (most proofs below are wrt this one). *)
Fixpoint to_cotree'' {A} (t : tree A) : cotree bool (unit + A) :=
  match t with
  | Leaf s => coleaf (inr s)
  | Fail _ => coleaf (inl tt)
  | Choice _ k => conode (to_cotree'' ∘ k)
  | Fix st G g k => sup (cotree_loop_approx st G (to_cotree'' ∘ g) (to_cotree'' ∘ k))
  end.

(** cotree_iter version (matches itree construction exactly. Would
    prefer to only use this version but the above one was defined
    first. Could probably remove it and fix the proofs fairly easily. *)
Fixpoint to_cotree_open {A} (t : tree A) : cotree bool (unit + A) :=
  match t with
  | Leaf s => coleaf (inr s)
  | Fail _ => coleaf (inl tt)
  | Choice _ k => conode (to_cotree_open ∘ k)
  | Fix st G g k => cotree_loop G (to_cotree_open ∘ g) (to_cotree_open ∘ k) st
  end.

Definition tie_cotree {A} (t : cotree bool (unit + A)) : cotree bool A :=
  cotree_iter (const t) tt.

(** This can be used instead *)
Definition iid_F {A} (a : cotree bool (unit + A)) : cotree bool A -> cotree bool A :=
  fun b => cotree_bind a (fun y => match y with
                             | inl _ => cotau b
                             | inr z => coleaf z
                             end).

(** Doesn't include tau nodes. Easier to reason about when doing the
    geometric series proof, and is obviously equivalent under cotwp to
    the version with tau nodes (iid_F).*)
Definition iid_F' {A} (a : cotree bool (unit + A)) : cotree bool A -> cotree bool A :=
  fun b => cotree_bind a (cotuple (const b) (@coleaf bool A)).

(** iter iid_F'
    a0 = cobot
    a1 = F a0 = F cobot = bind t (cotuple (const cobot) coleaf) = snip t
    a2 = F a1 = F (bind t (cotuple (const cobot) coleaf)) = F (snip t)
       = bind t (cotuple (const (snip t)) coleaf)
    a3 = F a2 = F (bind t (cotuple (const (snip t)) coleaf))
       = bind t (cotuple (bind t (cotuple (const (snip t)) coleaf)) coleaf)
 *)

Definition tie_cotree_iid {A} (t : cotree bool (unit + A)) : cotree bool A :=
  iter (iid_F t) cobot.

Definition to_cotree {A} : tree A -> cotree bool A := tie_cotree ∘ to_cotree_open.

(** iid_chain_
    a0 = coleaf (inl tt)
    a1 = bind a0 (cotuple (const t) (coleaf ∘ inr)) = t
    a2 = bind a1 (cotuple (const t) (coleaf ∘ inr))
       = bind t (cotuple (const t) (coleaf ∘ inr))
    a3 = bind a2 (cotuple (const t) (coleaf ∘ inr))
       = bind (bind t (cotuple (const t) (coleaf ∘ inr)))
              (cotuple (const t) (coleaf ∘ inr))
 *)
Fixpoint iid_chain_ {A} (t : cotree bool (unit + A)) (n : nat) : cotree bool (unit + A) :=
  match n with
  | O => coleaf (inl tt)
  | S n' => cotree_bind (iid_chain_ t n')
             (cotuple (const t) (@coleaf bool (unit + A) ∘ inr))
  end.

(** iid_chain
    b0 = snip a0 = cobot
    b1 = snip a1 = snip t
    b2 = snip a2 = snip (bind t (cotuple (const t) (coleaf ∘ inr)))
                 = bind t (snip ∘ (cotuple (const t) (coleaf ∘ inr)))
    b3 = snip a3 = snip (bind (bind t (cotuple (const t) (coleaf ∘ inr)))
                              (cotuple (const t) (coleaf ∘ inr)))
                 = bind (bind t (cotuple (const t) (coleaf ∘ inr)))
                        (snip ∘ cotuple (const t) (coleaf ∘ inr))
                 = bind t (fun x => bind (cotuple (const t) (coleaf ∘ inr) x)
                                         (snip ∘ cotuple (const t) (coleaf ∘ inr)))

  cotree_bind' (cotree_bind' t f) g = cotree_bind' t (fun x => cotree_bind' (f x) g).
 *)

Definition iid_chain {A} (t : cotree bool (unit + A)) (n : nat) : cotree bool A :=
  snip (iid_chain_ t n).

(** wp_ on finite trees. *)
Definition btwp {A} (f : A -> eR) : atree bool A -> eR :=
  fold 0 f id (fun k => (k false + k true) / 2).

Definition btwpQ {A} (f : A -> Q) : atree bool A -> Q :=
  fold 0%Q f id (fun k => (k false + k true) / 2)%Q.

(** wp_ on cotrees. *)
Definition cotwp {A} (f : A -> eR) : cotree bool A -> eR := co (btwp f).

(** wp on cotrees. *)
Definition cowp {A} (f : A -> eR) : cotree bool (unit + A) -> eR :=
  cotwp (cotuple (const 0) f).

(** wpfail on cotrees. *)
Definition cowpfail {A} (f : A -> eR) : cotree bool (unit + A) -> eR :=
  cotwp (cotuple (const 1) f).

(** fail on cotrees. *)
Definition cofail {A} : cotree bool (unit + A) -> eR := cowpfail (const 0).

(** wlp_ on finite trees. *)
Definition btwlp {A} (f : A -> eR) : atree bool A -> eR :=
  fold 1 f id (fun k => (k false + k true) / 2).

(** wlp_ on cotrees. *)
Definition cotwlp {A} (f : A -> eR) : cotree bool A -> eR := coop (btwlp f).

(** wlp on cotrees. *)
Definition cowlp {A} (f : A -> eR) : cotree bool (unit + A) -> eR :=
  cotwlp (cotuple (const 0) f).

(** wlpfail on cotrees. *)
Definition cowlpfail {A} (f : A -> eR) : cotree bool (unit + A) -> eR :=
  cotwlp (cotuple (const 1) f).

(** fail_or_diverge on cotrees. *)
Definition cofail_or_diverge {A} : cotree bool (unit + A) -> eR := cowlpfail (const 0).

(** cwp on cotrees. *)
Definition cocwp {A} (f : A -> eR) (t : cotree bool (unit + A)) : eR :=
  cowp f t / cowlp (const 1) t.


(* Check exportation of Argument Scopes even without import of modules *)

Require Import ZArith.

Module A.
Definition opp := Z.opp.
End A.
Check (A.opp 3).

(* Test extra scopes to be used in the presence of coercions *)

Record B := { f :> Z -> Z }.
Variable a:B.
Arguments a _%Z_scope : extra scopes.
Check a 0.

(* Check that casts activate scopes if ever possible *)

Inductive U := A.
Bind Scope u with U.
Notation "'ε'" := A : u.
Definition c := ε : U.

(* Check activation of type scope for tactics such as assert *)

Goal True.
assert (nat * nat).


From CoreErlang.BigStep Require Export BigStep.

(**
  IMPORTANT NOTICE:
  To use the `solve` tactic, the abbreviations (e.g. `EEmptyTuple`)
  should not be used (use `ETuple []` instead).
*)

Import ListNotations.

Section Helper_Theorems.

Theorem length_succ {B : Type} (a2 : B) (n : nat) (l2 : list B):
n = length l2
->
S n = length (a2 :: l2).
Proof.
  intros. simpl. rewrite H. auto.
Qed.

End Helper_Theorems.

(* Section Optimization.

Fixpoint is_literal_list (l : list Expression) : bool :=
match l with
| [] => true
| (ELit _)::xs => is_literal_list xs
| _ => false
end.

Fixpoint literal_list_to_value_list (l : list Expression) : list Value :=
match l with
| [] => []
| (ELit x)::xs => (VLit x)::(literal_list_to_value_list xs)
| _ => []
end.

Theorem eval_lit_list :
  forall l env id eff,
  is_literal_list l = true
->
  (forall i, i < length l -> |env, id, nth i l ErrorExp, eff|
  -e>
  |id, inl (nth i (literal_list_to_value_list l) ErrorValue), eff|).
Proof.
  induction l; intros.
  * inversion H0.
  * simpl in H0, H. destruct i.
    - simpl. destruct a; try (inversion H).
      + simpl. apply eval_lit.
    - simpl. destruct a; try (inversion H). simpl. apply IHl.
      + assumption.
      + lia.
Qed.

Fixpoint make_list {A : Type} (e : A) (n : nat) : list A :=
match n with
| 0 => []
| S n' => e::(make_list e n')
end.

Theorem length_lit_list :
  forall l, is_literal_list l = true ->
  length l = length (literal_list_to_value_list l).
Proof.
  intros. induction l.
  * simpl. reflexivity.
  * simpl. destruct a; try (inversion H).
    - simpl. rewrite (IHl H1). auto.
Qed.

Theorem make_list_length :
  forall {A : Type} e n, length (@make_list A e n) = n.
Proof.
  intros. induction n.
  * simpl. reflexivity.
  * simpl. rewrite (IHn). auto.
Qed.

Theorem last_make_list :
  forall {A : Type} e n, last (@make_list A e n) e = e.
Proof.
  intros. induction n.
  * simpl. reflexivity.
  * simpl. rewrite (IHn). destruct (make_list e n); auto.
Qed.

Theorem nth_make_list :
  forall {A : Type} e def n i, i < n -> nth i (@make_list A e n) def = e.
Proof.
  induction n; intros.
  * inversion H.
  * simpl. destruct i; auto.
    - apply lt_S_n in H. apply IHn. auto.
Qed.

Theorem nth_def_make_list :
  forall {A : Type} e def n i, i < n -> nth_def (@make_list A e n) e def i = e.
Proof.
  intros. unfold nth_def. destruct i.
  * auto.
  * apply nth_make_list. lia.
Qed.

Theorem S_nth_def_make_list :
  forall {A : Type} e def n i, i < n -> nth_def (@make_list A e n) e def (S i) = e.
Proof.
  intros. unfold nth_def. apply nth_make_list. auto.
Qed.

Theorem quick_tuple_eval :
  forall l env id eff,
  is_literal_list l = true
->
  |env, id, ETuple l, eff| -e> |id, inl (VTuple (literal_list_to_value_list l)), eff |.
Proof.
  intros. eapply eval_tuple with (eff := make_list eff (length l)) (ids := make_list id (length l)).
  - apply length_lit_list. assumption.
  - rewrite make_list_length. auto.
  - rewrite make_list_length. auto.
  - intros. pose (eval_lit_list l env id eff H i H0).
    rewrite nth_def_make_list, nth_def_make_list, S_nth_def_make_list, S_nth_def_make_list. all: auto.
  - apply eq_sym, last_make_list.
  - apply eq_sym, last_make_list.
Qed.

Fixpoint check_lit_cons (e : Expression) : bool :=
match e with
| ENil => true
| ECons (ELit x) y => match y with
                      | ENil => true
                      | ECons y' z => check_lit_cons y
                      | ELit y' => true
                      | _ => false
                      end
| _ => false
end.

Fixpoint exp_cons_to_val_cons (e : Expression) : Value :=
match e with
| ENil => VNil
| ECons (ELit x) y => match y with
                      | ENil => VCons (VLit x) VNil
                      | ECons y' z => VCons (VLit x) (exp_cons_to_val_cons y)
                      | ELit y' => VCons (VLit x) (VLit y')
                      | _ => ErrorValue
                      end
| _ => ErrorValue
end.

Theorem quick_list_eval :
  forall e env id eff, check_lit_cons e = true
->
  | env, id, e, eff | -e> | id, inl (exp_cons_to_val_cons e), eff|.
Proof.
  induction e; intros; try (inversion H).
  * simpl. apply eval_nil.
  * simpl. destruct e4, e5; try (inversion H1).
    - eapply eval_cons. apply eval_nil. apply eval_lit.
    - eapply eval_cons; apply eval_lit.
    - eapply eval_cons. 2: apply eval_lit.
      + apply IHe2. assumption.
Qed.

End Optimization. *)

(** Macro tactics *)
Ltac simpl_app :=
  repeat (rewrite app_assoc);
  repeat (rewrite app_nil_r).

Ltac simpl_app_H Hyp0 :=
  repeat (rewrite app_assoc in Hyp0);
  repeat (rewrite app_nil_r in Hyp0).

Ltac finishing_tactic :=
unfold nth_def; simpl;
match goal with
| |- | ?env, ?module, ?own_module, ?id, ENil, ?eff | -e> | ?id', ?res, ?eff'| => apply eval_nil
| |- | ?env, ?module, ?own_module, ?id, ELit ?lit, ?eff | -e> | ?id', ?res, ?eff'| => apply eval_lit
| |- | ?env, ?module, ?own_module, ?id, EVar ?v, ?eff | -e> | ?id', ?res, ?eff'| => apply eval_var; reflexivity
| |- | ?env, ?module, ?own_module, ?id, EFunId ?fid, ?eff | -e> | ?id', ?res, ?eff'| => (apply eval_funid; reflexivity) + (eapply eval_funid_module; reflexivity)
| |- | ?env, ?module, ?own_module, ?id, EFun ?pl ?b, ?eff | -e> | ?id', ?res, ?eff'| => apply eval_fun
end
.

Ltac empty_list :=
simpl;
match goal with
| |- 0 = length ?l => apply eq_sym, length_zero_iff_nil; reflexivity
| |- length ?l = 0 => apply length_zero_iff_nil; reflexivity
end.

Ltac unfold_list :=
simpl;
match goal with
| |- length ?l = _ => symmetry; repeat (eapply length_succ); empty_list
| |- _ = length ?l => repeat (eapply length_succ); empty_list
| _ => idtac
end.

(** Solver tactic *)
Ltac solve :=
unfold nth_def; simpl;
match goal with
(* | |- | ?env, ?module, ?own_module, ?id, ESingle _, ?eff | -e> | ?id', ?res, ?eff'| => apply eval_single; solve *)
| |- | ?env, ?module, ?own_module, ?id, EValues _, ?eff | -e> | ?id', ?res, ?eff'| =>
     (eapply eval_values;
     unfold_list2;
     unfold_elements;
     solve_inners;
     try(simpl;reflexivity);
     auto)
     +
     valuelist_exception_solver 0

| |- | ?env, ?module, ?own_module, ?id, ENil, ?eff | -e> | ?id', ?res, ?eff'| => finishing_tactic
| |- | ?env, ?module, ?own_module, ?id, ENil, ?eff | -e> | ?id', ?res, ?eff'| => finishing_tactic
| |- | ?env, ?module, ?own_module, ?id, ELit ?lit, ?eff | -e> | ?id', ?res, ?eff'| => finishing_tactic
| |- | ?env, ?module, ?own_module, ?id, EVar ?v, ?eff | -e> | ?id', ?res, ?eff'| => finishing_tactic
| |- | ?env, ?module, ?own_module, ?id, EFunId ?fid, ?eff | -e> | ?id', ?res, ?eff'| => finishing_tactic
| |- | ?env, ?module, ?own_module, ?id, EFun ?pl ?b, ?eff | -e> | ?id', ?res, ?eff'| => finishing_tactic
| |- | ?env, ?module, ?own_module, ?id, ETuple ?l, ?eff | -e> | ?id', ?res, ?eff'| =>
     (* (apply quick_tuple_eval; simpl; reflexivity)
     + *)
     (eapply eval_tuple;
     unfold_list2;
     unfold_elements;
     solve_inners;
     try(simpl;reflexivity);
     auto)
     + tuple_exception_solver 0
| |- | ?env, ?module, ?own_module, ?id, ECons _ _, ?eff | -e> | ?id', ?res, ?eff'| =>
     (* (apply quick_list_eval; simpl; reflexivity)
     + *)
     (eapply eval_cons; solve_inners)
     +
     (eapply eval_cons_tl_ex; solve_inners)
     +
     (eapply eval_cons_hd_ex; solve_inners)
| |- | ?env, ?module, ?own_module, ?id, ECase _ _, ?eff | -e> | ?id', ?res, ?eff'| =>
     case_solver 0
     +
     (eapply eval_case_pat_ex;
      solve_inners)
     +
     (eapply eval_case_clause_ex;
      (* unfold_list2;
      match goal with
      | |- forall i, i < length _ -> |_, _, _, _| -e> |_, _, _| =>
                                            unfold_elements;
                                            try(solve_inners)
      | _ => idtac
      end; *)
      solve_inners;
      intros;
      unfold_elements;
      match goal with

      | [H : match_clause _ _ _ = Some _ |- _] => inversion H
      | _ => idtac
      end;
      try(simpl;reflexivity);
      solve_inners)
| |- | ?env, ?module, ?own_module, ?id, ECall _ _ ?l, ?eff | -e> | ?id', ?res, ?eff'| =>  (* Need naother *)
     (eapply eval_call ;
     unfold_list2;
     solve_inners;
     unfold_elements;
     solve_inners;
     match goal with
     | |- eval _ _ _ _ = _ => tryif reflexivity then idtac else fail 1
     | _ => idtac
     end;
     auto)
     +
     (call_exception_solver 0)
| |- | ?env, ?module, ?own_module, ?id, EPrimOp _ _ ?l, ?eff | -e> | ?id', ?res, ?eff'| =>
     (eapply eval_call;
     unfold_list2;
     solve_inners;
     unfold_elements;
     solve_inners;
     match goal with
     | |- eval _ _ _ _ = _ => tryif reflexivity then idtac else fail 1
     | _ => idtac
     end;
     auto)
     +
     (primop_exception_solver 0)
| |- | ?env, ?module, ?own_module, ?id, EApp _ _, ?eff | -e> | ?id', ?res, ?eff'| =>
     (eapply eval_app;
     unfold_list2;
     unfold_elements;
     solve_inners;
     try(simpl;reflexivity);
     auto)
     +
     (eapply eval_app_closure_ex; solve_inners)
     +
     (app_param_exception_solver 0)
     +
     (eapply eval_app_badfun_ex;
      unfold_list2;
      unfold_elements;
      solve_inners;
      try(simpl;reflexivity);
      try(congruence)
     )
     +
     (eapply eval_app_badarity_ex;
      unfold_list2;
      unfold_elements;
      solve_inners;
      try(simpl;reflexivity);
      try(congruence)
     )
| |- | ?env, ?module, ?own_module, ?id, ELet _ _ _, ?eff | -e> | ?id', ?res, ?eff'| =>
     (eapply eval_let;
     solve_inners;
     try(simpl;reflexivity);
     auto)
     +
     (eapply eval_let_ex;
      solve_inners)
| |- | ?env, ?module, ?own_module, ?id, ESeq _ _, ?eff | -e> | ?id', ?res, ?eff'| =>
     (eapply eval_seq; solve_inners)
     +
     (eapply eval_seq_ex; solve_inners)
| |- | ?env, ?module, ?own_module, ?id, ELetRec _ _, ?eff | -e> | ?id', ?res, ?eff'| =>
     eapply eval_letrec;
     solve_inners
| |- | ?env, ?module, ?own_module, ?id, EMap ?l, ?eff | -e> | ?id', ?res, ?eff'| =>
     (eapply eval_map;
     unfold_list2;
     unfold_elements;
     solve_inners;
     try(simpl;reflexivity);
     auto)
     +
     (map_key_exception_solver 0)
| |- | ?env, ?module, ?own_module, ?id, ETry _ _ _ _ _, ?eff | -e> | ?id', ?res, ?eff'| =>
     (eapply eval_try;
      unfold_list2;
      solve_inners
      auto)
     +
     (
      eapply eval_catch;
      solve_inners
     )
end
with unfold_list2 :=
match goal with
| |- ?n = length ?l => unfold_list
| |- length ?l = ?n => unfold_list
| _ => idtac
end
with unfold_elements :=
intros; simpl length in *;
match goal with
| [H : S ?i <= 0 |-_ ] => inversion H
| [H : ?i < 0 |-_ ] => inversion H
| [H : S ?i <= ?n |-_ ] => inversion H; clear H; subst; unfold_elements
| [H : ?i < ?n |-_ ] => inversion H; clear H; subst; unfold_elements
| _ => idtac
end
with
solve_inners :=
match goal with
| |- | _, _, _, _, _, _ | -e> | _, _, _ | => tryif solve then idtac else fail 1
| |- | _, _, _, _, _, _ | -e> | _, _, _ | => tryif solve then idtac else fail 1
| _ => idtac
end
with
case_solver num :=
  tryif
    eapply eval_case with (i := num);
    match goal with
    | |- _ < _ => tryif simpl; lia then idtac else fail 2
    | _ => idtac
    end;
    try solve_inners;
    match goal with
     | |- match_clause _ _ _ = _ => tryif reflexivity then idtac else fail 1
     | _ => idtac
    end;
    match goal with
    | |- |_, _, _, _, _, _| -e> |_, inl ttrue, _| => tryif solve then idtac else fail 1
    | _ => idtac
    end;
    unfold_elements;
    match goal with
     | [H : match_clause _ _ _ = Some _ |- _] => inversion H
     | _ => idtac
    end;
    solve_inners;
    auto
  then idtac
  else
     case_solver (S num)
with
tuple_exception_solver num :=
  match goal with
  | |- |_, _, _, _, _, _| -e> | _, inl _, _ | => fail 1
  | _ =>
  tryif
    eapply eval_tuple_ex with (i := num);
    match goal with
    | |- _ < _ => tryif simpl; lia then idtac else fail 2
    | _ => idtac
    end;
    unfold_list2;
    unfold_elements;
    solve_inners
  then
    idtac
  else
    tuple_exception_solver (S num)
  end
with
valuelist_exception_solver num :=
  match goal with
  | |- |_, _, _, _, _, _| -e> | _, inl _, _ | => fail 1
  | _ =>
  tryif
    eapply eval_values_ex with (i := num);
    match goal with
    | |- _ < _ => tryif simpl; lia then idtac else fail 2
    | _ => idtac
    end;
    unfold_list2;
    unfold_elements;
    solve_inners
  then
    idtac
  else
    valuelist_exception_solver (S num)
  end
with
app_param_exception_solver num :=
  match goal with
  | |- |_, _, _, _, _, _ | -e> | _, inl _, _ | => fail 1
  | _ =>
    tryif
      eapply eval_app_param_ex with (i := num);
      match goal with
      | |- _ < _ => tryif simpl; lia then idtac else fail 2
      | _ => idtac
      end;
      unfold_list2;
      unfold_elements;
      solve_inners
    then
      idtac
    else
      app_param_exception_solver (S num)
  end
with
map_key_exception_solver num :=
  match goal with
  | |- |_, _, _, _, _, _| -e> | _, inl _, _ | => fail 1
  | _ =>
    tryif
      eapply eval_map_ex with (i := num);
      match goal with
      | |- _ < _ => tryif simpl; lia then idtac else fail 2
      | _ => idtac
      end;
      unfold_list2;
      unfold_elements;
      solve_inners
    then
      idtac
    else
      map_key_exception_solver (S num)
  end
with
call_exception_solver num :=
  match goal with
  | |- |_, _, _, _, _, _| -e> | _, inl _, _ | => fail 1
  | _ =>
    tryif
      eapply eval_call_ex with (i := num);
      match goal with
      | |- _ < _ => tryif simpl; lia then idtac else fail 2
      | _ => idtac
      end;
      unfold_list2;
      unfold_elements;
      solve_inners
    then
      idtac
    else
      call_exception_solver (S num)
  end
with
primop_exception_solver num :=
  match goal with
  | |- |_, _, _, _, _, _| -e> | _, inl _, _ | => fail 1
  | _ =>
    tryif
      eapply eval_call_ex with (i := num);
      match goal with
      | |- _ < _ => tryif simpl; lia then idtac else fail 2
      | _ => idtac
      end;
      unfold_list2;
      unfold_elements;
      solve_inners
    then
      idtac
    else
      primop_exception_solver (S num)
  end
.