(* 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 Reals.
Require Import trajectory_const.
Require Import trajectory_def.
Require Import constants.
Require Import ycngftys.
Require Import ycngstys.
Require Import tau.
Require Import ails.
Require Import trajectory.
Require Import measure2state.

Lemma d_distance :
 forall (intr : Trajectory) (evad : EvaderTrajectory),
 distance (measure2state (tr evad) 0) (measure2state intr 0) = d intr evad.
Proof with trivial.
unfold distance, d in |- *; unfold Die in |- *; simpl in |- *;
 unfold xi, yi in |- *...
Qed.

Lemma R_T :
 forall (intr : Trajectory) (evad : EvaderTrajectory) (T : TimeT),
 h (tr evad) = V ->
 Rsqr (RR (measure2state intr 0) (measure2state (tr evad) 0) T) =
 (Rsqr (l intr evad T * cos (beta intr evad T + thetat intr 0) - V * T) +
  Rsqr (l intr evad T * sin (beta intr evad T + thetat intr 0)))%R.
Proof with trivial.
intros intr evad T hyp_evad; rewrite Rsqr_minus...
unfold Rminus in |- *...
repeat rewrite Rplus_assoc...
set (z := 250%R)...
rewrite
 (Rplus_comm (Rsqr (l intr evad T * cos (beta intr evad T + thetat intr 0))))
 ...
repeat rewrite Rplus_assoc...
replace
 (Rsqr (l intr evad T * sin (beta intr evad T + thetat intr 0)) +
  Rsqr (l intr evad T * cos (beta intr evad T + thetat intr 0)))%R with
 (Rsqr (l intr evad T))...
rewrite <- (Rplus_comm (Rsqr (l intr evad T)))...
repeat rewrite <- Rplus_assoc...
replace
 (2 * (l intr evad T * cos (beta intr evad T + thetat intr 0)) * (V * T))%R
 with
 (2 * (l intr evad T * (V * T) * cos (beta intr evad T + thetat intr 0)))%R...
cut
 (l intr evad T =
  dist_euc (x (tr evad) T) (y (tr evad) T) (x intr 0%R) (y intr 0%R))...
intro...
rewrite H...
cut
 ((V * T)%R =
  dist_euc (x (tr evad) 0%R + T * z - T * z * cos (thetat intr 0))
    (y (tr evad) 0%R - T * z * sin (thetat intr 0))
    (x (tr evad) T) (y (tr evad) T))...
intro...
rewrite H0...
cut
 (RR (measure2state intr 0) (measure2state (tr evad) 0) T =
  dist_euc (x (tr evad) 0%R + T * z - T * z * cos (thetat intr 0))
    (y (tr evad) 0%R - T * z * sin (thetat intr 0))
    (x intr 0%R) (y intr 0%R))...
intro; rewrite H1...
replace
 (Rsqr
    (dist_euc (x (tr evad) 0 + T * z - T * z * cos (thetat intr 0))
       (y (tr evad) 0 - T * z * sin (thetat intr 0))
       (x (tr evad) T) (y (tr evad) T)) +
  Rsqr (dist_euc (x (tr evad) T) (y (tr evad) T) (x intr 0) (y intr 0)) +
  -
  (2 *
   (dist_euc (x (tr evad) T) (y (tr evad) T) (x intr 0) (y intr 0) *
    dist_euc (x (tr evad) 0 + T * z - T * z * cos (thetat intr 0))
      (y (tr evad) 0 - T * z * sin (thetat intr 0))
      (x (tr evad) T) (y (tr evad) T) *
    cos (beta intr evad T + thetat intr 0))))%R with
 (Rsqr
    (dist_euc (x (tr evad) 0 + T * z - T * z * cos (thetat intr 0))
       (y (tr evad) 0 - T * z * sin (thetat intr 0))
       (x (tr evad) T) (y (tr evad) T)) +
  Rsqr (dist_euc (x (tr evad) T) (y (tr evad) T) (x intr 0) (y intr 0)) -
  2 *
  (dist_euc (x (tr evad) T) (y (tr evad) T) (x intr 0) (y intr 0) *
   dist_euc (x (tr evad) 0 + T * z - T * z * cos (thetat intr 0))
     (y (tr evad) 0 - T * z * sin (thetat intr 0))
     (x (tr evad) T) (y (tr evad) T) * cos (beta intr evad T + thetat intr 0)))%R...
apply law_cosines...
unfold dist_euc in |- *...
replace
 (sqrt
    (Rsqr (x (tr evad) T - x intr 0%R) + Rsqr (y (tr evad) T - y intr 0%R)))
 with (l intr evad T)...
generalize (tr_cond1 evad (val T))...
intro; rewrite H2...
generalize (tr_cond2 evad (val T)); intro...
rewrite H3...
replace
 (x (tr evad) 0 + T * z - T * z * cos (thetat intr 0) -
  (x (tr evad) 0 + h (tr evad) * T))%R with (- T * z * cos (thetat intr 0))%R...
replace (y (tr evad) 0 - T * z * sin (thetat intr 0) - y (tr evad) 0)%R with
 (- T * z * sin (thetat intr 0))%R...
replace
 (Rsqr (- T * z * cos (thetat intr 0)) + Rsqr (- T * z * sin (thetat intr 0)))%R
 with (Rsqr (T * z))...
rewrite sqrt_Rsqr...
rewrite <- H2...
rewrite <- H3...
generalize xe_0; intro...
unfold xe, xi in H4...
rewrite (H4 intr evad T)...
generalize ye_0; intro...
unfold ye, yi in H5...
rewrite (H5 intr evad T)...
replace (x intr 0 - (l intr evad T * cos (beta intr evad T) + x intr 0))%R
 with (- (l intr evad T * cos (beta intr evad T)))%R...
unfold Rminus in |- *...
replace
 (y intr 0 + - (y intr 0 + - (l intr evad T * sin (beta intr evad T))))%R
 with (l intr evad T * sin (beta intr evad T))%R...
rewrite cos_plus...
unfold Rminus in |- *...
rewrite Rmult_plus_distr_l...
replace
 (- (l intr evad T * cos (beta intr evad T)) *
  (- T * z * cos (thetat intr 0)) +
  l intr evad T * sin (beta intr evad T) * (- T * z * sin (thetat intr 0)))%R
 with
 (l intr evad T * cos (beta intr evad T) * T * z * cos (thetat intr 0) +
  l intr evad T * - sin (beta intr evad T) * T * z * sin (thetat intr 0))%R...
replace (- (sin (beta intr evad T) * sin (thetat intr 0)))%R with
 (- sin (beta intr evad T) * sin (thetat intr 0))%R...
repeat rewrite <- Rmult_assoc...
repeat rewrite Rmult_assoc...
pattern (cos (beta intr evad T)) at 1 in |- *;
 rewrite (Rmult_comm (cos (beta intr evad T)))...
repeat rewrite <- Rmult_assoc...
replace
 (l intr evad T * T * z * cos (beta intr evad T) * cos (thetat intr 0))%R
 with
 (l intr evad T * T * z * cos (thetat intr 0) * cos (beta intr evad T))%R...
apply Rplus_eq_compat_l...
repeat rewrite Rmult_assoc...
apply Rmult_eq_compat_l...
repeat rewrite <- Rmult_assoc...
repeat rewrite <- (Rmult_comm (sin (thetat intr 0)))...
repeat rewrite Rmult_assoc...
apply Rmult_eq_compat_l...
rewrite (Rmult_comm (- sin (beta intr evad T)))...
repeat rewrite Rmult_assoc...
repeat rewrite Rmult_assoc...
repeat apply Rmult_eq_compat_l...
ring...
rewrite Ropp_mult_distr_l_reverse...
rewrite <- Ropp_mult_distr_l_reverse...
replace
 (- l intr evad T * cos (beta intr evad T) * (- T * z * cos (thetat intr 0)))%R
 with
 (l intr evad T * cos (beta intr evad T) * T * z * cos (thetat intr 0))%R...
apply Rplus_eq_compat_l...
repeat rewrite Rmult_assoc...
apply Rmult_eq_compat_l...
repeat rewrite <- Rmult_assoc...
repeat rewrite <- (Rmult_comm (sin (thetat intr 0)))...
apply Rmult_eq_compat_l...
repeat rewrite <- (Rmult_comm z)...
apply Rmult_eq_compat_l...
ring...
repeat rewrite <- Rmult_assoc...
repeat rewrite <- (Rmult_comm (cos (thetat intr 0)))...
apply Rmult_eq_compat_l...
repeat rewrite <- (Rmult_comm z)...
apply Rmult_eq_compat_l...
ring...
ring...
ring...
left; apply Rmult_lt_0_compat...
apply Rlt_le_trans with MinT...
apply MinT_is_pos...
apply (cond_1 T)...
unfold z in |- *; prove_sup...
replace (- T * z * cos (thetat intr 0))%R with
 (- T * (z * cos (thetat intr 0)))%R...
replace (- T * z * sin (thetat intr 0))%R with
 (- T * (z * sin (thetat intr 0)))%R...
repeat rewrite Rsqr_mult...
repeat rewrite <- Rsqr_neg...
rewrite cos2...
unfold Rminus in |- *; rewrite Rmult_plus_distr_l...
rewrite Rmult_1_r...
ring...
repeat rewrite Rmult_assoc...
repeat rewrite Rmult_assoc...
unfold Rminus in |- *...
rewrite (Rplus_comm (y (tr evad) 0%R))...
repeat rewrite Rplus_assoc...
rewrite Rplus_opp_r; rewrite Rplus_0_r...
repeat rewrite <- Ropp_mult_distr_l_reverse...
rewrite hyp_evad...
replace (v V) with z...
unfold Rminus in |- *...
ring...
unfold Rminus in |- *; unfold RR, dist_euc in |- *...
replace
 (sqrt
    (Rsqr (dx (measure2state intr 0) (measure2state (tr evad) 0) T) +
     Rsqr (dy (measure2state intr 0) (measure2state (tr evad) 0) T))) with
 (sqrt
    (Rsqr
       (x intr 0%R + T * z * cosd (toDeg (theta intr 0%R)) -
        (x (tr evad) 0%R + T * z)) +
     Rsqr
       (y intr 0%R + T * z * sind (toDeg (theta intr 0%R)) - y (tr evad) 0%R)))...
unfold cosd, sind, thetat in |- *...
rewrite rad_deg...
rewrite
 (Rsqr_neg
    (x intr 0%R + T * z * cos (theta intr 0%R) - (x (tr evad) 0%R + T * z)))
 ...
rewrite
 (Rsqr_neg (y intr 0%R + T * z * sin (theta intr 0%R) - y (tr evad) 0%R))
 ...
replace
 (- (x intr 0 + T * z * cos (theta intr 0) - (x (tr evad) 0 + T * z)))%R with
 (x (tr evad) 0 + T * z - T * z * cos (theta intr 0) - x intr 0)%R...
replace (- (y intr 0 + T * z * sin (theta intr 0) - y (tr evad) 0))%R with
 (y (tr evad) 0 - T * z * sin (theta intr 0) - y intr 0)%R...
unfold Rminus in |- *...
repeat rewrite Ropp_plus_distr...
rewrite Ropp_involutive...
rewrite <- (Rplus_comm (y (tr evad) 0%R))...
repeat rewrite Rplus_assoc...
apply Rplus_eq_compat_l...
rewrite (Rplus_comm (- y intr 0%R))...
unfold Rminus in |- *...
repeat rewrite Ropp_plus_distr...
repeat rewrite Ropp_involutive...
rewrite <- (Rplus_comm (x (tr evad) 0%R + T * z))...
repeat rewrite Rplus_assoc...
repeat apply Rplus_eq_compat_l...
rewrite (Rplus_comm (- x intr 0%R))...
cut (v V = z)...
intro...
rewrite H0...
unfold dist_euc in |- *...
generalize (tr_cond1 evad (val T)); intro...
generalize (tr_cond2 evad (val T)); intro...
rewrite H1...
rewrite H2...
rewrite hyp_evad...
rewrite H0...
replace
 (x (tr evad) 0 + T * z - T * z * cos (thetat intr 0) -
  (x (tr evad) 0 + z * T))%R with (- (T * z * cos (thetat intr 0)))%R...
replace (y (tr evad) 0 - T * z * sin (thetat intr 0) - y (tr evad) 0)%R with
 (- (T * z * sin (thetat intr 0)))%R...
repeat rewrite <- Rsqr_neg...
repeat rewrite Rsqr_mult...
rewrite cos2...
replace
 (Rsqr T * Rsqr z * (1 - Rsqr (sin (thetat intr 0))) +
  Rsqr T * Rsqr z * Rsqr (sin (thetat intr 0)))%R with
 (Rsqr T * Rsqr z)%R...
rewrite <- Rsqr_mult...
rewrite sqrt_Rsqr...
apply Rmult_comm...
left; apply Rmult_lt_0_compat...
apply Rlt_le_trans with MinT...
apply MinT_is_pos...
apply (cond_1 T)...
unfold z in |- *; prove_sup...
unfold Rminus in |- *...
rewrite Rmult_plus_distr_l...
rewrite Rmult_1_r...
ring...
unfold Rminus in |- *...
rewrite (Rplus_comm (y (tr evad) 0%R))...
rewrite Rplus_assoc...
rewrite Rplus_opp_r...
symmetry  in |- *; apply Rplus_0_r...
unfold Rminus in |- *...
rewrite Ropp_plus_distr...
rewrite (Rplus_comm (- x (tr evad) 0%R))...
repeat rewrite Rplus_assoc...
rewrite (Rplus_comm (x (tr evad) 0%R))...
repeat rewrite Rplus_assoc...
rewrite Rplus_opp_l; rewrite Rplus_0_r...
ring...
unfold l, dist_euc in |- *...
unfold Die in |- *...
unfold xi, yi in |- *...
rewrite (Rsqr_neg (x intr 0%R - x (tr evad) T))...
rewrite (Rsqr_neg (y intr 0%R - y (tr evad) T))...
unfold Rminus in |- *...
repeat rewrite Ropp_plus_distr...
repeat rewrite Ropp_involutive...
rewrite <- (Rplus_comm (x (tr evad) T))...
rewrite <- (Rplus_comm (y (tr evad) T))...
repeat rewrite Rmult_assoc...
repeat apply Rmult_eq_compat_l...
rewrite <- (Rmult_comm (V * T))...
repeat rewrite Rmult_assoc...
repeat rewrite Rsqr_mult...
rewrite sin2...
unfold Rminus in |- *...
rewrite Rmult_plus_distr_l...
rewrite Rmult_1_r...
ring...
Qed.


Require Export Program.Basics. Open Scope program_scope.
From Paco Require Import paconotation_internal paco_internal pacotac_internal.
From Paco Require Export paconotation.
Set Implicit Arguments.

Section PACO5.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.
Variable T4 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1) (x3: @T3 x0 x1 x2), Type.

