(* Require Export compcert.lib.Coqlib. *)
From mathcomp.ssreflect Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype finfun.
Set Implicit Arguments.
Set Bullet Behavior "Strict Subproofs".
Set Nested Proofs Allowed.
Definition map_leq {A B} (m1: PTree.t A)(m2: PTree.t B): Prop :=
forall p, m1 ! p -> m2 ! p.
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.
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.
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.
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.

Lemma strong_tree_leq_xmap':
forall {A B} f1 f2 t (leq: option B -> option A -> Prop),
forall p,
(forall a p0,
PTree.get p0 t = Some a ->
leq (Some (f1 (PTree.prev_append p p0)%positive a))
(Some (f2 (PTree.prev_append p p0)%positive a))) ->
leq None None ->
strong_tree_leq
(@PTree.xmap A B f1 t p)
(@PTree.xmap A A f2 t p)
leq.