(** ** Predicates of Arity 5
*)

Definition paco5(gf : rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4)(r: rel5 T0 T1 T2 T3 T4) : rel5 T0 T1 T2 T3 T4 :=
  @curry5 T0 T1 T2 T3 T4 (paco (fun R0 => @uncurry5 T0 T1 T2 T3 T4 (gf (@curry5 T0 T1 T2 T3 T4 R0))) (@uncurry5 T0 T1 T2 T3 T4 r)).

Definition upaco5(gf : rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4)(r: rel5 T0 T1 T2 T3 T4) := paco5 gf r \5/ r.
Arguments paco5 : clear implicits.
Arguments upaco5 : clear implicits.
#[local] Hint Unfold upaco5 : core.

Definition monotone5 (gf: rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4) :=
  forall x0 x1 x2 x3 x4 r r' (IN: gf r x0 x1 x2 x3 x4) (LE: r <5= r'), gf r' x0 x1 x2 x3 x4.

Definition _monotone5 (gf: rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4) :=
  forall r r'(LE: r <5= r'), gf r <5== gf r'.

Lemma monotone5_eq (gf: rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4) :
  monotone5 gf <-> _monotone5 gf.
Proof. unfold monotone5, _monotone5, le5. split; intros; eapply H; eassumption. Qed.

Lemma monotone5_map (gf: rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4)
      (MON: _monotone5 gf) :
  _monotone (fun R0 => @uncurry5 T0 T1 T2 T3 T4 (gf (@curry5 T0 T1 T2 T3 T4 R0))).
Proof.
  red; intros. apply uncurry_map5. apply MON; apply curry_map5; assumption.
Qed.

Lemma monotone5_compose (gf gf': rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4)
      (MON1: monotone5 gf)
      (MON2: monotone5 gf'):
  monotone5 (compose gf gf').
Proof.
  red; intros. eapply MON1. apply IN.
  intros. eapply MON2. apply PR. apply LE.
Qed.

Lemma monotone5_union (gf gf': rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4)
      (MON1: monotone5 gf)
      (MON2: monotone5 gf'):
  monotone5 (gf \6/ gf').
Proof.
  red; intros. destruct IN.
  - left. eapply MON1. apply H. apply LE.
  - right. eapply MON2. apply H. apply LE.
Qed.

Lemma _paco5_mon_gen (gf gf': rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4) r r'
    (LEgf: gf <6= gf')
    (LEr: r <5= r'):
  paco5 gf r <5== paco5 gf' r'.
Proof.
  apply curry_map5. red; intros. eapply paco_mon_gen. apply PR.
  - intros. apply LEgf, PR0.
  - intros. apply LEr, PR0.
Qed.

Lemma paco5_mon_gen (gf gf': rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4) r r' x0 x1 x2 x3 x4
    (REL: paco5 gf r x0 x1 x2 x3 x4)
    (LEgf: gf <6= gf')
    (LEr: r <5= r'):
  paco5 gf' r' x0 x1 x2 x3 x4.
Proof.
  eapply _paco5_mon_gen; [apply LEgf | apply LEr | apply REL].
Qed.

Lemma paco5_mon_bot (gf gf': rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4) r' x0 x1 x2 x3 x4
    (REL: paco5 gf bot5 x0 x1 x2 x3 x4)
    (LEgf: gf <6= gf'):
  paco5 gf' r' x0 x1 x2 x3 x4.
Proof.
  eapply paco5_mon_gen; [apply REL | apply LEgf | intros; contradiction PR].
Qed.

Lemma upaco5_mon_gen (gf gf': rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4) r r' x0 x1 x2 x3 x4
    (REL: upaco5 gf r x0 x1 x2 x3 x4)
    (LEgf: gf <6= gf')
    (LEr: r <5= r'):
  upaco5 gf' r' x0 x1 x2 x3 x4.
Proof.
  destruct REL.
  - left. eapply paco5_mon_gen; [apply H | apply LEgf | apply LEr].
  - right. apply LEr, H.
Qed.

Lemma upaco5_mon_bot (gf gf': rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4) r' x0 x1 x2 x3 x4
    (REL: upaco5 gf bot5 x0 x1 x2 x3 x4)
    (LEgf: gf <6= gf'):
  upaco5 gf' r' x0 x1 x2 x3 x4.
Proof.
  eapply upaco5_mon_gen; [apply REL | apply LEgf | intros; contradiction PR].
Qed.

Section Arg5.

Variable gf : rel5 T0 T1 T2 T3 T4 -> rel5 T0 T1 T2 T3 T4.
Arguments gf : clear implicits.

Theorem _paco5_mon: _monotone5 (paco5 gf).
Proof.
  red; intros. eapply curry_map5, _paco_mon; apply uncurry_map5; assumption.
Qed.

Theorem _paco5_acc: forall
  l r (OBG: forall rr (INC: r <5== rr) (CIH: l <5== rr), l <5== paco5 gf rr),
  l <5== paco5 gf r.
Proof.
  intros. apply uncurry_adjoint1_5.
  eapply _paco_acc. intros.
  apply uncurry_adjoint1_5 in INC. apply uncurry_adjoint1_5 in CIH.
  apply uncurry_adjoint2_5.
  eapply le5_trans. eapply (OBG _ INC CIH).
  apply curry_map5.
  apply _paco_mon; try apply le1_refl; apply curry_bij1_5.
Qed.

Theorem _paco5_mult_strong: forall r,
  paco5 gf (upaco5 gf r) <5== paco5 gf r.
Proof.
  intros. apply curry_map5.
  eapply le1_trans; [| eapply _paco_mult_strong].
  apply _paco_mon; intros [] H; apply H.
Qed.

Theorem _paco5_fold: forall r,
  gf (upaco5 gf r) <5== paco5 gf r.
Proof.
  intros. apply uncurry_adjoint1_5.
  eapply le1_trans; [| apply _paco_fold]. apply le1_refl.
Qed.

Theorem _paco5_unfold: forall (MON: _monotone5 gf) r,
  paco5 gf r <5== gf (upaco5 gf r).
Proof.
  intros. apply curry_adjoint2_5.
  eapply _paco_unfold; apply monotone5_map; assumption.
Qed.

Theorem paco5_acc: forall
  l r (OBG: forall rr (INC: forall _x_0 _x_1 _x_2 _x_3 _x_4 (PR: r _x_0 _x_1 _x_2 _x_3 _x_4 : Prop), rr _x_0 _x_1 _x_2 _x_3 _x_4 : Prop) (CIH: forall _x_0 _x_1 _x_2 _x_3 _x_4 (PR: l _x_0 _x_1 _x_2 _x_3 _x_4 : Prop), rr _x_0 _x_1 _x_2 _x_3 _x_4 : Prop), forall _x_0 _x_1 _x_2 _x_3 _x_4 (PR: l _x_0 _x_1 _x_2 _x_3 _x_4 : Prop), paco5 gf rr _x_0 _x_1 _x_2 _x_3 _x_4 : Prop),
  l <5= paco5 gf r.
Proof.
  apply _paco5_acc.
Qed.

Theorem paco5_mon: monotone5 (paco5 gf).
Proof.
  apply monotone5_eq.
  apply _paco5_mon.
Qed.

Theorem upaco5_mon: monotone5 (upaco5 gf).
Proof.
  red; intros.
  destruct IN.
  - left. eapply paco5_mon. apply H. apply LE.
  - right. apply LE, H.
Qed.

Theorem paco5_mult_strong: forall r,
  paco5 gf (upaco5 gf r) <5= paco5 gf r.
Proof.
  apply _paco5_mult_strong.
Qed.

Corollary paco5_mult: forall r,
  paco5 gf (paco5 gf r) <5= paco5 gf r.
Proof. intros; eapply paco5_mult_strong, paco5_mon; [apply PR|..]; intros; left; assumption. Qed.

Theorem paco5_fold: forall r,
  gf (upaco5 gf r) <5= paco5 gf r.
Proof.
  apply _paco5_fold.
Qed.

Theorem paco5_unfold: forall (MON: monotone5 gf) r,
  paco5 gf r <5= gf (upaco5 gf r).
Proof.
  intro. eapply _paco5_unfold; apply monotone5_eq; assumption.
Qed.

End Arg5.

Arguments paco5_acc : clear implicits.
Arguments paco5_mon : clear implicits.
Arguments upaco5_mon : clear implicits.
Arguments paco5_mult_strong : clear implicits.
Arguments paco5_mult : clear implicits.
Arguments paco5_fold : clear implicits.
Arguments paco5_unfold : clear implicits.

Global Instance paco5_inst  (gf : rel5 T0 T1 T2 T3 T4->_) r x0 x1 x2 x3 x4 : paco_class (paco5 gf r x0 x1 x2 x3 x4) :=
{ pacoacc    := paco5_acc gf;
  pacomult   := paco5_mult gf;
  pacofold   := paco5_fold gf;
  pacounfold := paco5_unfold gf }.

End PACO5.

Global Opaque paco5.

#[export] Hint Unfold upaco5 : core.
#[export] Hint Resolve paco5_fold : core.
#[export] Hint Unfold monotone5 : core.


(* NOTE: This program is NOT open-source, and is NOT licensed for
 * redistribution.  It is copyright by the authors.  Permission is
 * granted only to the CertiCoq project for the use of this program
 * as a benchmark in measuring CertiCoq performance. *)

(************************************************************************************)
(**                                                                                *)
(**                              The DataCert Library                                *)
(**                                                                                *)
(**                           LRI, CNRS & Université Paris-Sud                       *)
(**                                                                                *)
(**                 Copyright 2016 : Véronique Benzaken & Évelyne Contejean          *)
(**                                                                                *)
(************************************************************************************)

Set Implicit Arguments.

(** printing inS? $\in_?$ #∈?# *)
(** printing inS $\in$ #∈# *)
(** printing subS? $\subseteq_?$ #⊆?# *)
(** printing subS $\subseteq$ #⊆# *)
(** printing unionS $\cup$ #⋃# *)
(** printing interS $\cap$ #⋂# *)
(** printing inI $\in_I$ #∈I# *)
(** printing theta $\theta$ #θ# *)
(** printing nu1 $\nu_1$ #ν1# *)
(** printing nu $\nu$ #ν# *)
(** printing mu $\mu$ #μ# *)
(** printing sigma $\sigma$ #σ# *)
(** printing -> #⟶# *)
(** printing <-> #⟷# *)
(** printing => #⟹# *)
(** printing (emptysetS) $\emptyset$ #Ø# *)
(** printing emptysetS $\emptyset$ #Ø# *)
(** printing {{ $\{$ #{# *)
(** printing }} $\}$ #}# *)

Require Import Relations SetoidList List String Ascii Bool ZArith NArith.

Require Import FlatData ListFacts OrderedSet FiniteSet Tree Formula Sql.

Section Try.
Import Tuple Expression.
Require Import Values Relnames SortedAttributes SortedTuples.

(** Defining functions and aggregates, and giving their interpretation *)

Inductive symbol : Type :=
  | Symbol : string -> symbol
  | CstVal : value -> symbol.

Inductive predicate : Type := Predicate : string -> predicate.

Definition OP : Oset.Rcd predicate.
split with (fun x y => match x, y with Predicate s1, Predicate s2 => string_compare s1 s2 end).
- intros [s1] [s2]; generalize (Oset.eq_bool_ok Ostring s1 s2); simpl.
  case (string_compare s1 s2).
  + apply f_equal.
  + intros H1 H2; apply H1; injection H2; exact (fun h => h).
  + intros H1 H2; apply H1; injection H2; exact (fun h => h).
- intros [s1] [s2] [s3]; apply (Oset.compare_lt_trans Ostring s1 s2 s3).
- intros [s1] [s2]; apply (Oset.compare_lt_gt Ostring s1 s2).
Defined.

Definition symbol_compare (s1 s2 : symbol) :=
  match s1, s2 with
    | Symbol s1, Symbol s2 => string_compare s1 s2
    | Symbol _, CstVal _ => Lt
    | CstVal _, Symbol _ => Gt
    | CstVal v1, CstVal v2 => value_compare v1 v2
  end.

Definition OSymbol : Oset.Rcd symbol.
split with symbol_compare.
- intros [s1 | s1] [s2 | s2]; simpl; try discriminate.
  + generalize (Oset.eq_bool_ok Ostring s1 s2); simpl.
    case (string_compare s1 s2).
    * apply f_equal.
    * intros H1 H2; apply H1; injection H2; exact (fun h => h).
    * intros H1 H2; apply H1; injection H2; exact (fun h => h).
  + generalize (Oset.eq_bool_ok OVal s1 s2); simpl.
    case (value_compare s1 s2).
    * apply f_equal.
    * intros H1 H2; apply H1; injection H2; exact (fun h => h).
    * intros H1 H2; apply H1; injection H2; exact (fun h => h).
- intros [s1 | s1] [s2 | s2] [s3 | s3]; simpl;
  try (apply (Oset.compare_lt_trans Ostring) ||
             apply (Oset.compare_lt_trans OVal) ||
             trivial || discriminate).
- intros [s1 | s1] [s2 | s2]; simpl;
  try (apply (Oset.compare_lt_gt Ostring) ||
             apply (Oset.compare_lt_gt OVal) ||
             trivial || discriminate).
Defined.

Definition interp_symbol f :=
  match f with
    | Symbol "plus" =>
      fun l =>
        match l with
          | Value_N a1 :: Value_N a2 :: nil => Value_N (Nplus a1 a2)
          | _ => Value_N 0 end
    | Symbol "mult" =>
      fun l =>
        match l with
          | Value_N a1 :: Value_N a2 :: nil => Value_N (Nmult a1 a2)
          | _ => Value_N 0 end
    | Symbol "minus" =>
      fun l =>
        match l with
          | Value_N a1 :: Value_N a2 :: nil => Value_N (Nminus a1 a2)
          | _ => Value_N 0 end
    | Symbol "opp" =>
      fun l =>
        match l with
          | Value_N a1 :: nil => Value_N (Nopp a1)
          | _ => Value_N 0 end
    | CstVal v =>
      fun l =>
        match l with
          | nil => v
          | _ => default_value (type_of_value v)
        end
    | _ => fun _ => Value_N 0
  end.

Definition interp_predicate p :=
  match p with
    | Predicate "<" =>
      fun l =>
        match l with
          | Value_N a1 :: Value_N a2 :: nil =>
            match Ncompare a1 a2 with Lt => true | _ => false end
          | _ => false
        end
    | Predicate "<=" =>
      fun l =>
        match l with
          | Value_N a1 :: Value_N a2 :: nil =>
            match Ncompare a1 a2 with Gt => false | _ => true end
          | _ => false
        end
    | Predicate ">" =>
      fun l =>
        match l with
          | Value_N a1 :: Value_N a2 :: nil =>
            match Ncompare a1 a2 with Gt => true | _ => false end
          | _ => false
        end
    | Predicate ">=" =>
      fun l =>
        match l with
          | Value_N a1 :: Value_N a2 :: nil =>
            match Ncompare a1 a2 with Lt => false | _ => true end
          | _ => false
        end
    | Predicate "=" =>
      fun l =>
        match l with
          | Value_N a1 :: Value_N a2 :: nil =>
            match Ncompare a1 a2 with Eq => true | _ => false end
          | Value_string s1 :: Value_string s2 :: nil =>
            match string_compare s1 s2 with Eq => true | _ => false end
          | _ => false
        end
   | _ => fun _ => false
  end.

Inductive aggregate : Type :=
  | Aggregate : string -> aggregate.

Definition OAgg : Oset.Rcd aggregate.
split with (fun x y => match x, y with Aggregate s1, Aggregate s2 => string_compare s1 s2 end).
- intros [s1] [s2]; generalize (Oset.eq_bool_ok Ostring s1 s2); simpl.
  case (string_compare s1 s2).
  + apply f_equal.
  + intros H1 H2; apply H1; injection H2; exact (fun h => h).
  + intros H1 H2; apply H1; injection H2; exact (fun h => h).
- intros [s1] [s2] [s3]; apply (Oset.compare_lt_trans Ostring s1 s2 s3).
- intros [s1] [s2]; apply (Oset.compare_lt_gt Ostring s1 s2).
Defined.

Definition interp_aggregate a :=
  match a with
    | Aggregate "count" =>
      fun (l : list (Tuple.value T)) => Value_N (N_of_nat (List.length l))
    | Aggregate "sum" =>
      fun (l : list (Tuple.value T)) =>
           Value_N (fold_left (fun acc x => match x with Value_N x => (acc + x)%N | _ => acc end) l 0%N)
    | Aggregate "avg" =>
      fun (l : list (Tuple.value T)) =>
           Value_N (let sum := fold_left (fun acc x => match x with Value_N x => (acc + x)%N | _ => acc end) l 0%N in Ndiv sum (N_of_nat (List.length l)))
    | Aggregate _ => fun _ => Value_N 0
  end.

(** Building a database instance, and updating it  *)
Definition mk_tuple la f := mk_tuple T (mk_set FAN la) f.

Definition show_tuple t :=
  List.map
    (fun a => (a, dot T t a))
    (Fset.elements _ (support _ t)).

Definition show_tuples x :=
  List.map show_tuple (Feset.elements (FTuple T) x).

Record db_state : Type :=
  mk_state
    {
      _relnames : list relname;
      _basesort : relname -> Fset.set FAN;
      _instance : relname -> Feset.set (FTuple T)
    }.

Definition show_state (db : db_state) :=
  (_relnames db,
   List.map (fun r => (r, Fset.elements _ (_basesort db r))) (_relnames db),
   List.map (fun r => (r, show_tuples (_instance db r))) (_relnames db)).

Definition init_db :=
  mk_state
    nil
    (fun _ => Fset.empty FAN)
    (fun _ => Feset.empty (FTuple T)).

Definition create_table
           (* old state *) db
           (* new table name *) t
           (* new table sort *) st
            :=
  mk_state
    (t :: _relnames db)
    (fun x =>
       match Oset.compare ORN x t with
         | Eq => mk_set FAN st
         |_ => _basesort db x
       end)
    (_instance db).

Definition insert_tuple_into
           (* old state *) db
           (* new tuple *) tpl
           (* table *) tbl
            :=
  if Fset.equal FAN (support T tpl) (_basesort db tbl)
  then
    mk_state
      (_relnames db)
      (_basesort db)
      (fun x =>
         match Oset.compare ORN x tbl with
           | Eq => Feset.add (FTuple T) tpl (_instance db tbl)
           |_ => _instance db x
         end)
   else (* no NULL values by default *) db.

Fixpoint insert_tuples_into
           (* old state *) db
           (* new tuple list *) ltpl
           (* table *) tbl :=
  match ltpl with
    | nil => db
    | t :: l => insert_tuple_into (insert_tuples_into db l tbl) t tbl
  end.

Definition MyDBS db := DatabaseSchema.mk_R (Tuple.A T) ORN (_basesort db).

(** Evaluation of SQL-COQ queries *)

Definition eval_sql_query_in_state (db : db_state) q :=
  eval_sql_query
    (DBS := MyDBS db) interp_predicate interp_symbol interp_aggregate (_instance db) q.

(** Some notations, to ease the readability *)
Notation aa := (Attr_N 0 "a").
Notation bb := (Attr_N 0 "b").
Notation cc := (Attr_N 0 "c").
Notation ac := (Attr_N 0 "ac").
Notation cb := (Attr_N 0 "cb").
Notation b_plus_c := (Attr_N 0 "b_plus_c").
Notation a := (Attr_N 0 "a").
Notation b := (Attr_N 0 "b").
Notation c := (Attr_N 0 "c").
Notation a1 := (Attr_N 0 "a1").
Notation b1 := (Attr_N 0 "b1").
Notation c1 := (Attr_N 0 "c1").
Notation a0 := (Attr_N 0 "a0").
Notation b0 := (Attr_N 0 "b0").
Notation c0 := (Attr_N 0 "c0").
Notation a2 := (Attr_N 0 "a2").
Notation b2 := (Attr_N 0 "b2").
Notation c2 := (Attr_N 0 "c2").
Notation a3 := (Attr_N 0 "a3").
Notation b3 := (Attr_N 0 "b3").
Notation c3 := (Attr_N 0 "c3").
Notation a4 := (Attr_N 0 "a4").
Notation b4 := (Attr_N 0 "b4").
Notation c4 := (Attr_N 0 "c4").

Notation table0 :=  (Rel "table0").
Notation t0 :=  (Rel "t0").
Notation table1 :=  (Rel "table1").
Notation t1 :=  (Rel "t1").
Notation table2 :=  (Rel "table2").
Notation t2 :=  (Rel "t2").
Notation table3 :=  (Rel "table3").
Notation t3 :=  (Rel "t3").

(** Again, for the constructs of the SQL framework *)
Definition _Select_Star := (@Select_Star symbol aggregate T).

Definition _Select_List := (@Select_List symbol aggregate T).

Definition _Select_As := (@Select_As symbol aggregate T).

Definition _Att_Ren_Star := (@Att_Ren_Star T).

Definition _Att_Ren_List := (@Att_Ren_List T).

Definition _Att_As := (@Att_As T).

Definition _Sql_Table db := (@Sql_Table predicate symbol aggregate T (MyDBS db)).

Definition _Sql_Select db := @Sql_Select predicate symbol aggregate T (MyDBS db).

Definition _From_Item db := (@From_Item predicate symbol aggregate T (MyDBS db)).

Definition _Sql_Atom db := (@Sql_Atom predicate symbol aggregate T (MyDBS db)).

Definition _Sql_True db := (@Sql_True predicate symbol aggregate T (MyDBS db)).

Definition _Sql_Not db := (@Sql_Not predicate symbol aggregate T (MyDBS db)).

Definition _Sql_Conj db := (@Sql_Conj predicate symbol aggregate T (MyDBS db)).

Definition _Group_Fine := (@Group_Fine symbol T).

Definition __Sql_Dot a := (@F_Dot T symbol a).

Definition _Sql_Dot a := (@A_Expr T _ aggregate (@F_Dot T symbol a)).

Definition _Sql_Pred db := (@Sql_Pred predicate symbol aggregate T (MyDBS db)).

Definition _Sql_In db := (@Sql_In predicate symbol aggregate T (MyDBS db)).

Definition _Sql_Quant db := (@Sql_Quant predicate symbol aggregate T (MyDBS db)).

Definition _A_Expr := (@A_Expr T symbol aggregate).

Definition _F_Expr := (@F_Expr T symbol).

Definition _CstN n := (F_Constant T symbol (Value_N n)).

Definition CstN n := (_A_Expr (F_Constant T symbol (Value_N n))).

Definition t123 :=
  mk_tuple
    (aa :: bb :: cc :: nil)
    (fun x => match x with
                | aa => Value_N 1
                | bb => Value_N 2
                | cc => Value_N 3
                | _ => Value_N 0 end).

Definition t456 := mk_tuple
        (aa :: bb :: cc :: nil)
        (fun x => match x with
                    | aa => Value_N 4
                    | bb => Value_N 5
                    | cc => Value_N 6
                    | _ => Value_N 0 end).

Definition t778 := mk_tuple
        (aa :: bb :: cc :: nil)
        (fun x => match x with
                    | aa => Value_N 7
                    | bb => Value_N 7
                    | cc => Value_N 8
                    | _ => Value_N 0 end).

Definition t779 := mk_tuple
        (aa :: bb :: cc :: nil)
        (fun x => match x with
                    | aa => Value_N 7
                    | bb => Value_N 7
                    | cc => Value_N 9
                    | _ => Value_N 0 end).

Definition db0 := init_db.

(**
create table table1(a integer, b integer, c integer);
*)

Definition db1 :=
  create_table
    (create_table db0 table0 (aa :: bb :: cc :: nil))
    table1 (aa :: bb :: cc :: nil).

(**
insert into table1 values (1,2,3);
insert into table1 values (4,5,6);
*)
Definition db2 := insert_tuples_into db1 (t123 :: t456 :: nil) table1.

Definition db3 := insert_tuples_into db2 (t778 :: t779 :: nil) table1.

(**
insert into table1 values (4,5);
*)

Definition db4 :=
  insert_tuple_into
    db3
    (mk_tuple
        (aa :: bb :: nil)
        (fun x => match x with
                    | aa => Value_N 4
                    | bb => Value_N 5
                    | _ => Value_N 0 end))
    table1.

(** select t5.a2 as a3 from table5 as t5(a2) *)

Definition eval_sql0 :=
  let a1 := Attr_N 0 "a1" in
  let a2 := Attr_N 0 "a2" in
  let a3 := Attr_N 0 "a3" in
  let table5 := Rel "table5" in
  let tpl n :=
      mk_tuple
        (a1 :: nil)
        (fun x => match x with a1 => Value_N n | _ => Value_N 0 end) in
  let db1 :=
      insert_tuples_into
        (create_table db0 table5 (a1 :: nil))
        (tpl 1 :: tpl 2 :: tpl 3 :: nil)
        table5 in
  let sql0 db :=
  _Sql_Select
        (* select *) (_Select_List ((_Select_As (_Sql_Dot a2) a3) :: nil))
        (* from *) ((_From_Item
                       (_Sql_Table table5)
                       (Att_Ren_List ((Att_As T a1 a2) :: nil))) :: nil)
        (* where *) (_Sql_Atom (_Sql_True db))
        (* groupby *) (_Group_Fine)
        (* having *) (_Sql_Atom (_Sql_True db)) in

  eval_sql_query_in_state (sql0 db1).

Eval compute in (show_tuples eval_sql0).

(** select * from table1; *)

Definition sql1 db :=
  _Sql_Select
    (* select *) _Select_Star
    (* from *) ((_From_Item (_Sql_Table table1) _Att_Ren_Star) :: nil)
    (* where *) (_Sql_Atom (_Sql_True db))
    (* groupby *) _Group_Fine
    (* having *) (_Sql_Atom (_Sql_True db)).

Definition eval_sql1 := eval_sql_query_in_state (sql1 db2).

Eval compute in (show_tuples eval_sql1).

(** select * from table1 where aa = bb *)
Definition sql2 db :=
  _Sql_Select
    (* select *) _Select_Star
    (* from *) ((_From_Item (_Sql_Table table1) _Att_Ren_Star) :: nil)
    (* where *) (_Sql_Atom (_Sql_Pred db (Predicate "=") (_Sql_Dot aa :: _Sql_Dot bb :: nil)))
    (* groupby *) _Group_Fine
    (* having *) (_Sql_Atom (_Sql_True db)).

Definition eval_sql2 := eval_sql_query_in_state (sql2 db2).
Eval compute in (show_tuples eval_sql2).

(** Evalution of the same query in different states (that is instances) of the database *)
Definition eval_sql2' := eval_sql_query_in_state (sql2 db3).
Eval compute in (show_tuples eval_sql2').

Definition eval_sql1' := eval_sql_query_in_state (sql1 db3).
Eval compute in (show_tuples eval_sql1').

Definition eval_sql1'' := eval_sql_query_in_state (sql1 db4).
Eval compute in (show_tuples eval_sql1'').

(** (4,5) has not been inserted in db4, as specified by insert_tuple.
 We COULD have made another choice, and null values in that case would correspond
 to an attribute which occurs in the sort of the query, but not in the support
 of the tuple.*)

(** SELECT a, b FROM table1; *)

Definition sql5 db :=
  _Sql_Select
    (* select *) (_Select_List
                    ((_Select_As (_Sql_Dot aa) aa) ::
                     (_Select_As (_Sql_Dot bb) bb ) :: nil))
    (* from *) ((_From_Item (_Sql_Table table1) _Att_Ren_Star) :: nil)
    (* where *) (_Sql_Atom (_Sql_True db))
    (* groupby *) _Group_Fine
    (* having *) (_Sql_Atom (_Sql_True db)).

Definition eval_sql5 := eval_sql_query_in_state (sql5 db4).
Eval vm_compute in (show_tuples eval_sql5).

(** SELECT a, b + c FROM table1; actully, we use
   SELECT a, b + c AS bplusc FROM table1; *)
Definition sql6 db :=
  _Sql_Select
    (* select *) (_Select_List
                    ((_Select_As (_Sql_Dot aa) aa) ::
                     (_Select_As
                        (_A_Expr ((_F_Expr (Symbol "plus")) ((__Sql_Dot bb) :: (__Sql_Dot cc) :: nil)))
                          b_plus_c ) :: nil))
    (* from *) ((_From_Item (_Sql_Table table1) _Att_Ren_Star) :: nil)
    (* where *) (_Sql_Atom (_Sql_True db))
    (* groupby *) _Group_Fine
    (* having *) (_Sql_Atom (_Sql_True db)).

Definition eval_sql6 := eval_sql_query_in_state (sql6 db4).
Eval compute in (show_tuples eval_sql6).

(** explicit renaming of attributes
      select * from table1 as t1(a1 , b1 , c1 ); *)

Definition sql7 db :=
  _Sql_Select
    (* select *) _Select_Star
    (* from *) ((_From_Item
                   (_Sql_Table table1)
                   (_Att_Ren_List
                      (_Att_As aa a1 ::
                       _Att_As bb b1 ::
                       _Att_As cc c1 :: nil))) :: nil)
    (* where *) (_Sql_Atom (_Sql_True db))
    (* groupby *) _Group_Fine
    (* having *) (_Sql_Atom (_Sql_True db)).

Definition eval_sql7 := eval_sql_query_in_state (sql7 db4).
Eval vm_compute in (show_tuples eval_sql7).

(** select * from table1 as t1 where t1.a < 4*)
Definition sql8 db :=
  _Sql_Select
    (* select *) _Select_Star
    (* from *) ((_From_Item (_Sql_Table table1) _Att_Ren_Star) :: nil)
    (* where *) (_Sql_Atom
                   (_Sql_Pred db (Predicate "<")
                              (_Sql_Dot aa :: CstN 4 :: nil)))
    (* groupby *) _Group_Fine
    (* having *) (_Sql_Atom (_Sql_True db)).

Definition eval_sql8 := eval_sql_query_in_state (sql8 db4).
Eval vm_compute in (show_tuples eval_sql8).

(** select * from table1 as t1 where t1.a > 4*)

Definition sql9 db :=
  _Sql_Select
    (* select *) _Select_Star
    (* from *) ((_From_Item (_Sql_Table table1) _Att_Ren_Star) :: nil)
    (* where *) (_Sql_Atom
                   (_Sql_Pred db (Predicate ">")
                              (_Sql_Dot aa :: CstN 4 :: nil)))
    (* groupby *) _Group_Fine
    (* having *) (_Sql_Atom (_Sql_True db)).

Definition eval_sql9 := eval_sql_query_in_state (sql9 db4).
Eval vm_compute in (show_tuples eval_sql9).

(** select * from table1 as t1 where t1.a = 4*)
Definition sql10 db :=
  _Sql_Select
    (* select *) _Select_Star
    (* from *) ((_From_Item (_Sql_Table table1) _Att_Ren_Star) :: nil)
    (* where *) (_Sql_Atom
                   (_Sql_Pred db (Predicate "=")
                              (_Sql_Dot aa :: CstN 4 :: nil)))
    (* groupby *) _Group_Fine
    (* having *) (_Sql_Atom (_Sql_True db)).

Definition eval_sql10 := eval_sql_query_in_state (sql10 db4).
Eval vm_compute in (show_tuples eval_sql10).

(** select * from table1 as t1 where t1.a <> 4*)

Definition sql11 db :=
  _Sql_Select
    (* select *) _Select_Star
    (* from *) ((_From_Item (_Sql_Table table1) _Att_Ren_Star) :: nil)
    (* where *) (_Sql_Not
                   (_Sql_Atom
                   (_Sql_Pred db (Predicate "=")
                              (_Sql_Dot aa :: CstN 4 :: nil))))
    (* groupby *) _Group_Fine
    (* having *) (_Sql_Atom (_Sql_True db)).

Definition eval_sql11 := eval_sql_query_in_state (sql11 db4).
Eval vm_compute in (show_tuples eval_sql11).

(** select * from table1 as t1 where t1.a < 4 or t1.a >= 7*)
Definition sql12 db :=
  _Sql_Select
    (* select *) _Select_Star
    (* from *) ((_From_Item (_Sql_Table table1) _Att_Ren_Star) :: nil)
    (* where *) (_Sql_Conj Or_F
                   (_Sql_Atom
                   (_Sql_Pred db (Predicate "<")
                              (_Sql_Dot aa :: CstN 4 :: nil)))
                   (_Sql_Atom
                   (_Sql_Pred db (Predicate ">=")
                              (_Sql_Dot aa :: CstN 7 :: nil))))
    (* groupby *) _Group_Fine
    (* having *) (_Sql_Atom (_Sql_True db)).

Definition eval_sql12 := eval_sql_query_in_state (sql12 db4).
Eval vm_compute in (show_tuples eval_sql12).

(** select * from table1 where 2 * a < 12 *)
Definition sql13 db :=
  _Sql_Select
    (* select *) _Select_Star
    (* from *) ((_From_Item (_Sql_Table table1) _Att_Ren_Star) :: nil)
    (* where *) (_Sql_Atom
                   (_Sql_Pred db (Predicate "<")
                              (_A_Expr (((_F_Expr (Symbol "mult"))
                                     (_CstN 2 :: __Sql_Dot aa :: nil))) ::
                              (CstN 12) :: nil)))
    (* groupby *) _Group_Fine
    (* having *) (_Sql_Atom (_Sql_True db)).

Definition eval_sql13 := eval_sql_query_in_state (sql13 db4).

Eval vm_compute in (show_tuples eval_sql13).

Notation a_plus_b :=
  (_A_Expr ((_F_Expr (Symbol "plus")) ((__Sql_Dot a) :: (__Sql_Dot b) :: nil))).

Notation a0_plus_c1 :=
  (_A_Expr ((_F_Expr (Symbol "plus")) ((__Sql_Dot a0) :: (__Sql_Dot c1) :: nil))).

Notation rho0 := (Att_Ren_List ((Att_As T a a0) :: (Att_As T b b0) ::  (Att_As T c c0) ::  nil)).
Notation rho1 := (Att_Ren_List ((Att_As T a a1) :: (Att_As T b b1) ::  (Att_As T c c1) ::  nil)).

(** select * from from tbl1[[*]] where (a+b) >= all (select (a0 + c1) as a0_plus_c1 from tbl0[[rho0]], tbl1[[rho1]]) *)
Definition sql17 db :=
  _Sql_Select
    (* select *) _Select_Star
    (* from *) ((_From_Item (_Sql_Table table1) _Att_Ren_Star) :: nil)
    (* where *) (_Sql_Atom
                   (_Sql_Quant
                      Forall_F (db := db)
                      (Predicate ">=") (a_plus_b :: nil)
                      (_Sql_Select
                         (_Select_List (_Select_As a0_plus_c1 (Attr_N 0 "a0_plus_c1") :: nil))
                         (_From_Item (_Sql_Table table0) rho0 ::
                                     _From_Item  (_Sql_Table table1) rho1 :: nil)
                         (_Sql_Atom (_Sql_True db))
                         _Group_Fine
                         (_Sql_Atom (_Sql_True db)))))
    (* groupby *) _Group_Fine
    (* having *) (_Sql_Atom (_Sql_True db)).

End Try.


Require Import compcert.lib.Axioms.
Require Import compcert.lib.Maps.
(* Require Export compcert.lib.Coqlib. *)

Require Import concurrency.sepcomp. Import SepComp.

Require Import concurrency.pos.
Require Import concurrency.scheduler.
Require Import concurrency.TheSchedule.
Require Import concurrency.konig.
Require Import concurrency.addressFiniteMap. (*The finite maps*)
Require Import concurrency.pos.
Require Import concurrency.lksize.
Require Import concurrency.permjoin_def.
Require Import Coq.Program.Program.
From mathcomp.ssreflect Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype finfun.
Set Implicit Arguments.

Require Import concurrency.ssromega. (*omega in ssrnat *)

Require Import Coq.ZArith.ZArith.

Require Import concurrency.permissions.
Require Import concurrency.threadPool.

Require Import compcert.common.Memory. (*for Mem.perm_order'' *)
Set Bullet Behavior "Strict Subproofs".

Definition map_leq {A B} (m1: PTree.t A)(m2: PTree.t B): Prop :=
  forall p, m1 ! p -> m2 ! p.

Lemma map_leq_apply:
  forall {A B} (m1: PTree.t A)(m2: PTree.t B) p f1,
    map_leq m1 m2 ->
    m1 ! p = Some f1 -> exists f2, m2 ! p = Some f2.
Proof.
  move => A B m1 m2 p f1.
  rewrite /map_leq => /(_ p) Mle AA.
  rewrite AA in Mle. specialize (Mle ltac:(auto)).
  destruct (m2 ! p) as [f2|]; try solve[inversion Mle].
  exists f2; auto.
Qed.

Lemma treemap_sub_map: forall {A B} (f: positive -> B -> A) m2,
    map_leq (PTree.map f m2) m2.
Proof.
  move => A B f m2 p.
  rewrite PTree.gmap.
  destruct (m2 ! p) eqn:m2p; auto; intros HH; inversion HH.
Qed.

Definition map_empty_def {A} (m1: PMap.t (Z -> option A)):=
  m1.1 = fun _ => None.

Definition fun_leq' {A B} (f1: Z -> option A) (f2: Z -> option B): Prop :=
  forall p, f1 p -> f2 p.

Definition fun_leq {A B} (o1: option (Z -> option A)) (o2: option (Z -> option B)): Prop :=
  match o1, o2 with
  | Some f1, Some f2 => fun_leq' f1 f2
  | None, None => True
  | _, _ => False
  end.

Definition option_eq {A B} (a:option A) (b: option B): Prop :=
  match a, b with
  | Some _ , Some _ => True
  | None, None => True
  | _, _ => False
  end.

Definition bounded_nat_func_aux {A} (f: nat -> option A) hi: Prop :=
  (forall p, (p >= hi )%nat -> f p = None).

Definition bounded_nat_func' {A} (f: nat -> option A) hi: Prop :=
  (forall p, (p > hi )%nat -> f p = None).

Definition bounded_func' {A} (f: Z -> option A) hi lo: Prop :=
  (forall p, (p > hi )%Z -> f p = None) /\
  (forall p, (p < lo)%Z -> f p = None).

Definition bounded_func_op {A} (f: option (Z -> option A)) hi lo: Prop :=
  match f with
  | Some f' => bounded_func' f' hi lo
  | None => True
  end.

Definition bounded_func {A} (f: Z -> option A): Prop :=
  exists hi lo,
  bounded_func' f hi lo.

Definition bounded_map {A} (m: PTree.t (Z -> option A)):=
  forall p f, m ! p = Some f -> bounded_func f.

Fixpoint strong_tree_leq {A B}
         (t1: PTree.t A) (t2: PTree.t B)
         (leq: option A -> option B -> Prop):=
  match t1, t2 with
  | PTree.Leaf, PTree.Leaf => True
  | PTree.Node l1 o1 r1, PTree.Node l2 o2 r2 =>
    leq o1 o2 /\
    strong_tree_leq l1 l2 leq /\
    strong_tree_leq r1 r2 leq
  | _, _ => False
  end.

Definition same_shape {A B} (m1: PTree.t (Z -> option A))(m2: PTree.t (Z -> option B)):=
  strong_tree_leq m1 m2 option_eq.

Definition sub_map' {A B} (m1: PTree.t (Z -> option A))(m2: PTree.t (Z -> option B)):=
  forall p f1, m1 ! p = Some f1 ->
          exists f2, m2 ! p = Some f2 /\ fun_leq' f1 f2.

Definition sub_map {A B} (m1: PTree.t (Z -> option A))(m2: PTree.t (Z -> option B)):=
  strong_tree_leq m1 m2 fun_leq.

Lemma sub_map_and_shape:
  forall { A B} m1 m2,
  @same_shape A B m1 m2 ->
  sub_map' m1 m2 ->
  sub_map m1 m2.
Proof.
  induction m1.
  - intros.
    destruct m2; inversion H.
    auto.
  - intros.
    rewrite /sub_map /=.
    destruct m2; try inversion H.
    split; [|split].
    + destruct o as [o|].
      2: destruct o0; inversion H1; auto.
      specialize (H0 1%positive o ltac:(auto)).
      destruct o0; try solve [inversion H1].
      destruct H0 as [f [ISo LEQ]].
      inversion ISo.
      auto.
    + destruct H as [AA [BB CC]].
      eapply IHm1_1; eauto.
      move => b f HH.
      move: H0 => /(_  (b~0)%positive f HH) //.
    + destruct H as [AA [BB CC]].
      eapply IHm1_2; eauto.
      move => b f HH.
      move: H0 => /(_  (b~1)%positive f HH) //.
Qed.

Definition nat_to_perm (i:nat) :=
  (match i with
  | 0 => Some None
  | 1 => Some (Some Nonempty)
  | 2 => Some (Some Readable)
  | 3 => Some (Some Writable)
  | 4 => Some (Some Freeable)
  | _ => None
  end)%nat.

Definition perm_to_nat (p: option (option permission)) :=
  match p with
  | Some (None) => 0
  | Some (Some Nonempty) => 1
  | Some (Some Readable) => 2
  | Some (Some Writable) => 3
  | Some (Some Freeable) => 4
  | None => 5
  end.

Definition nat_to_perm_simpl (i:nat) :=
  (match i with
  | 0 => None
  | 1 => Some Nonempty
  | 2 => Some Readable
  | 3 => Some Writable
  | 4 => Some Freeable
  | _ => None
  end)%nat.

Definition perm_to_nat_simpl (p: option permission) :=
  match p with
  | None => 0
  | Some Nonempty => 1
  | Some Readable => 2
  | Some Writable => 3
  | Some Freeable => 4
  end.
Lemma perm_to_nat_bound:
  forall p,
    perm_to_nat p < 6.
Proof.
  intros p.
  destruct p as [p|];
    try destruct p as [p|]; try destruct p; compute; auto.
Qed.

Lemma perm_to_nat_bound_simpl:
  forall p,
    perm_to_nat_simpl p < 5.
Proof.
  intros p.
  destruct p as [p|];
    try destruct p; compute; auto.
Qed.

Lemma nat_to_perm_perm_to_nat:
  forall p,
    nat_to_perm (perm_to_nat p) = p.
Proof.
  intros p.
  destruct p as [p|];
    try destruct p as [p|];
    try destruct p;
    reflexivity.
Qed.

Lemma nat_to_perm_perm_to_nat_simpl:
  forall p,
    nat_to_perm_simpl (perm_to_nat_simpl p) = p.
Proof.
  intros p.
  destruct p as [p|];
    try destruct p;
    reflexivity.
Qed.

Lemma finite_bounded_nat_aux_func:
  forall hi ,
    konig.finite
      ( fun f:nat -> option (option permission) => bounded_nat_func_aux f hi).
Proof.

   intros hi.
   pose (K:= perm_to_nat).
   induction hi.
   - exists 1%nat.
     exists (fun x _ => None).
     intros.
     exists 0%nat.
     split; auto.

     extensionality b.
     symmetry.
     apply H.
     apply /leP. omega.

   - destruct IHhi as [N [FN H]].
     exists (6*N)%nat.
     exists (fun x i => if (Nat.eq_dec i hi) then
                       nat_to_perm (Nat.modulo x 6)
                else FN (Nat.div x 6) i).
     move=> f HH.
     specialize (H (fun n => if (Nat.eq_dec n hi) then
                            None
                          else f n) ).
     destruct H as [i [ineq f_spec]].
     + intros pp pphi.
       destruct (Nat.eq_dec pp hi).
       * auto.
       * simpl; eapply HH.
         move: pphi=> /leP pphi.
         apply /ltP.
         omega.

     + exists ((6 * i) + (perm_to_nat (f hi))).
       split.
       * replace (6 * N) with
         (6 * (N - 1) + 6 ).
         { eapply (NPeano.Nat.lt_le_trans _ (6 * i  + 6)).
           - apply /leP.
             rewrite ltn_add2l.
             destruct (f hi) as [p|];
               [destruct p; try destruct p|]; simpl; apply /leP; try omega.
           - apply /leP.
             rewrite leq_add2r.
             rewrite leq_pmul2l.
             + apply / leP. clear -ineq.
               replace N with (S (N - 1)) in ineq.
               apply /leP.
               by rewrite - ltnS; apply /leP.
               rewrite -addn1.
               apply subnK.
               destruct N; apply /ltP; try omega.
             + compute; auto.
         }
         rewrite - mulnSr.
         replace (N -1).+1 with N; auto.
         rewrite -addn1.
         symmetry; apply subnK.
         destruct N; apply /ltP; try omega.
       * { extensionality i0.
           destruct (Nat.eq_dec i0 hi).
           - subst.
             rewrite addnC.
             rewrite mulnC.
             rewrite NPeano.Nat.mod_add; try omega.
             rewrite NPeano.Nat.mod_small;
               try (apply /ltP; eapply perm_to_nat_bound).
             rewrite nat_to_perm_perm_to_nat.
             reflexivity.

           - replace ((6 * i + perm_to_nat (f hi)) / 6) with i.
             + rewrite f_spec.
               simpl.
               destruct (Nat.eq_dec i0 hi);
                 try solve [exfalso; apply n; auto].
               reflexivity.
             + eapply NPeano.Nat.div_unique;
               try (apply /ltP; eapply perm_to_nat_bound).
               reflexivity.
         }
Qed.

Lemma finite_bounded_nat_aux_func_simpl:
  forall hi ,
    konig.finite
      ( fun f:nat -> option permission => bounded_nat_func_aux f hi).
Proof.

   intros hi.
   pose (K:= perm_to_nat_simpl).
   induction hi.
   - exists 1%nat.
     exists (fun x _ => None).
     intros.
     exists 0%nat.
     split; auto.

     extensionality b.
     symmetry.
     apply H.
     apply /leP. omega.

   - destruct IHhi as [N [FN H]].
     exists (5*N)%nat.
     exists (fun x i => if (Nat.eq_dec i hi) then
                       nat_to_perm_simpl (Nat.modulo x 5)
                else FN (Nat.div x 5) i).
     move=> f HH.
     specialize (H (fun n => if (Nat.eq_dec n hi) then
                            None
                          else f n) ).
     destruct H as [i [ineq f_spec]].
     + intros pp pphi.
       destruct (Nat.eq_dec pp hi).
       * auto.
       * simpl; eapply HH.
         move: pphi=> /leP pphi.
         apply /ltP.
         omega.

     + exists ((5 * i) + (perm_to_nat_simpl (f hi))).
       split.
       * replace (5 * N) with
         (5 * (N - 1) + 5 ).
         { eapply (NPeano.Nat.lt_le_trans _ (5 * i  + 5)).
           - apply /leP.
             rewrite ltn_add2l.
             destruct (f hi) as [p|]; [destruct p|]; simpl; apply /leP; try omega.
           - apply /leP.
             rewrite leq_add2r.
             rewrite leq_pmul2l.
             + apply / leP. clear -ineq.
               replace N with (S (N - 1)) in ineq.
               apply /leP.
               by rewrite - ltnS; apply /leP.
               rewrite -addn1.
               apply subnK.
               destruct N; apply /ltP; try omega.
             + compute; auto.
         }
         rewrite - mulnSr.
         replace (N -1).+1 with N; auto.
         rewrite -addn1.
         symmetry; apply subnK.
         destruct N; apply /ltP; try omega.
       * { extensionality i0.
           destruct (Nat.eq_dec i0 hi).
           - subst.
             rewrite addnC.
             rewrite mulnC.
             rewrite NPeano.Nat.mod_add; try omega.
             rewrite NPeano.Nat.mod_small;
               try (apply /ltP; eapply perm_to_nat_bound_simpl).
             rewrite nat_to_perm_perm_to_nat_simpl.
             reflexivity.

           - replace ((5 * i + perm_to_nat_simpl (f hi)) / 5) with i.
             + rewrite f_spec.
               simpl.
               destruct (Nat.eq_dec i0 hi);
                 try solve [exfalso; apply n; auto].
               reflexivity.
             + eapply NPeano.Nat.div_unique;
               try (apply /ltP; eapply perm_to_nat_bound_simpl).
               reflexivity.
         }
Qed.

Lemma finite_bounded_nat_func:
  forall hi ,
    konig.finite
      ( fun f:nat -> option (option permission) => bounded_nat_func' f hi).
Proof.
  intros.
  destruct (finite_bounded_nat_aux_func (S hi)) as [x [f HH]].
  exists x, f.
  move=> x0 BND.
  cut (bounded_nat_func_aux x0 hi.+1).
  Focus 2. { intros b ineq; eapply BND; auto. } Unfocus.
  move=> /HH [] i [] A B.
  exists i; split; eauto.
Qed.

Lemma finite_bounded_nat_func_simpl:
  forall hi ,
    konig.finite
      ( fun f:nat -> option permission => bounded_nat_func' f hi).
Proof.
  intros.
  destruct (finite_bounded_nat_aux_func_simpl (S hi)) as [x [f HH]].
  exists x, f.
  move=> x0 BND.
  cut (bounded_nat_func_aux x0 hi.+1).
  Focus 2. { intros b ineq; eapply BND; auto. } Unfocus.
  move=> /HH [] i [] A B.
  exists i; split; eauto.
Qed.

Lemma finite_bounded_func:
  forall hi lo,
    konig.finite
      ( fun f:Z -> option (option permission) => bounded_func' f hi lo).
Proof.
  intros hi lo.
  destruct (Coqlib.zlt hi lo).
  - exists 1%N.
    exists (fun _ _ => None).
    intros.
    exists 0%nat; split; auto.
    extensionality b.
    destruct H as[H1 H2].
    symmetry.
    destruct (Coqlib.zle b hi).
    + eapply H2.
      eapply Z.le_lt_trans; eauto.
    + eapply H1; assumption.
  - assert (0 <= hi - lo)%Z by omega.
    pose (n:= Z.to_nat (hi - lo)).
    destruct (finite_bounded_nat_func n) as [N [FN HN]].
    exists N.
    exists (fun n z => (if (Z_lt_ge_dec z lo)
                then None
                else FN n (Z.to_nat (z-lo)))).
    intros f [BOUND1 BOUND2].
    pose (f':= fun n => f (Z.of_nat n + lo)%Z).
    assert (bounded_nat_func' f' n).
    { intros b ineq.
      unfold f'.
      eapply BOUND1.
      unfold n in ineq.
      cut (Z.of_nat b > hi - lo)%Z.
      omega.
      move: ineq => /ltP /inj_lt /Z.gt_lt_iff.
      rewrite Z2Nat.id => //.
    }
    apply HN in H0.
    destruct H0 as [i [ineq FN_spec]].
    exists i; split; auto.
    extensionality z.
    rewrite FN_spec.
    unfold f'.
    destruct (Z_lt_ge_dec z lo).
    + simpl.
      symmetry.
        by apply BOUND2.
    + simpl.
      rewrite Z2Nat.id.
      * f_equal; omega.
      * omega.
Qed.

Lemma finite_bounded_func_simpl:
  forall hi lo,
    konig.finite
      ( fun f:Z -> option permission => bounded_func' f hi lo).
Proof.
  intros hi lo.
  destruct (Coqlib.zlt hi lo).
  - exists 1%N.
    exists (fun _ _ => None).
    intros.
    exists 0%nat; split; auto.
    extensionality b.
    destruct H as[H1 H2].
    symmetry.
    destruct (Coqlib.zle b hi).
    + eapply H2.
      eapply Z.le_lt_trans; eauto.
    + eapply H1; assumption.
  - assert (0 <= hi - lo)%Z by omega.
    pose (n:= Z.to_nat (hi - lo)).
    destruct (finite_bounded_nat_func_simpl n) as [N [FN HN]].
    exists N.
    exists (fun n z => (if (Z_lt_ge_dec z lo)
                then None
                else FN n (Z.to_nat (z-lo)))).
    intros f [BOUND1 BOUND2].
    pose (f':= fun n => f (Z.of_nat n + lo)%Z).
    assert (bounded_nat_func' f' n).
    { intros b ineq.
      unfold f'.
      eapply BOUND1.
      unfold n in ineq.
      cut (Z.of_nat b > hi - lo)%Z.
      omega.
      move: ineq => /ltP /inj_lt /Z.gt_lt_iff.
      rewrite Z2Nat.id => //.
    }
    apply HN in H0.
    destruct H0 as [i [ineq FN_spec]].
    exists i; split; auto.
    extensionality z.
    rewrite FN_spec.
    unfold f'.
    destruct (Z_lt_ge_dec z lo).
    + simpl.
      symmetry.
        by apply BOUND2.
    + simpl.
      rewrite Z2Nat.id.
      * f_equal; omega.
      * omega.
Qed.

Lemma finite_bounded_op_func_simpl:
  forall hi lo,
    konig.finite
      ( fun f: option (Z -> option permission) => bounded_func_op f hi lo).
Proof.
  move => hi lo.
  move: (finite_bounded_func_simpl hi lo) => [] N [] FN FN_spec.

  exists (S N).
  exists (fun n => if n == 0 then None
           else Some (FN (n -1)) ).
  move => f H.
  destruct f.
  - move: FN_spec => /(_ _ H) [] i [] ineqi speci.
    exists (S i); split.
    + omega.
    + rewrite - speci.
      simpl; repeat f_equal.
      rewrite - addn1 - addnBA=> //.
  - exists 0; split; auto.
    + omega.
Qed.

Lemma finite_bounded_op_func:
  forall hi lo,
    konig.finite
      ( fun f: option (Z -> option (option permission)) => bounded_func_op f hi lo).
Proof.
  move => hi lo.
  move: (finite_bounded_func hi lo) => [] N [] FN FN_spec.

  exists (S N).
  exists (fun n => if n == 0 then None
           else Some (FN (n -1)) ).
  move => f H.
  destruct f.
  - move: FN_spec => /(_ _ H) [] i [] ineqi speci.
    exists (S i); split.
    + omega.
    + rewrite - speci.
      simpl; repeat f_equal.
      rewrite - addn1 - addnBA=> //.
  - exists 0; split; auto.
    + omega.
Qed.

Lemma finite_sub_maps:
  forall m2,
    @bounded_map permission m2 ->
    konig.finite
      (fun m1 => @sub_map (option permission) permission m1 m2).
Proof.
  induction m2.
  - move => _.
    exists 1%nat.
    exists (fun _ => PTree.Leaf).
    intros .
    exists 0%nat.
    split; auto.
    destruct x; auto.
    unfold strong_tree_leq in H;
      simpl in H.
    destruct o; inversion H.
  - move => H.
    assert (HH1:
              forall (p : positive) (f : Z -> option permission),
                m2_1 ! p = Some f ->
                exists hi lo : Z,
                  (forall p0 : Z, (p0 > hi)%Z -> f p0 = None) /\
                  (forall p0 : Z, (p0 < lo)%Z -> f p0 = None)).
    { clear - H.
      move=> p f Hget.
      move : H => /(_ (p~0)%positive f ltac:(simpl;auto)) [] hi [] lo BOUND.
      exists hi, lo; assumption.
    }
    move: IHm2_1=> /(_ HH1) [] N1 [] F1 spec_F1.
    assert (HH2:
              forall (p : positive) (f : Z -> option permission),
                m2_2 ! p = Some f ->
                exists hi lo : Z,
                  (forall p0 : Z, (p0 > hi)%Z -> f p0 = None) /\
                  (forall p0 : Z, (p0 < lo)%Z -> f p0 = None)).
    { clear - H.
      move=> p f Hget.
      move : H => /(_ (p~1)%positive f ltac:(simpl;auto)) [] hi [] lo BOUND.
      exists hi, lo; assumption.
    }
    move: IHm2_2=> /(_ HH2) [] N2 [] F2 spec_F2.
    destruct o as [f1|].
    + move : H => /(_ 1%positive f1 ltac:(reflexivity)) [] hi [] lo BNDD.
      move : (finite_bounded_op_func hi lo) => [] N [] F F_spec.
      exists (S( N * N1 * N2)).
      exists (fun n => if n == 0
               then PTree.Leaf
               else
                 PTree.Node
                   (F1 ( (n-1) mod N1))
                   (F ((n-1) / (N1 * N2)))
                   (F2 (((n-1) / N1 ) mod N2))).
      intros x spec.
      destruct x.
      * exists 0%nat; split; auto.
        omega.
      * move: spec .
        rewrite /sub_map /= => [] [] FUN_lq [] tree1 tree2.
        assert (bounded_func_op o hi lo).
        { Lemma fun_le_bounded_func_op:
            forall {A} o f hi lo,
              @bounded_func' A f hi lo ->
              fun_leq o (Some f) ->
              @bounded_func_op (option A) o hi lo.
          Proof.
            intros.
            destruct o; [|constructor].
            simpl.
            simpl in H0.
            split; intros p.
            - intros HH. apply H in HH.
              unfold fun_leq' in H0.
              specialize (H0 p).
              destruct (o p); try solve [auto].
              specialize (H0 ltac:(auto)).
              rewrite HH in H0; inversion H0.
            - intros HH. apply H in HH.
              unfold fun_leq' in H0.
              specialize (H0 p).
              destruct (o p); try solve [auto].
              specialize (H0 ltac:(auto)).
              rewrite HH in H0; inversion H0.
          Qed.
          eapply fun_le_bounded_func_op ; eauto.
          }
        move: F_spec => /(_ _ H) []i [] ineq fi.
        move : spec_F1 => /(_ _ tree1) [] i1 [] ineq1 fi1.
        move : spec_F2 => /(_ _ tree2) [] i2 [] ineq2 fi2.
        exists (S(i1 + (i2 * N1) + (i * N1 * N2))); split.
        { apply lt_n_S.
          replace (N * N1 * N2) with
          (N1 + N1 * (N2 * N -1)).
          - eapply (NPeano.Nat.lt_le_trans).
            + instantiate (1:= (N1 + i2 * N1 + i * N1 * N2)).
              apply /ltP.
              rewrite ltn_add2r;
                rewrite ltn_add2r;
                apply /ltP; auto.
            + apply /leP.
              rewrite -addnA.
              rewrite leq_add2l.
              apply /leP.
              replace (i * N1 * N2) with
              ((i * N2) * N1).
              *
                rewrite -mulnDl.
                rewrite mulnC.
                apply /leP.
                rewrite leq_pmul2l; try (apply /ltP; omega).
                apply /leP.
                eapply lt_n_Sm_le.
                rewrite - addn1.
                rewrite subnK.
                2:
                  rewrite muln_gt0;
                  apply /andP; split;
                  try (apply /ltP; omega).
                eapply (NPeano.Nat.lt_le_trans).
                -- instantiate (1:= N2 + i * N2).
                   apply /ltP.
                   rewrite ltn_add2r.
                   apply /leP; auto.
                -- replace (N2 + i * N2) with
                   (N2 * (1 + i)).
                   apply /leP.
                   rewrite leq_pmul2l.
                   rewrite add1n.
                   apply /ltP; auto.
                   apply /ltP; omega.
                   rewrite mulnDr.
                   rewrite mulnC.
                   f_equal.
                   compute; auto.
                   rewrite mulnC; auto.
              * do 2 rewrite - mulnA.
                f_equal. rewrite mulnC; auto.
          - replace (N1 + N1 * (N2 * N - 1))
            with (N1 * 1 + N1 * (N2 * N - 1)).
            + rewrite -mulnDr.
              rewrite addnC.
              rewrite subnK.

              2:
                rewrite muln_gt0;
                apply /andP; split;
                try (apply /ltP; omega).
              rewrite -mulnA.
              rewrite mulnA.
              rewrite mulnC; auto.
            + f_equal.
              rewrite mulnC.
              compute; auto. }
      -- simpl; f_equal.
         ++ rewrite - fi1.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2 + (1 - 1)) with
            (i1 + i2 * N1 + i * N1 * N2) by ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2) with
            (i1 + (i2  + i *  N2) * N1).
            2:
            rewrite mulnDl addnA; f_equal;
            do 2 rewrite -mulnA; f_equal; rewrite mulnC; auto.
            rewrite NPeano.Nat.mod_add.
            apply NPeano.Nat.mod_small; auto.
            destruct N1; omega.
         ++ rewrite - fi.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2 + (1 - 1)) with
            (i1 + i2 * N1 + i * N1 * N2) by ssromega.
            assert (i1 + i2 * N1 + i * N1 * N2 =
                    ((N1 * N2) * i) + (i1 + i2 * N1)).
            { rewrite addnC. f_equal.
              rewrite - mulnA mulnC; auto. }
            eapply NPeano.Nat.div_unique in H0; auto.
            eapply (NPeano.Nat.lt_le_trans).
            ** instantiate (1:= N1 + i2 * N1).
               apply /ltP; rewrite ltn_add2r.
               apply /ltP; auto.
            ** replace (N1 + i2 * N1) with ( (1 + i2) * N1).
               rewrite add1n.
               rewrite mulnC.
               apply /leP; rewrite leq_pmul2l.
               apply /ltP; auto.
               destruct N1; ssromega.
               rewrite mulnDl; f_equal.
               ssromega.

         ++ rewrite - fi2.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2 + (1 - 1)) with
            (i1 + i2 * N1 + i * N1 * N2) by ssromega.
            assert (i1 + i2 * N1 + i * N1 * N2 =
                    (N1 * (i2 + i * N2)) + i1).
            { rewrite -addnA.
              replace (i * N1 * N2) with
              (i  * N2 * N1).
              rewrite - mulnDl.
              rewrite mulnC addnC; auto.
              do 2 rewrite -mulnA; f_equal.
              rewrite mulnC. auto. }
            eapply NPeano.Nat.div_unique in H0; auto.
            rewrite - H0.
            rewrite NPeano.Nat.mod_add.
            apply NPeano.Nat.mod_small; auto.
            destruct N2; omega.
    + exists (S( N1 * N2)).
      exists (fun n => if n == 0
               then PTree.Leaf
               else
                 PTree.Node
                   (F1 ( (n-1) mod N1))
                   (None )
                   (F2 (((n-1) / N1 ) mod N2))).
      intros x spec.
      destruct x.
      * exists 0%nat; split; auto.
        omega.
      * move: spec .
        rewrite /sub_map /= => [] [] FUN_lq [] tree1 tree2.
        move : spec_F1 => /(_ _ tree1) [] i1 [] ineq1 fi1.
        move : spec_F2 => /(_ _ tree2) [] i2 [] ineq2 fi2.
        exists (S(i1 + (i2 * N1))); split.
        { apply lt_n_S.
          replace (N1 * N2) with
          (N1 + N1 * (N2 -1)).
          - eapply (NPeano.Nat.lt_le_trans).
            + instantiate (1:= (N1 + i2 * N1)).
              apply /ltP.
              rewrite ltn_add2r;
                apply /ltP; auto.
            + apply /leP.
              rewrite leq_add2l.
              apply /leP.
              rewrite mulnC.
              apply /leP.
              rewrite leq_pmul2l; try (apply /ltP; omega).
              apply /leP.
              eapply lt_n_Sm_le.
              rewrite - addn1.
              rewrite subnK; auto.
              destruct N2; ssromega.

          - replace (N1 + N1 * (N2 - 1))
            with (N1 * 1 + N1 * (N2 - 1)).
            + rewrite -mulnDr.
              rewrite addnC.
              rewrite subnK.
              2: ssromega.
              rewrite mulnC; auto.
            + f_equal.
              rewrite mulnC.
              compute; auto. }
      -- simpl; f_equal.
         ++ rewrite - fi1.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + (1 - 1)) with
            (i1 + i2 * N1) by ssromega.
            rewrite NPeano.Nat.mod_add.
            apply NPeano.Nat.mod_small; auto.
            destruct N1; omega.
         ++ destruct o; auto; inversion FUN_lq.
         ++ rewrite - fi2.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + (1 - 1)) with
            (i1 + i2 * N1 ) by ssromega.
            assert (i1 + i2 * N1 =
                    (N1 * (i2) + i1)).
            { rewrite mulnC addnC; auto. }
            eapply NPeano.Nat.div_unique in H0; auto.
            rewrite - H0.
            apply NPeano.Nat.mod_small; auto.
Qed.

Lemma finite_sub_maps_simpl:
  forall m2,
    @bounded_map permission m2 ->
    konig.finite
      (fun m1 => @sub_map permission permission m1 m2).
Proof.

  induction m2.
  - move => _.
    exists 1%nat.
    exists (fun _ => PTree.Leaf).
    intros .
    exists 0%nat.
    split; auto.
    destruct x; auto.
    unfold strong_tree_leq in H;
      simpl in H.
    destruct o; inversion H.
  - move => H.
    assert (HH1:
              forall (p : positive) (f : Z -> option permission),
                m2_1 ! p = Some f ->
                exists hi lo : Z,
                  (forall p0 : Z, (p0 > hi)%Z -> f p0 = None) /\
                  (forall p0 : Z, (p0 < lo)%Z -> f p0 = None)).
    { clear - H.
      move=> p f Hget.
      move : H => /(_ (p~0)%positive f ltac:(simpl;auto)) [] hi [] lo BOUND.
      exists hi, lo; assumption.
    }
    move: IHm2_1=> /(_ HH1) [] N1 [] F1 spec_F1.
    assert (HH2:
              forall (p : positive) (f : Z -> option permission),
                m2_2 ! p = Some f ->
                exists hi lo : Z,
                  (forall p0 : Z, (p0 > hi)%Z -> f p0 = None) /\
                  (forall p0 : Z, (p0 < lo)%Z -> f p0 = None)).
    { clear - H.
      move=> p f Hget.
      move : H => /(_ (p~1)%positive f ltac:(simpl;auto)) [] hi [] lo BOUND.
      exists hi, lo; assumption.
    }
    move: IHm2_2=> /(_ HH2) [] N2 [] F2 spec_F2.
    destruct o as [f1|].
    + move : H => /(_ 1%positive f1 ltac:(reflexivity)) [] hi [] lo BNDD.
      move : (finite_bounded_op_func_simpl hi lo) => [] N [] F F_spec.
      exists (S( N * N1 * N2)).
      exists (fun n => if n == 0
               then PTree.Leaf
               else
                 PTree.Node
                   (F1 ( (n-1) mod N1))
                   (F ((n-1) / (N1 * N2)))
                   (F2 (((n-1) / N1 ) mod N2))).
      intros x spec.
      destruct x.
      * exists 0%nat; split; auto.
        omega.
      * move: spec .
        rewrite /sub_map /= => [] [] FUN_lq [] tree1 tree2.
        assert (bounded_func_op o hi lo).
        { Lemma fun_le_bounded_func_op_simpl:
            forall {A} o f hi lo,
              @bounded_func' A f hi lo ->
              fun_leq o (Some f) ->
              @bounded_func_op A o hi lo.
          Proof.
            intros.
            destruct o; [|constructor].
            simpl.
            simpl in H0.
            split; intros p.
            - intros HH. apply H in HH.
              unfold fun_leq' in H0.
              specialize (H0 p).
              destruct (o p); try solve [auto].
              specialize (H0 ltac:(auto)).
              rewrite HH in H0; inversion H0.
            - intros HH. apply H in HH.
              unfold fun_leq' in H0.
              specialize (H0 p).
              destruct (o p); try solve [auto].
              specialize (H0 ltac:(auto)).
              rewrite HH in H0; inversion H0.
          Qed.
          eapply fun_le_bounded_func_op_simpl ; eauto.
          }
        move: F_spec => /(_ _ H) []i [] ineq fi.
        move : spec_F1 => /(_ _ tree1) [] i1 [] ineq1 fi1.
        move : spec_F2 => /(_ _ tree2) [] i2 [] ineq2 fi2.
        exists (S(i1 + (i2 * N1) + (i * N1 * N2))); split.
        { apply lt_n_S.
          replace (N * N1 * N2) with
          (N1 + N1 * (N2 * N -1)).
          - eapply (NPeano.Nat.lt_le_trans).
            + instantiate (1:= (N1 + i2 * N1 + i * N1 * N2)).
              apply /ltP.
              rewrite ltn_add2r;
                rewrite ltn_add2r;
                apply /ltP; auto.
            + apply /leP.
              rewrite -addnA.
              rewrite leq_add2l.
              apply /leP.
              replace (i * N1 * N2) with
              ((i * N2) * N1).
              *
                rewrite -mulnDl.
                rewrite mulnC.
                apply /leP.
                rewrite leq_pmul2l; try (apply /ltP; omega).
                apply /leP.
                eapply lt_n_Sm_le.
                rewrite - addn1.
                rewrite subnK.
                2:
                  rewrite muln_gt0;
                  apply /andP; split;
                  try (apply /ltP; omega).
                eapply (NPeano.Nat.lt_le_trans).
                -- instantiate (1:= N2 + i * N2).
                   apply /ltP.
                   rewrite ltn_add2r.
                   apply /leP; auto.
                -- replace (N2 + i * N2) with
                   (N2 * (1 + i)).
                   apply /leP.
                   rewrite leq_pmul2l.
                   rewrite add1n.
                   apply /ltP; auto.
                   apply /ltP; omega.
                   rewrite mulnDr.
                   rewrite mulnC.
                   f_equal.
                   compute; auto.
                   rewrite mulnC; auto.
              * do 2 rewrite - mulnA.
                f_equal. rewrite mulnC; auto.
          - replace (N1 + N1 * (N2 * N - 1))
            with (N1 * 1 + N1 * (N2 * N - 1)).
            + rewrite -mulnDr.
              rewrite addnC.
              rewrite subnK.

              2:
                rewrite muln_gt0;
                apply /andP; split;
                try (apply /ltP; omega).
              rewrite -mulnA.
              rewrite mulnA.
              rewrite mulnC; auto.
            + f_equal.
              rewrite mulnC.
              compute; auto. }
      -- simpl; f_equal.
         ++ rewrite - fi1.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2 + (1 - 1)) with
            (i1 + i2 * N1 + i * N1 * N2) by ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2) with
            (i1 + (i2  + i *  N2) * N1).
            2:
            rewrite mulnDl addnA; f_equal;
            do 2 rewrite -mulnA; f_equal; rewrite mulnC; auto.
            rewrite NPeano.Nat.mod_add.
            apply NPeano.Nat.mod_small; auto.
            destruct N1; omega.
         ++ rewrite - fi.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2 + (1 - 1)) with
            (i1 + i2 * N1 + i * N1 * N2) by ssromega.
            assert (i1 + i2 * N1 + i * N1 * N2 =
                    ((N1 * N2) * i) + (i1 + i2 * N1)).
            { rewrite addnC. f_equal.
              rewrite - mulnA mulnC; auto. }
            eapply NPeano.Nat.div_unique in H0; auto.
            eapply (NPeano.Nat.lt_le_trans).
            ** instantiate (1:= N1 + i2 * N1).
               apply /ltP; rewrite ltn_add2r.
               apply /ltP; auto.
            ** replace (N1 + i2 * N1) with ( (1 + i2) * N1).
               rewrite add1n.
               rewrite mulnC.
               apply /leP; rewrite leq_pmul2l.
               apply /ltP; auto.
               destruct N1; ssromega.
               rewrite mulnDl; f_equal.
               ssromega.

         ++ rewrite - fi2.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + i * N1 * N2 + (1 - 1)) with
            (i1 + i2 * N1 + i * N1 * N2) by ssromega.
            assert (i1 + i2 * N1 + i * N1 * N2 =
                    (N1 * (i2 + i * N2)) + i1).
            { rewrite -addnA.
              replace (i * N1 * N2) with
              (i  * N2 * N1).
              rewrite - mulnDl.
              rewrite mulnC addnC; auto.
              do 2 rewrite -mulnA; f_equal.
              rewrite mulnC. auto. }
            eapply NPeano.Nat.div_unique in H0; auto.
            rewrite - H0.
            rewrite NPeano.Nat.mod_add.
            apply NPeano.Nat.mod_small; auto.
            destruct N2; omega.
    + exists (S( N1 * N2)).
      exists (fun n => if n == 0
               then PTree.Leaf
               else
                 PTree.Node
                   (F1 ( (n-1) mod N1))
                   (None )
                   (F2 (((n-1) / N1 ) mod N2))).
      intros x spec.
      destruct x.
      * exists 0%nat; split; auto.
        omega.
      * move: spec .
        rewrite /sub_map /= => [] [] FUN_lq [] tree1 tree2.
        move : spec_F1 => /(_ _ tree1) [] i1 [] ineq1 fi1.
        move : spec_F2 => /(_ _ tree2) [] i2 [] ineq2 fi2.
        exists (S(i1 + (i2 * N1))); split.
        { apply lt_n_S.
          replace (N1 * N2) with
          (N1 + N1 * (N2 -1)).
          - eapply (NPeano.Nat.lt_le_trans).
            + instantiate (1:= (N1 + i2 * N1)).
              apply /ltP.
              rewrite ltn_add2r;
                apply /ltP; auto.
            + apply /leP.
              rewrite leq_add2l.
              apply /leP.
              rewrite mulnC.
              apply /leP.
              rewrite leq_pmul2l; try (apply /ltP; omega).
              apply /leP.
              eapply lt_n_Sm_le.
              rewrite - addn1.
              rewrite subnK; auto.
              destruct N2; ssromega.

          - replace (N1 + N1 * (N2 - 1))
            with (N1 * 1 + N1 * (N2 - 1)).
            + rewrite -mulnDr.
              rewrite addnC.
              rewrite subnK.
              2: ssromega.
              rewrite mulnC; auto.
            + f_equal.
              rewrite mulnC.
              compute; auto. }
      -- simpl; f_equal.
         ++ rewrite - fi1.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + (1 - 1)) with
            (i1 + i2 * N1) by ssromega.
            rewrite NPeano.Nat.mod_add.
            apply NPeano.Nat.mod_small; auto.
            destruct N1; omega.
         ++ destruct o; auto; inversion FUN_lq.
         ++ rewrite - fi2.
            f_equal.
            rewrite -addn1.
            rewrite -addnBA. 2: ssromega.
            replace (i1 + i2 * N1 + (1 - 1)) with
            (i1 + i2 * N1 ) by ssromega.
            assert (i1 + i2 * N1 =
                    (N1 * (i2) + i1)).
            { rewrite mulnC addnC; auto. }
            eapply NPeano.Nat.div_unique in H0; auto.
            rewrite - H0.
            apply NPeano.Nat.mod_small; auto.
Qed.