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

Require Import VST.concurrency.common.sepcomp. Import SepComp.

Require Import VST.concurrency.common.pos.
Require Import VST.concurrency.common.scheduler.
Require Import VST.concurrency.common.konig.
Require Import VST.concurrency.common.addressFiniteMap. (*The finite maps*)
Require Import VST.concurrency.common.pos.
Require Import VST.concurrency.common.lksize.
Require Import VST.concurrency.common.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 VST.concurrency.common.ssromega. (*omega in ssrnat *)

Require Import Coq.ZArith.ZArith.

Require Import VST.concurrency.common.permissions.
Require Import VST.concurrency.common.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).
  2:{ intros b ineq; eapply BND; auto. }
  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).
  2:{ intros b ineq; eapply BND; auto. }
  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.

Lemma fun_leq_trans: forall {A B C} f1 f2 f3, @fun_leq A B f1 f2 -> @fun_leq B C f2 f3 ->
  @fun_leq A C f1 f3.
Proof.
  unfold fun_leq, fun_leq'; destruct f1, f2, f3; auto.
Qed.

Lemma sub_map_trans: forall {A B C} m1 m2 m3, @sub_map A B m1 m2 -> @sub_map B C m2 m3 ->
  @sub_map A C m1 m3.
Proof.
  unfold sub_map; induction m1; destruct m2; intros; inversion H; destruct m3; inversion H0;
    auto; simpl in *.
  repeat split.
  - eapply fun_leq_trans; eauto.
  - apply (IHm1_1 m2_1); tauto.
  - apply (IHm1_2 m2_2); tauto.
Qed.

Lemma same_shape_map:
  forall {A B} m f,
    @same_shape A B (PTree.map f m) m.
Proof.
  intros until m.
  unfold PTree.map.
  pose (i:=1%positive); fold i.
  generalize i; clear i.
  induction m.
  - intros;
      unfold same_shape;
      simpl; auto.
  - intros;
      unfold same_shape;
      split; [| split].
    + destruct o; simpl; auto.
    + eapply IHm1.
    + eapply IHm2.
Qed.


Require Export Iron.Language.SystemF2Cap.Step.Frame.
Require Export Iron.Language.SystemF2Cap.Store.Bind.
Require Export Iron.Language.SystemF2Cap.Store.TypeB.
Require Export Iron.Language.SystemF2Cap.Store.StoreT.
Require Export Iron.Language.SystemF2Cap.Store.StoreM.
Require Export Iron.Language.SystemF2Cap.Store.StoreP.

(*******************************************************************)
(* Well formed store. *)
Inductive WfS   : stenv -> stprops -> store -> Prop :=
 | WfS_
   :  forall se sp ss
   ,  Forall ClosedT se
   -> StoreM se    ss
   -> StoreT se sp ss
   -> WfS se sp ss.
Hint Constructors WfS.

(* Well formed store and frame stack. *)
Inductive WfFS : stenv -> stprops -> store -> stack -> Prop :=
 | WfFS_
   :  forall se sp ss fs
   ,  Forall ClosedT se
   -> StoreM se ss
   -> StoreT se sp ss
   -> StoreP sp fs
   -> WfFS se sp ss fs.
Hint Constructors WfFS.

(*******************************************************************)
(* If a well formed frame stack and store is well formed,
   then the store is also well formed by itself. *)
Lemma wfFS_wfS
 :  forall se sp ss fs
 ,  WfFS   se sp ss fs
 -> WfS    se sp ss.
Proof. intros. inverts H. eauto. Qed.
Hint Resolve wfFS_wfS.

Lemma wfFS_closedT
 :  forall se sp ss fs
 ,  WfFS   se sp ss fs
 -> Forall ClosedT se.
Proof. intros. inverts H. eauto. Qed.
Hint Resolve wfFS_closedT.

Lemma wfFS_typeb
 :  forall se sp ss fs b
 ,  WfFS se sp ss fs
 -> In b ss
 -> (exists t, TypeB nil nil se sp b t).
Proof.
 intros.
 inverts H.
 eapply Forall2_exists_left; eauto.
Qed.
Hint Resolve wfFS_typeb.

(* The region handles of private regions are present in the
   store properties. *)
Lemma wfFS_fpriv_sregion
 :  forall se sp ss fs m1 p2 ts
 ,  WfFS se sp ss fs
 -> In (FPriv   m1 p2 ts) fs
 -> In (SRegion p2)    sp.
Proof. intros. inverts H. firstorder. Qed.
Hint Resolve wfFS_fpriv_sregion.

(* The length of the store enviroment is the same as the length
   of the store. We have one entry in the store environment for
   each binding in the store. *)
Lemma wfFS_storem_length
 :  forall se sp ss fs
 ,  WfFS   se sp ss fs
 -> length se = length ss.
Proof. intros. inverts H. auto. Qed.
Hint Resolve wfFS_storem_length.

(* Creating a top level private region preserves well-formedness
   of the store. *)
Lemma wfFS_push_priv_top
 :  forall se sp ss fs p2 ts
 ,  WfFS se sp ss fs
 -> WfFS se (SRegion p2 <: sp) ss (fs :> FPriv None p2 ts).
Proof. intros. inverts H. auto. Qed.
Hint Resolve wfFS_push_priv_top.

(* Creating an extension region preserves well-formedness
   of the store. *)
Lemma wfFS_push_priv_ext
 :  forall se sp ss fs p1 p2 ts
 ,  In (SRegion p1) sp
 -> WfFS  se  sp ss fs
 -> WfFS  se  (SRegion p2 <: sp) ss (fs :> FPriv (Some p1) p2 ts).
Proof.
 intros.
 inverts H0. eapply WfFS_; rip.
 unfold StoreP in *. rip.
 - inverts H0; eauto.
   inverts H4. eauto.
 - inverts H0; eauto.
   inverts H4; eauto.
Qed.
Hint Resolve wfFS_push_priv_ext.

(* Deallocating a region preserves well-formedness of the store. *)
Lemma typeB_deallocate
 :  forall ke te se sp p b t
 ,  TypeB  ke te se sp b t
 -> TypeB  ke te se sp (deallocRegion p b) t.
Proof.
 intros.
 destruct b.
 - snorm. subst.
   inverts H. eauto.
 - snorm.
Qed.

(* Deallocating bindings preserves the well typedness of the store. *)
Lemma storeT_deallocate
 :  forall se sp ss p
 ,  StoreT se sp ss
 -> StoreT se sp (map (deallocRegion p) ss).
Proof.
 intros.
 unfold StoreT in *.
 eapply Forall2_map_left.
 eapply Forall2_impl.
 - intros.
    eapply typeB_deallocate. eauto.
 - auto.
Qed.

(* Deallocating top-level region on the top of the frame stack
   preserves the well formedness of the store. *)
Lemma wfFS_region_deallocate
 :  forall se sp ss fs p ts
 ,  WfFS se sp ss (fs :> FPriv None p ts)
 -> WfFS se sp (map (deallocRegion p) ss) fs.
Proof.
 intros.
 inverts H. eapply WfFS_; rip.
 - unfold StoreM in *.
   rewrite map_length; auto.
 - eapply storeT_deallocate; auto.
 - unfold StoreP in *; snorm; eauto.
Qed.

Lemma wfFS_pop_priv_ext
 :  forall se sp ss fs p1 p2 ts
 ,  In (SRegion p1) sp
 -> WfFS se sp ss (fs :> FPriv (Some p1) p2 ts)
 -> WfFS (mergeTE p1 p2 se) sp (mergeBs p1 p2 ss) fs.
Proof.
 intros.
 inverts H0. split.
 - eapply Forall_map.
   eapply Forall_impl with (P := ClosedT).
   + intros. eapply mergeT_wfT; eauto.
   + auto.

 - unfold StoreM in *.
   unfold mergeTE.
   unfold mergeBs.
   repeat (rewrite map_length). auto.

 - unfold StoreT.
   eapply storeT_mergeB; auto.

 - eapply storeP_pop; eauto.
Qed.

(* Appending a closed store binding to the store preserves its
   well formedness. *)
Lemma wfFS_stbind_snoc
 :  forall se sp ss fs p v t
 ,  In (SRegion p) sp
 -> TypeV  nil nil se sp v t
 -> WfFS           se sp ss fs
 -> WfFS   (TRef (TRgn p) t <: se) sp
           (StValue p v <: ss) fs.
Proof.
 intros.
 inverts H1.
 eapply WfFS_; rip.
 eapply Forall_snoc; eauto.
Qed.

(* Updating bindings preserves the well formedness of the store. *)
Lemma wfFS_stbind_update
 :  forall se sp ss fs l p v t
 ,  get l se = Some (TRef (TRgn p) t)
 -> In (SRegion p) sp
 -> TypeV nil nil se sp v t
 -> WfFS se sp ss fs
 -> WfFS se sp (update l (StValue p v) ss) fs.
Proof.
 intros se sp ss fs l p v t HG HK HV HWF1.
 inverts HWF1. eapply WfFS_; rip.
 - have (length se = length ss).
   unfold StoreM.
   rewritess.
   rewrite update_length. auto.
 - unfold StoreT.
   eapply Forall2_update_right; eauto.
Qed.


From cap_machine Require Import rules_base.
From iris.base_logic Require Export invariants gen_heap.
From iris.program_logic Require Export weakestpre ectx_lifting.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import frac.

Section cap_lang_rules.
  Context `{memG Σ, regG Σ, MonRef: MonRefG (leibnizO _) CapR_rtc Σ}.
  Context `{MachineParameters}.
  Implicit Types P Q : iProp Σ.
  Implicit Types σ : ExecConf.
  Implicit Types c : cap_lang.expr.
  Implicit Types a b : Addr.
  Implicit Types r : RegName.
  Implicit Types v : cap_lang.val.
  Implicit Types w : Word.
  Implicit Types reg : gmap RegName Word.
  Implicit Types ms : gmap Addr Word.

  Inductive LoadU_failure (regs: Reg) (rdst rsrc: RegName) (offs: Z + RegName) (mem : PermMem):=
  | LoadU_fail_const z:
      regs !! rsrc = Some (inl z) ->
      LoadU_failure regs rdst rsrc offs mem
  | LoadU_fail_perm p g b e a:
      regs !! rsrc = Some (inr ((p, g), b, e, a)) ->
      isU p = false ->
      LoadU_failure regs rdst rsrc offs mem
  | LoadU_fail_offs_arg p g b e a:
      regs !! rsrc = Some (inr ((p, g), b, e, a)) ->
      isU p = true ->
      z_of_argument regs offs = None ->
      LoadU_failure regs rdst rsrc offs mem
  | LoadU_fail_verify_access p g b e a noffs:
      regs !! rsrc = Some (inr ((p, g), b, e, a)) ->
      isU p = true ->
      z_of_argument regs offs = Some noffs ->
      verify_access (LoadU_access b e a noffs) = None ->
      LoadU_failure regs rdst rsrc offs mem
  | LoadU_fail_incrementPC p g b e a noffs a' p' w:
      regs !! rsrc = Some (inr ((p, g), b, e, a)) ->
      isU p = true ->
      z_of_argument regs offs = Some noffs ->
      verify_access (LoadU_access b e a noffs) = Some a' ->
      mem !! a' = Some(p', w) →
      incrementPC (<[ rdst := w ]> regs) = None ->
      LoadU_failure regs rdst rsrc offs mem.

  Inductive LoadU_spec
    (regs: Reg) (rdst rsrc: RegName) (offs: Z + RegName)
    (regs': Reg) (mem : PermMem) : cap_lang.val → Prop
  :=
  | LoadU_spec_success p p' g b e a a' noffs w :
      regs !! rsrc = Some (inr ((p, g), b, e, a)) ->
      isU p = true ->
      z_of_argument regs offs = Some noffs ->
      verify_access (LoadU_access b e a noffs) = Some a' ->
      mem !! a' = Some(p', w) →
      incrementPC (<[ rdst := w ]> regs) = Some regs' ->
      LoadU_spec regs rdst rsrc offs regs' mem NextIV
  | LoadU_spec_failure :
    LoadU_failure regs rdst rsrc offs mem ->
    LoadU_spec regs rdst rsrc offs regs' mem FailedV.

  Lemma wp_loadU Ep
     pc_p pc_g pc_b pc_e pc_a pc_p'
     rdst rsrc offs w mem regs :
   decodeInstrW w = LoadU rdst rsrc offs →
   pc_p' ≠ O →
   isCorrectPC (inr ((pc_p, pc_g), pc_b, pc_e, pc_a)) →
   regs !! PC = Some (inr ((pc_p, pc_g), pc_b, pc_e, pc_a)) →
   regs_of (LoadU rdst rsrc offs) ⊆ dom _ regs →
   mem !! pc_a = Some (pc_p', w) →
   match regs !! rsrc with
   | None => True
   | Some (inl _) => True
   | Some (inr (p, g, b, e, a)) =>
     if isU p then
       match z_of_argument regs offs with
       | None => True
       | Some zoffs => match verify_access (LoadU_access b e a zoffs) with
                      | None => True
                      | Some a' => match mem !! a' with
                                  | None => False
                                  | Some (p', w) => p' <> O
                                  end
                      end
       end
     else True
   end ->

   {{{ (▷ [∗ map] a↦pw ∈ mem, ∃ p w, ⌜pw = (p,w)⌝ ∗ a ↦ₐ[p] w) ∗
       ▷ [∗ map] k↦y ∈ regs, k ↦ᵣ y }}}
     Instr Executable @ Ep
   {{{ regs' retv, RET retv;
       ⌜ LoadU_spec regs rdst rsrc offs regs' mem retv⌝ ∗
         ([∗ map] a↦pw ∈ mem, ∃ p w, ⌜pw = (p,w)⌝ ∗ a ↦ₐ[p] w) ∗
         [∗ map] k↦y ∈ regs', k ↦ᵣ y }}}.
   Proof.
     iIntros (Hinstr Hfl Hvpc HPC Dregs Hmem_pc HaLoad φ) "(>Hmem & >Hmap) Hφ".
     iApply wp_lift_atomic_head_step_no_fork; auto.
     iIntros (σ1 l1 l2 n) "[Hr Hm] /=". destruct σ1; simpl.
     iDestruct (gen_heap_valid_inclSepM with "Hr Hmap") as %Hregs.

     (* Derive necessary register values in r *)
     pose proof (lookup_weaken _ _ _ _ HPC Hregs).
     specialize (indom_regs_incl _ _ _ Dregs Hregs) as Hri. unfold regs_of in Hri.
     feed destruct (Hri rsrc) as [rsrcv [Hrsrc' Hrsrc]]. by set_solver+.
     feed destruct (Hri rdst) as [rdstv [Hrdst' _]]. by set_solver+.
     pose proof (regs_lookup_eq _ _ _ Hrsrc') as Hrsrc''.
     pose proof (regs_lookup_eq _ _ _ Hrdst') as Hrdst''.
     (* Derive the PC in memory *)
     iDestruct (gen_mem_valid_inSepM pc_a _ _ _ _ mem _ m with "Hm Hmem") as %Hma; eauto.

     iModIntro.
     iSplitR. by iPureIntro; apply normal_always_head_reducible.
     iNext. iIntros (e2 σ2 efs Hpstep).
     apply prim_step_exec_inv in Hpstep as (-> & -> & (c & -> & Hstep)).
     iSplitR; auto. eapply step_exec_inv in Hstep; eauto.

     option_locate_mr m r.
     rewrite /exec in Hstep. rewrite Hrrsrc in Hstep.

     destruct rsrcv as [| [[[[p g] b] e] a] ].
     { inv Hstep. iFailWP "Hφ" LoadU_fail_const. }

     destruct (isU p) eqn:HisU; cycle 1.
     { inv Hstep. iFailWP "Hφ" LoadU_fail_perm. }

     assert (Hzofargeq: z_of_argument r offs = z_of_argument regs offs).
     { rewrite /z_of_argument; destruct offs; auto.
       feed destruct (Hri r0) as [? [?]]. by set_solver+.
       rewrite H2 H3; auto. }
     rewrite Hzofargeq in Hstep.

     destruct (z_of_argument regs offs) as [zoffs|] eqn:Hoffs; cycle 1.
     { inv Hstep. iFailWP "Hφ" LoadU_fail_offs_arg. }

     destruct (verify_access (LoadU_access b e a zoffs)) as [a'|] eqn:Hverify; cycle 1.
     { inv Hstep. iFailWP "Hφ" LoadU_fail_verify_access. }
     simpl in Hstep. rewrite Hrsrc' HisU Hverify in HaLoad.
     rewrite /MemLocate in Hstep. destruct (mem !! a') as [(p', wa)|] eqn:Ha'; cycle 1.
     { inv HaLoad. }
     iDestruct (gen_mem_valid_inSepM a' _ _ _ _ mem _ m with "Hm Hmem") as %Hma'; eauto.
     rewrite Hma' in Hstep. destruct (incrementPC (<[rdst:=wa]> regs)) eqn:Hincr; cycle 1.
     { assert _ as Hincr' by (eapply (incrementPC_overflow_mono (<[rdst:=wa]> regs) (<[rdst:=wa]> r) _ _ _)).
       rewrite incrementPC_fail_updatePC in Hstep; eauto.
       inv Hstep. simpl.
       iMod ((gen_heap_update_inSepM _ _ rdst) with "Hr Hmap") as "[Hr Hmap]"; eauto.
       iFailWP "Hφ" LoadU_fail_incrementPC. }

     destruct (incrementPC_success_updatePC _ m _ Hincr) as (p1 & g1 & b1 & e1 & a1 & a_pc1 & HPC'' & Ha_pc' & HuPC & ->).
     eapply updatePC_success_incl in HuPC. 2: by eapply insert_mono.
     rewrite HuPC in Hstep; clear HuPC; inversion Hstep; clear Hstep; subst c σ2. cbn.
     iMod ((gen_heap_update_inSepM _ _ rdst) with "Hr Hmap") as "[Hr Hmap]"; eauto.
     iMod ((gen_heap_update_inSepM _ _ PC) with "Hr Hmap") as "[Hr Hmap]"; eauto.
     iFrame. iModIntro. iApply "Hφ". iFrame.
     iPureIntro. econstructor; eauto.
     Unshelve. all: eauto.
     { destruct (reg_eq_dec PC rdst).
       - subst rdst. rewrite lookup_insert. eauto.
       - rewrite lookup_insert_ne; eauto. }
     { eapply insert_mono; eauto. }
   Qed.

End cap_lang_rules.


Require Import bedrock2.Syntax bedrock2.NotationsCustomEntry.
Require Import bedrock2.FE310CSemantics.

Import Syntax BinInt String Datatypes List List.ListNotations ZArith.
Local Open Scope string_scope. Local Open Scope Z_scope. Local Open Scope list_scope.

Definition silly1 := func! (a) ~> c {
  b = load4(a + $16);
  store4(a + $14, b);
  c = load4(a + $16)
}.

Require Import coqutil.Macros.symmetry.

Require Import coqutil.Word.Interface coqutil.Word.Properties.
Require Import bedrock2.Semantics bedrock2.ProgramLogic bedrock2.Array.
Require Import bedrock2.Map.Separation bedrock2.Map.SeparationLogic.
Require Import Coq.Lists.List coqutil.Map.OfListWord.
Require Import coqutil.Z.Lia.
Require Import coqutil.Tactics.Tactics.
Require Import coqutil.Tactics.letexists.
Require Import coqutil.Tactics.rdelta.
Require Import coqutil.Word.Bitwidth32.
Import Map.Interface Interface.map OfFunc.map OfListWord.map.
Require Import bedrock2.AbsintWordToZ.
Require Import bedrock2.groundcbv.
Require Import coqutil.Tactics.rewr.
Require Import AdmitAxiom.

Section WithParameters.
  Context {word: word.word 32} {mem: map.map word Byte.byte}.
  Context {word_ok: word.ok word} {mem_ok: map.ok mem}.
  Add Ring wring : (Properties.word.ring_theory (word := word))
        (preprocess [autorewrite with rew_word_morphism],
         morphism (Properties.word.ring_morph (word := word)),
         constants [Properties.word_cst]).

  Local Instance spec_of_silly1 : spec_of "silly1" := fun functions =>
      forall t m a bs R, Z.of_nat (length bs) = 32 ->
      (sep (eq (map.of_list_word_at a bs)) R) m ->
      WeakestPrecondition.call functions "silly1" t m [a]
      (fun T M rets => True).

  Ltac ring_simplify_unsigned_goal :=
    match goal with
    |- context [word.unsigned ?x] =>
      let Hrw := fresh in
      eassert (let y := _ in x = y) as Hrw by (
        let y := fresh in
        intros y; ring_simplify;
        subst y; trivial);
      rewrite !Hrw; clear Hrw
    end.
  Ltac ring_simplify_unsigned_in H :=
    match type of H with context [word.unsigned ?x] =>
      let Hrw := fresh in
      eassert (let y := _ in x = y) as Hrw by (
        let y := fresh in
        intros y; ring_simplify;
        subst y; trivial);
      rewrite !Hrw in H; clear Hrw
    end.
  Ltac ring_simplify_unsigned :=
    try ring_simplify_unsigned_goal;
    repeat match goal with
           | H: context [word.unsigned ?x] |- _ => ring_simplify_unsigned_in H
           end.

  Ltac unify_and_change lhs rhs :=
    let rhs := match rhs with ?x => x end in
    let __ := constr:(eq_refl : lhs = rhs) in
    change lhs with rhs in *.

  Ltac change_with_Z_literal W :=
    first [ let e := open_constr:(BinInt.Zpos _) in
            unify_and_change W e;
            requireZcst e
          | unify_and_change W open_constr:(BinInt.Z0)
          | let e := open_constr:(BinInt.Zneg _) in
            unify_and_change W e;
            requireZcst e].

  Ltac simplify_ZcstExpr_goal :=
    match goal with
    |- context [?e] =>
        requireZcstExpr e;
        assert_fails (idtac; requireZcst e);
        let e' := eval vm_compute in e in
        let Hrw := fresh in
        assert (e = e') as Hrw by (vm_cast_no_check (eq_refl e'));
        (* idtac "simplified" e "in GOAL"; *)
        progress rewrite Hrw; clear Hrw
    end.

  Ltac simplify_ZcstExpr_in H :=
    match type of H with context [?e] =>
        requireZcstExpr e;
        assert_fails (idtac; requireZcst e);
        let e' := eval vm_compute in e in
        let Hrw := fresh in
        assert (e = e') as Hrw by (vm_cast_no_check (eq_refl e'));
        (* idtac "simplified" e "in" H; *)
        progress rewrite Hrw in H; clear Hrw
    end.

  Ltac simplify_ZcstExpr_hyps :=
    repeat match goal with H : _ |- _ => simplify_ZcstExpr_in H end.

  Ltac simplify_ZcstExpr :=
    simplify_ZcstExpr_hyps; try simplify_ZcstExpr_goal.

  Ltac rewrite_unsigned_of_Z_goal :=
    match goal with
    |- context [@word.unsigned ?w ?W ?X] =>
      let E := constr:(@word.unsigned w W X) in
      let x := rdelta X in
      let z := match x with word.of_Z ?z => z end in
      rewrite ((@word.unsigned_of_Z w W _ z) : E = z mod 2^w)
    end.

  Ltac rewrite_unsigned_of_Z_in H :=
    match type of H with context [@word.unsigned ?w ?W ?X] =>
      let E := constr:(@word.unsigned w W X) in
      let x := rdelta X in
      let z := match x with word.of_Z ?z => z end in
      rewrite ((@word.unsigned_of_Z w W _ z) : E = z mod 2^w) in H
    end.

  Ltac wordcstexpr_tac := (* hacky *)
    repeat first
          [ progress ring_simplify_unsigned
          | rewrite !word.unsigned_add; cbv [word.wrap]
          | rewrite_unsigned_of_Z_goal ];
    repeat simplify_ZcstExpr_goal; trivial.

  Lemma List__splitZ_spec [A] (xsys : list A) i (H : 0 <= i < Z.of_nat (length xsys)) :
    let xs := firstn (Z.to_nat i) xsys in
    let ys := skipn (Z.to_nat i) xsys in
    xsys = xs ++ ys /\
    Z.of_nat (length xs) = i /\
    Z.of_nat (length ys) = Z.of_nat (length xsys) - i.
  Proof.
    pose proof eq_sym (firstn_skipn (Z.to_nat i) xsys).
    split; trivial.
    rewrite length_firstn_inbounds, length_skipn; blia.
  Qed.

  Ltac lift_head_let_in H :=
    match type of H with
    | let x := ?v in ?C =>
        let X := fresh x in
        pose v as X;
        let C := constr:(match X with x => C end) in
        change C in H
    end.

  Ltac flatten_hyps :=
    repeat match goal with
           | H : let x := ?v in ?C |- _ =>
               let X := fresh x in
               pose v as X;
               let C := constr:(match X with x => C end) in
               change C in H
           | H : _ /\ _ |- _ => destruct H
           | H : exists _, _ |- _ => destruct H
           end.

  Lemma List__splitZ_spec_n [A] (xsys : list A) i n
    (Hn : Z.of_nat (length xsys) = n) (H : 0 <= i < n) :
    let xs := firstn (Z.to_nat i) xsys in
    let ys := skipn (Z.to_nat i) xsys in
    xsys = xs ++ ys /\
    Z.of_nat (length xs) = i /\
    Z.of_nat (length ys) = n - i.
  Proof.
    pose proof eq_sym (firstn_skipn (Z.to_nat i) xsys).
    split; trivial.
    rewrite length_firstn_inbounds, length_skipn; blia.
  Qed.

  Ltac List__splitZ bs n :=
      match goal with H: Z.of_nat (length bs) = _ |- _ =>
          pose proof List__splitZ_spec_n bs n _ H ltac:(blia);
          clear H; flatten_hyps; simplify_ZcstExpr;
          let Hrw := lazymatch goal with H : bs = _ ++ _ |- _ => H end in
          let eqn := type of Hrw in
          rewr ltac:(fun t => match t with
                              | eqn => fail 1
                              | _ => constr:(Hrw) end) in *
      end.

  Lemma map__of_list_word_at_app_n [value] [map : map.map word value] {ok : map.ok map}
    (a : word) (xs ys : list value)
    lxs (Hlxs : Z.of_nat (length xs) = lxs)
    : map.of_list_word_at a (xs ++ ys)
    = putmany (map.of_list_word_at (word.add a (word.of_Z lxs)) ys) (map.of_list_word_at a xs).
  Proof. subst lxs; apply map.of_list_word_at_app. Qed.

  Lemma map__adjacent_arrays_disjoint_n [value] [map : map.map word value] {ok : map.ok map}
    (a : word) (xs ys : list value)
    lxs (Hlxs : Z.of_nat (length xs) = lxs)
    (H :Z.of_nat (length xs) + Z.of_nat (length ys) <= 2 ^ 32)
    : disjoint (map.of_list_word_at (word.add a (word.of_Z lxs)) ys) (map.of_list_word_at a xs).
  Proof. subst lxs. auto using map.adjacent_arrays_disjoint. Qed.

      Declare Scope word_scope.
      Bind Scope word_scope with word.
      Delimit Scope word_scope with word.
      Local Notation "a + b" := (word.add a b) (at level 50, left associativity, format "a + b") : word_scope.
      Local Infix "-" := word.sub : word_scope.
      Local Coercion Z.of_nat : nat >-> Z.
      Local Infix "$+" := putmany (at level 70).
      Local Notation "xs $@ a" := (map.of_list_word_at a%word xs) (at level 10, format "xs $@ a").
      Local Notation "! x" := (word.of_Z x) (at level 10, format "! x").
      Local Notation "a * b" := (sep a%type b%type) : type_scope.
      Local Open Scope word_scope.

  Lemma sep_eq_putmany [key value] [map : map.map key value] (a b : map) (H : disjoint a b) : Lift1Prop.iff1 (eq (a $+ b)) (sep (eq a) (eq b)).
  Proof.
    split.
    { intros; subst. eexists _, _; eauto using Properties.map.split_disjoint_putmany. }
    { intros (?&?&(?&?)&?&?); subst; trivial. }
  Qed.

  Lemma sep_eq_of_list_word_at_app [value] [map : map.map word value] {ok : map.ok map}
    (a : word) (xs ys : list value)
    lxs (Hlxs : Z.of_nat (length xs) = lxs) (Htotal : length xs + length ys <= 2^32)
    : Lift1Prop.iff1 (eq (map.of_list_word_at a (xs ++ ys)))
      (sep (eq (map.of_list_word_at a xs)) (eq (map.of_list_word_at (word.add a (word.of_Z lxs)) ys))).
  Proof.
    etransitivity.
    2: eapply sep_comm.
    etransitivity.
    2: eapply sep_eq_putmany, map__adjacent_arrays_disjoint_n; trivial.
    erewrite map__of_list_word_at_app_n by eauto; reflexivity.
  Qed.

  Lemma list_word_at_app_of_adjacent_eq [value] [map : map.map word value] {ok : map.ok map}
    (a b : word) (xs ys : list value)
    (Hl: word.unsigned (word.sub b a) = Z.of_nat (length xs))
    (Htotal : length xs + length ys <= 2^32)
    : Lift1Prop.iff1
        (sep (eq (map.of_list_word_at a xs)) (eq (map.of_list_word_at b ys)) )
        (eq (map.of_list_word_at a (xs ++ ys))).
  Proof.
    etransitivity.
    2:symmetry; eapply sep_eq_of_list_word_at_app; trivial.
    do 3 Morphisms.f_equiv. rewrite <-Hl, word.of_Z_unsigned. ring.
  Qed.

  Lemma of_list_word_nil
    [value] [map : map.map word value] {ok : map.ok map}
    k : []$@k = empty(map:=map).
  Proof. apply Properties.map.fold_empty. Qed.
  Lemma of_list_word_singleton
    [value] [map : map.map word value] {ok : map.ok map}
    (k : word) (v : value) : [v]$@k = put empty k v.
  Proof.
    cbv [of_list_word_at of_list_word seq length List.map of_func update].
    rewrite word.unsigned_of_Z_0, Z2Nat.inj_0; cbv [MapKeys.map.map_keys nth_error].
    rewrite Properties.map.fold_singleton.
    f_equal; cbn [Z.of_nat].
    eapply word.unsigned_inj; rewrite word.unsigned_add; cbv [word.wrap]; rewrite word.unsigned_of_Z_0, Z.add_0_r, Z.mod_small; trivial; eapply word.unsigned_range.
  Qed.

  Import ptsto_bytes Lift1Prop Morphisms.
  Lemma eq_of_list_word_iff_array1 [value] [map : map.map word value] {ok : map.ok map}
    (a : word) (bs : list value)
    (H : length bs <= 2 ^ 32) :
    iff1 (eq (bs$@a)) (array ptsto (word.of_Z 1) a bs).
  Proof.
    revert H; revert a; induction bs; cbn [array]; intros.
    { rewrite of_list_word_nil; cbv [emp iff1]; intuition auto. }
    { etransitivity.
      2: eapply Proper_sep_iff1.
      3: eapply IHbs.
      2: reflexivity.
      2: cbn [length] in H; blia.
      change (a::bs) with ([a]++bs).
      rewrite of_list_word_at_app.
      etransitivity.
      1: eapply sep_eq_putmany, adjacent_arrays_disjoint; cbn [length] in *; blia.
      etransitivity.
      2:eapply sep_comm.
      f_equiv.
      rewrite of_list_word_singleton; try exact _.
      cbv [ptsto iff1]; intuition auto. }
  Qed.

  Ltac ring_simplify_address_in H :=
    match type of H with context [_ $@ ?x] =>
      let Hrw := fresh in
      eassert (let y := _ in x = y) as Hrw by (
        let y := fresh in
        intros y; ring_simplify;
        subst y; trivial);
      rewrite !Hrw in H; clear Hrw
    end.

  Ltac split_bytes_base_addr bs a0 ai :=
      let raw_i := constr:(word.unsigned (ai-a0)%word) in
      let Hidx := fresh "Hidx" in
      eassert (raw_i = _) as Hidx by (
        ring_simplify_unsigned_goal; repeat rewrite_unsigned_of_Z_goal;
        simplify_ZcstExpr; exact eq_refl);
      let i := match type of Hidx with _ = ?r => r end in
      let Happ := fresh "Happ" in
      match goal with H: Z.of_nat (length bs) = _ |- _ =>
          pose proof List__splitZ_spec_n bs i _ H ltac:(blia) as Happ;
          clear H
      end;
      repeat lift_head_let_in Happ; case Happ as (Happ&?H1l&?H2l);
      simplify_ZcstExpr;
      let eqn := type of Happ in
      rewr ltac:(fun t => match t with
                          | eqn => fail 1
                          | _ => constr:(Happ) end) in *;
      repeat match goal with Hsep : _ |- _ =>
        seprewrite_in_by sep_eq_of_list_word_at_app Hsep ltac:(
          try eassumption; try blia)
      end.

  Section __.
    Import WithoutTuples.
    Lemma load_bytes_of_putmany_bytes_at bs a (mR:mem) n (Hn : length bs = n) (Hl : Z.of_nat n < 2^32)
      : load_bytes (mR $+ bs$@a) a n = Some bs.
    Proof.
      destruct (load_bytes (mR $+ bs$@a) a n) eqn:HN in *; cycle 1.
      { exfalso; eapply load_bytes_None in HN; case HN as (i&?&?).
        case (Properties.map.putmany_spec mR (bs$@a) (a+!(BinIntDef.Z.of_nat i))%word) as [(?&?&?)| (?&?) ]; try congruence.
        rewrite get_of_list_word_at in H1; eapply nth_error_None in H1.
        revert H1.
        rewrite word.word_sub_add_l_same_l, word.unsigned_of_Z.
        cbv [word.wrap]; rewrite Z.mod_small, Nat2Z.id; eauto; blia. }
      transitivity (Some l); try congruence; f_equal; subst n.
      symmetry; eapply nth_error_ext_samelength.
      { symmetry; eauto using length_load_bytes. }
      intros.
      pose proof nth_error_load_bytes _ a _ _ HN i ltac:(trivial) as HH.
      epose proof H; eapply nth_error_nth' with (d:=Byte.x00) in H.
      erewrite Properties.map.get_putmany_right in HH; cycle 1.
      { rewrite get_of_list_word_at.
        rewrite word.word_sub_add_l_same_l, word.unsigned_of_Z.
        cbv [word.wrap]; rewrite Z.mod_small, Nat2Z.id; eauto; blia. }
      congruence.
    Qed.

    Lemma load_bytes_of_sep_bytes_at bs a R (m:mem) (Hsep: (eq(bs$@a)*R) m) n (Hn : length bs = n) (Hl : Z.of_nat n < 2^32)
      : load_bytes m a n = Some bs.
    Proof.
      eapply sep_comm in Hsep.
      destruct Hsep as (mR&?&(?&?)&?&?); subst.
      eapply load_bytes_of_putmany_bytes_at; eauto.
    Qed.
  End __.

  Lemma load_four_bytes_of_sep_at bs a R (m:mem) (Hsep: (eq(bs$@a)*R) m) (Hl : length bs = 4%nat) :
    load access_size.four m a = Some (word.of_Z (LittleEndianList.le_combine bs)).
  Proof.
    eapply Scalars.load_four_bytes_of_sep_at; try eassumption.
  Qed.

  Lemma uncurried_load_four_bytes_of_sep_at bs a R (m : mem)
    (H: (eq(bs$@a)*R) m /\ length bs = 4%nat) :
    load access_size.four m a = Some (word.of_Z (LittleEndianList.le_combine bs)).
  Proof. eapply Scalars.uncurried_load_four_bytes_of_sep_at; try eassumption. Qed.

  Lemma Z_uncurried_load_four_bytes_of_sep_at bs a R (m : mem)
    (H: (eq(bs$@a)*R) m /\ Z.of_nat (length bs) = 4) :
    load access_size.four m a = Some (word.of_Z (LittleEndianList.le_combine bs)).
  Proof. eapply Scalars.Z_uncurried_load_four_bytes_of_sep_at; try eassumption. Qed.

  (*
  Lemma store_four_of_sep addr (oldvalue : word32) (value : word) R m (post:_->Prop)
    (Hsep : sep (scalar32 addr oldvalue) R m)
    (Hpost : forall m, sep (scalar32 addr (word.of_Z (word.unsigned value))) R m -> post m)
    : exists m1, Memory.store Syntax.access_size.four m addr value = Some m1 /\ post m1.
  Proof.
  *)

  Ltac split_flat_memory_based_on_goal :=
    lazymatch goal with
    | |- load ?sz ?m ?a = _ =>
        let sz := eval cbv in (Z.of_nat (bytes_per (width:=32) sz)) in
        match goal with H : ?S m |- _ =>
        match S with context[?bs $@ ?a0] =>
        let a_r := constr:(word.add a (word.of_Z sz)) in
        split_bytes_base_addr bs a0 a_r end;
        match type of H with context[?bs $@ ?a0] =>
        split_bytes_base_addr bs a0 a end end
    | |- WeakestPrecondition.store ?sz ?m ?a _ _ =>
        let sz := eval cbv in (Z.of_nat (bytes_per (width:=32) sz)) in
        match goal with H : ?S m |- _ =>
        match S with context[?bs $@ ?a0] =>
        let a_r := constr:(word.add a (word.of_Z sz)) in
        split_bytes_base_addr bs a0 a_r end;
        match type of H with context[?bs $@ ?a0] =>
        split_bytes_base_addr bs a0 a end end
    end.

  Ltac subst_lets :=
    repeat match goal with x := ?v |- _ => assert_fails (is_evar v); subst x end.

  Ltac set_evars :=
    repeat match goal with
           | |- context [?e] => is_evar e; set e in *
           | H: context [?e] |- _ => is_evar e; set e in *
           end.
  Ltac subst_evars :=
    repeat match goal with
    x := ?e |- _ => is_evar e; subst x
           end.

  Lemma and_weaken_left (A A' B : Prop) : A -> A' -> A /\ B -> A' /\ B.
  Proof. tauto. Qed.

  Ltac on_left tac :=
      let A := open_constr:(_:Prop) in
      let k := open_constr:(_:A) in
      unshelve simple notypeclasses refine (and_weaken_left A _ _ k _ _);
        [> tac; try [> exact k ] | ];
      cbv delta [and_weaken_left] (* drop cast *);
      (* did tac solve the goal? *)
      (* "match A with ?A" strips outer casts *)
      tryif match A with ?A => is_evar A end
      then simple notypeclasses refine (conj I _)
      else idtac.
  Tactic Notation "on_left" tactic3(tac) := on_left tac.

  Import ProgramLogic.Coercions.

  (* note: do we want an Ltac coding rule that tactics must not start with a match? *)
  Local Ltac ecancel_assumption := idtac; SeparationLogic.ecancel_assumption.

(*
Import coqutil.Macros.subst.
Ltac flatten_hyps :=
  repeat match goal with
  | H : exists _, _ |- _ => destruct H as (?&H)
  | H : _ /\ _  |- _ => destruct H as (?&H)
  | H : let x := ?v in ?C |- _ =>
      let y := fresh x in pose v as y;
        change (subst! y for x in C) in H
  end.
*)
Ltac flatten_goal :=
  repeat match goal with
         | |- (_ /\ _) /\ _ => eapply and_assoc
         end.
Ltac flatten := flatten_hyps; flatten_goal.

Ltac simpl_lengths_step :=
  match goal with
  | _ => progress groundcbv_in_all
  | H : Z.of_nat (length ?x) = ?v |- _ =>
    let t' := type of H in
    assert_fails(t'); first [is_var v | is_ground v];
    progress rewr ltac:(fun t =>
      match t with
      | t' => fail 1
      | context[Z.of_nat (length x)] => H
      end) in *
  | _ => progress rewr ltac:(fun t =>
      match t with
      | context[@List.length ?A (List.app ?x ?y)] => constr:(@app_length A x y)
      end) in *
  end.
Ltac simpl_lengths := repeat simpl_lengths_step.

  Lemma silly1_ok : program_logic_goal_for_function! silly1.
  Proof.
    repeat (straightline || apply WeakestPreconditionProperties.dexpr_expr).

    eexists ?[v].

    on_left eapply Z_uncurried_load_four_bytes_of_sep_at.

    pose proof List__splitZ_spec_n bs 20 _ H ltac:(blia).
    flatten; simpl_lengths.
    set_evars; rewrite H1 in *; subst_evars.
    seprewrite_in_by sep_eq_of_list_word_at_app H0
      ltac:(trivial || blia); simpl_lengths.

    pose proof List__splitZ_spec_n _ 16 _ H2 ltac:(blia);
    flatten; simpl_lengths.
    set_evars; rewrite H4 in *; subst_evars; simpl_lengths.
    seprewrite_in_by sep_eq_of_list_word_at_app H0
      ltac:(trivial || blia); simpl_lengths.

    on_left ecancel_assumption. (*  this inlines definition of ys0, makes length proof annoying *)
    match goal with |- context[?x] => change x with ys0 end.

    split; [ trivial | ].

    repeat straightline. (* this inlines too many lets *)

    (* store4(a + $14, b); *)

    cbv [WeakestPrecondition.store].

    (* remerge *)
    seprewrite_in_by @list_word_at_app_of_adjacent_eq H0 ltac:(
      simpl_lengths; rewrite ?word.word_sub_add_l_same_l, ?word.unsigned_of_Z; trivial; clear;blia).
    repeat seprewrite_in_by @list_word_at_app_of_adjacent_eq H0 ltac:(
      rewrite ?app_length; wordcstexpr_tac; simpl_lengths; blia).

    Tactics.rapply (fun addr oldvalue value R m post H => Scalars.store_four_of_sep addr oldvalue value R m post (proj1 H) (proj2 H)).

    (* note: it would be nice to have a generalization of this /\-goal logic in on_left *)
    unshelve (
    let x := open_constr:(_ : _ /\ (_ /\ _)) in
    once (on_left (idtac; seprewrite (symmetry! (fun _: 32 <= 32 => @Scalars.scalar32_of_bytes)))); [exact (proj1 (proj2 x)) | exact (proj1 x) | exact (proj2 (proj2 x))]); shelve_unifiable.
    2: reflexivity. (* already in goal 1, but should only be there and not a second subgoal *)
    on_left (idtac; seprewrite @array1_iff_eq_of_list_word_at; cycle 1); cycle 1.

    (* frame calculation again, unclear what to subst before split_bytes_base_addr *)
    (* maybe make a rewrite that follows lets *)

    {
    eassert (Z.of_nat (length ((xs0 ++ ys0) ++ ys)) = _). {
      rewrite ?app_length.
      rewrite ?Nat2Z.inj_add.
      repeat match goal with
             | H: Z.of_nat (length ?x) = ?y |- context[length ?x] => rewrite H
             end.
      simplify_ZcstExpr.
      reflexivity.
    }

    repeat match goal with x := _ : word.rep |- _ => subst x end.
    set_evars.
    replace (length l1 = 4%nat) with (Z.of_nat (length l1) = 4) by case proof_admitted.

    match goal with |- context[?P m] =>
    match P with context[?e$@?a] =>
    match goal with | |- context[Z.of_nat (length e) = ?n] =>
    match goal with H : ?S m |- _ =>
    match S with context[?bs $@ ?a0] =>
    let a_r := constr:(word.add a (word.of_Z n)) in
    split_bytes_base_addr bs a0 a_r end;
    match type of H with context[?bs $@ ?a0] =>
    split_bytes_base_addr bs a0 a
end end
    end end end.

    on_left ecancel_assumption.
    split; [trivial|].
    split; [reflexivity|].

    repeat (straightline || apply WeakestPreconditionProperties.dexpr_expr).

    (* last line *)

    subst P.
    all: case proof_admitted. }

    Unshelve.
    all : case proof_admitted.

  Time Qed.

End WithParameters.

(* think of mempcpy/memmove within a packet rather than load and store, which are just "special cases" of memmove

operations on bytes

extend to other access_size?

 *)


Require Import FunctionApp.

Local Open Scope type_scope.

(** We apply AC_∞, the type-theoretic axiom of choice, so that
          we don't need to do higher order unification later. *)
Lemma emptiesStackStep' input world pf
      (H : forall i : input,
             { p' : stackProcess input world
             & emptiesStack (stackTransition i pf) p' *
               emptiesStackForever p' })
: @emptiesStackForever input world (Step pf).
Proof.
  econstructor.
  intro i.
  exists (projT1 (H i)).
  split; apply (projT2 (H _)).
Defined.

Definition stackProcess_eta input world (p : stackProcess input world)
: p = match p with
        | Step f => Step f
      end.
Proof.
  destruct p; reflexivity.
Defined.

Definition process_eta input world (p : process input world)
: p = match p with
        | Step f => Step f
      end.
Proof.
  destruct p; reflexivity.
Defined.

Lemma emptiesStackDone' input world p q (H : p = q) : @emptiesStack input world (stackDone, p) q.
Proof.
  subst.
  constructor.
Defined.

Lemma emptiesStackPush_sigT {input world} (m : input) (sw : stackWorld input world)
      (pf : stackStep) P
: { p2 : stackProcess input world & emptiesStack (stackTransition m pf) p2 * { p3 : _ & emptiesStack (sw, p2) p3 * P p3 } }
  -> { p3 : _ & emptiesStack (stackPush m sw, Step pf) p3 * P p3 }.
Proof.
  intro H.
  eexists.
  split; [ eapply emptiesStackPush | ];
  first [ apply (fst (projT2 H))
        | apply (fst (projT2 (snd (projT2 H))))
        | apply (snd (projT2 (snd (projT2 H)))) ].
Defined.

Lemma emptiesStackLift_sigT {input world} (a : action world) (sw : stackWorld input world)
      (p : stackProcess input world) P
: { p2 : _ & emptiesStack (sw, p) p2 * P p2 }
  -> { p2 : _ & emptiesStack (stackLift a sw, p) p2 * P p2 }.
Proof.
  intro H.
  eexists.
  split; [ eapply emptiesStackLift | ];
  first [ apply (fst (projT2 H))
        | apply (snd (projT2 H)) ].
Defined.

Lemma emptiesStackDone_sigT {input world} p (P : stackProcess input world -> Type)
: P p -> { p' : _ & emptiesStack (stackDone, p) p' * P p' }.
Proof.
  intro H.
  eexists.
  split; [ eapply emptiesStackDone | ]; eassumption.
Defined.

Lemma emptiesStackPush_ex {input world} (m : input) (sw : stackWorld input world)
      (pf : stackStep) P
: (exists p2 : stackProcess input world,
     emptiesStack (stackTransition m pf) p2
     /\ exists p3 : _, emptiesStack (sw, p2) p3 /\ P p3)
  -> exists p3 : _, emptiesStack (stackPush m sw, Step pf) p3 /\ P p3.
Proof.
  intros [? [? [? [? ?]]]].
  eexists.
  split; [ eapply emptiesStackPush | ];
  eassumption.
Defined.

Lemma emptiesStackLift_ex {input world} (a : action world) (sw : stackWorld input world)
      (p : stackProcess input world) P
: (exists p2 : _, emptiesStack (sw, p) p2 /\ P p2)
  -> exists p2 : _, emptiesStack (stackLift a sw, p) p2 /\ P p2.
Proof.
  intros [? [? ?]].
  eexists.
  split; [ eapply emptiesStackLift | ];
  eassumption.
Defined.

Lemma emptiesStackDone_ex {input world} p (P : stackProcess input world -> Prop)
: P p -> exists p' : _, emptiesStack (stackDone, p) p' /\ P p'.
Proof.
  intro H.
  eexists.
  split; [ eapply emptiesStackDone | ]; eassumption.
Defined.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                          PriorityDecode_Proof.v                          *)
(****************************************************************************)

Require Export PickSuccessfulInput.
Require Export Arbitration.
Require Export Moore_Mealy.

Set Implicit Arguments.
Unset Strict Implicit.

Section PriorityDecode_Correctness.

  Let Input_type :=
    (d_list bool 4 * (d_list bool 4 * d_list (d_list bool 2) 4))%type.

  Let Output_type := d_list (d_list bool 4) 4.

  Inductive label_p : Set :=
    | START_p : label_p
    | DECODE_p : label_p.

  Definition STATE_p : Set := (label_p * d_list (d_list bool 4) 4)%type.

(** Automaton describing the transitions from a state to another **)

  Definition Convert_and_filter (i : Input_type) : Output_type :=
    let (act, p) := i in
    let (pri, route) := p in
    d_map (PriorityRequests act pri) (merge (d_map Convert_list2 route)).

  Definition Trans_PriorityDecode (i : Input_type)
    (s : STATE_p) : STATE_p := (DECODE_p, Convert_and_filter i).

(** Each state corresponds to a result **)

  Definition Out_PriorityDecode (s : STATE_p) : Output_type :=
    let (s', old) := s in old.

(** States stream **)

  Definition States_PRIORITY_DECODE := States_Mealy Trans_PriorityDecode.

(** Intented behaviour **)

  Definition Behaviour_PRIORITY_DECODE :=
    Moore Trans_PriorityDecode Out_PriorityDecode.

(** Transformation of Behaviour_PRIORITY_DECODE to a Mealy automaton **)

  Definition Out_PriorityDecode_Mealy :=
    Out_Mealy (Input_type:=Input_type) Out_PriorityDecode.

  Lemma equiv_out_PriorityDecode :
   forall (i : Input_type) (s : STATE_p),
   Out_PriorityDecode s = Out_PriorityDecode_Mealy i s.
  Proof.
  auto.
  Qed.

  Lemma Equiv_PriorityDecode_Moore_Mealy :
   forall (s : STATE_p) (i : Stream Input_type),
   EqS (Behaviour_PRIORITY_DECODE i s)
     (Mealy Trans_PriorityDecode Out_PriorityDecode_Mealy i s).
  Proof.
  intros s i.
  unfold Behaviour_PRIORITY_DECODE in |- *;
   unfold Out_PriorityDecode_Mealy in |- *; apply Equiv_Moore_Mealy.
  Qed.

  Definition States_Structure_PRIORITY_DECODE :=
    States_Mealy Trans_priority_decode.

 (** No invariant property *)

  Let Reg_type := d_list (d_list bool 4) 4. (* Type of the registers of PRIORITY_DECODE *)

  Let Cst_True (i : Input_type) (s : STATE_p) (reg : Reg_type) := True.

  Definition R_Priority_Decode (s : STATE_p) (reg : Reg_type) :=
    reg = Out_PriorityDecode s.

 (* Cst_True is an invariant *)

  Lemma Cst_True_inv_pdecode :
   forall (i : Stream Input_type) (s : STATE_p) (reg : Reg_type),
   Inv Cst_True i (States_PRIORITY_DECODE i s)
     (States_Structure_PRIORITY_DECODE i reg).

  Proof.
  cofix Cst_True_inv_pdecode.
  intros i s reg.
  apply Inv_Ok.
  unfold Cst_True in |- *; auto.
  Qed.

(** Because the unit is essentially combinational, we assume its correctness **)

  Axiom
    Invariant_relation_p :
      Inv_under_P Trans_PriorityDecode Trans_priority_decode Cst_True
        R_Priority_Decode.

  Lemma Output_relation_p :
   Output_rel Out_PriorityDecode_Mealy Out_priority_decode R_Priority_Decode.

  Proof.
  unfold Output_rel in |- *; auto.
  Qed.

(** Correctness lemma  **)

  Lemma Correct_PRIORITY_DECODE :
   forall (i : Stream Input_type) (reg : Reg_type) (s : STATE_p),
   R_Priority_Decode s reg ->
   EqS (Behaviour_PRIORITY_DECODE i s) (Structure_PRIORITY_DECODE i reg).

  Proof.
  intros i reg s HR.
  unfold Structure_PRIORITY_DECODE in |- *;
   unfold Behaviour_PRIORITY_DECODE in |- *.
  apply
   (Equiv_2_Mealy Invariant_relation_p Output_relation_p
      (Cst_True_inv_pdecode i s reg) HR).

  Qed.

End PriorityDecode_Correctness.


Require Import Coq.omega.Omega.
Require Import Crypto.Util.FixCoqMistakes.
Require Import Crypto.Reflection.Syntax.
Require Import Crypto.Reflection.Wf.
Require Import Crypto.Reflection.Named.Syntax.
Require Import Crypto.Reflection.Named.ContextDefinitions.
Require Import Crypto.Reflection.Named.NameUtil.
Require Import Crypto.Reflection.Named.NameUtilProperties.
Require Import Crypto.Reflection.Named.ContextProperties.
Require Import Crypto.Reflection.Named.ContextProperties.Tactics.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Tactics.SplitInContext.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.SpecializeBy.

Section with_context.
  Context {base_type_code Name var} (Context : @Context base_type_code Name var)
          (base_type_code_dec : DecidableRel (@eq base_type_code))
          (Name_dec : DecidableRel (@eq Name))
          (ContextOk : ContextOk Context).

  Local Notation find_Name := (@find_Name base_type_code Name Name_dec).
  Local Notation find_Name_and_val := (@find_Name_and_val base_type_code Name base_type_code_dec Name_dec).

  Hint Rewrite (@find_Name_and_val_default_to_None _ _ base_type_code_dec Name_dec) using congruence : ctx_db.
  Hint Rewrite (@find_Name_and_val_different _ _ base_type_code_dec Name_dec) using assumption : ctx_db.
  Hint Rewrite (@find_Name_and_val_wrong_type _ _ base_type_code_dec Name_dec) using congruence : ctx_db.
  Hint Rewrite (@snd_split_onames_skipn base_type_code Name) : ctx_db.

  Local Ltac misc_oname_t_step :=
    match goal with
    | [ H : oname_list_unique (List.skipn _ _) -> _ |- _ ]
      => specialize (fun pf => H (@oname_list_unique_skipn _ _ _ pf))
    | [ H : ((_, _) = (_, _))%core -> _ |- _ ]
      => specialize (fun a b => H (f_equal2 (@pair _ _) a b))
    | [ H : ?x = (_,_)%core -> _ |- _ ]
      => rewrite (surjective_pairing x) in H;
           specialize (fun a b => H (f_equal2 (@pair _ _) a b))
    end.

  Lemma split_onames_find_Name
        {n T N ls ls'}
        (H : split_onames _ ls = (Some N, ls')%core)
    : (exists t, @find_Name n T N = Some t)
      <-> List.In (Some n) (List.firstn (CountLets.count_pairs T) ls).
  Proof.
    revert dependent ls; intro ls; revert ls ls'; induction T; intros;
      [ | | specialize (IHT1 (fst N) ls (snd (split_onames T1 ls)));
            specialize (IHT2 (snd N) (snd (split_onames T1 ls)) (snd (split_onames (T1 * T2) ls))) ];
      repeat first [ misc_oname_t_step
                   | t_step
                   | progress split_iff
                   | progress specialize_by (eexists; eauto)
                   | solve [ eauto using In_skipn, In_firstn ]
                   | match goal with
                     | [ H : List.In ?x (List.firstn ?n ?ls) |- List.In ?x (List.firstn (?n + ?m) ?ls) ]
                       => apply (In_firstn n); rewrite firstn_firstn by omega
                     | [ H : _ |- _ ] => first [ rewrite firstn_skipn_add in H
                                               | rewrite firstn_firstn in H by omega ]
                     | [ H : List.In ?x' (List.firstn (?n + ?m) ?ls) |- List.In ?x' (List.firstn ?m (List.skipn ?n ?ls)) ]
                       => apply (In_firstn_skipn_split n) in H
                     end ].
  Qed.

  Lemma split_onames_find_Name_Some_unique_iff
        {n T N ls ls'}
        (Hls : oname_list_unique ls)
        (H : split_onames _ ls = (Some N, ls')%core)
    : (exists t, @find_Name n T N = Some t)
      <-> List.In (Some n) ls /\ ~List.In (Some n) ls'.
  Proof.
    rewrite (split_onames_find_Name (ls':=ls') (ls:=ls)) by assumption.
    rewrite (surjective_pairing (split_onames _ _)) in H.
    rewrite fst_split_onames_firstn, snd_split_onames_skipn in H.
    inversion_prod; subst.
    split; [ split | intros [? ?] ]; eauto using In_firstn, oname_list_unique_specialize.
    eapply In_firstn_skipn_split in H; destruct_head' or; eauto; exfalso; eauto.
  Qed.

  Lemma split_onames_find_Name_Some_unique
        {t n T N ls ls'}
        (Hls : oname_list_unique ls)
        (H : split_onames _ ls = (Some N, ls')%core)
        (Hfind : @find_Name n T N = Some t)
    : List.In (Some n) ls /\ ~List.In (Some n) ls'.
  Proof.
    eapply split_onames_find_Name_Some_unique_iff; eauto.
  Qed.

  Lemma flatten_binding_list_find_Name_and_val_unique
        {var' t n T N V v ls ls'}
        (Hls : oname_list_unique ls)
        (H : split_onames _ ls = (Some N, ls')%core)
    : @find_Name_and_val var' t n T N V None = Some v
      <-> List.In (existT (fun t => (Name * var' t)%type) t (n, v)) (Wf.flatten_binding_list N V).
  Proof.
    revert dependent ls; intro ls; revert ls ls'; induction T; intros;
      [ | | specialize (IHT1 (fst N) (fst V) ls (snd (split_onames T1 ls)));
            specialize (IHT2 (snd N) (snd V) (snd (split_onames T1 ls)) (snd (split_onames (T1 * T2) ls))) ];
      repeat first [ find_Name_and_val_default_to_None_step
                   | progress simpl in *
                   | rewrite List.in_app_iff
                   | misc_oname_t_step
                   | t_step
                   | progress split_iff
                   | lazymatch goal with
                     | [ H : find_Name ?n ?x = Some ?t, H' : find_Name_and_val ?t' ?n ?X ?V None = Some ?v |- _ ]
                       => apply find_Name_and_val_find_Name_Some in H'
                     | [ H : find_Name ?n ?x = Some ?t, H' : find_Name ?n ?x' = Some ?t' |- _ ]
                       => let apply_in_tac H :=
                              (eapply split_onames_find_Name_Some_unique in H;
                               [ | | apply path_prod_uncurried; split; [ eassumption | simpl; reflexivity ] ];
                               [ | solve [ eauto using oname_list_unique_firstn, oname_list_unique_skipn ] ]) in
                          first [ constr_eq x x'; fail 1
                                | apply_in_tac H; apply_in_tac H' ]
                     end ].
  Qed.

  Lemma fst_split_mnames__flatten_binding_list__find_Name
        (MName : Type) (force : MName -> option Name)
        {var' t n T N V v} {ls : list MName}
        (Hs : fst (split_mnames force T ls) = Some N)
        (HN : List.In (existT _ t (n, v)%core) (Wf.flatten_binding_list (var2:=var') N V))
    : find_Name n N = Some t.
  Proof.
    revert dependent ls; induction T;
      [ | | specialize (IHT1 (fst N) (fst V));
            specialize (IHT2 (snd N) (snd V)) ];
      repeat first [ misc_oname_t_step
                   | t_step
                   | match goal with
                     | [ H : _ |- _ ] => first [ rewrite snd_split_mnames_skipn in H
                                               | rewrite List.in_app_iff in H ]
                     | [ H : context[fst (split_mnames _ _ ?ls)] |- _ ]
                       => is_var ls; rewrite (@fst_split_mnames_firstn _ _ _ _ _ ls) in H
                     end ].
  Abort.

  Lemma fst_split_mnames__find_Name__flatten_binding_list
        (MName : Type) (force : MName -> option Name)
        {var' t n T N V v default} {ls : list MName}
        (Hs : fst (split_mnames force T ls) = Some N)
        (Hfind : find_Name n N = Some t)
        (HN : List.In (existT _ t (n, v)%core) (Wf.flatten_binding_list N V))
    : @find_Name_and_val var' t n T N V default = Some v.
  Proof.
    revert default; revert dependent ls; induction T;
      [ | | specialize (IHT1 (fst N) (fst V));
            specialize (IHT2 (snd N) (snd V)) ];
      repeat first [ find_Name_and_val_default_to_None_step
                   | rewrite List.in_app_iff in *
                   | t_step ].
  Abort.
End with_context.


Unset Strict Universe Declaration.
(* File reduced by coq-bug-finder from original input, then from 11542 lines to 325 lines, then from 347 lines to 56 lines, then from 58 lines to 15 lines *)
(* coqc version trunk (September 2014) compiled on Sep 25 2014 2:53:46 with OCaml 4.01.0
   coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (bec7e0914f4a7144cd4efa8ffaccc9f72dbdb790) *)

Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y.
Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing).
Inductive V : Type@{U'} := | set {A : Type@{U}} (f : A -> V) : V.
Module NonPrim.
  Record hProp := hp { hproptype :> Type ; isp : Set}.
  Goal forall (A B : Type) (H_f : A -> V -> hProp) (H_g : B -> V -> hProp)
              (C : Type) (h : C -> V) (b : B) (a : A) (c : C),
         H_f a (h c) -> H_f a (h c) = H_g b (h c) -> H_g b (h c).
    intros A B H_f H_g C h b a c H3 H'.
    exact (@transport hProp (fun x => x) _ _ H' H3).
    Undo.
    Set Debug Unification.
    exact (H' # H3).
  Defined.
End NonPrim.

Module Prim.
  Set Primitive Projections.
  Set Universe Polymorphism.
  Record hProp := hp { hproptype :> Type ; isp : Set}.
  Goal forall (A B : Type) (H_f : A -> V -> hProp) (H_g : B -> V -> hProp)
              (C : Type) (h : C -> V) (b : B) (a : A) (c : C),
         H_f a (h c) -> H_f a (h c) = H_g b (h c) -> H_g b (h c).
    intros A B H_f H_g C h b a c H3 H'.
    exact (@transport hProp (fun x => x) _ _ H' H3).
    Undo.
    Set Debug Unification.
    exact (H' # H3).
    (* Toplevel input, characters 7-14:
Error:
In environment
A : Type
B : Type
H_f : A -> V -> hProp
H_g : B -> V -> hProp
C : Type
h : C -> V
b : B
a : A
c : C
H3 : H_f a (h c)
H' : H_f a (h c) = H_g b (h c)
Unable to unify "hproptype (H_f a (h c))" with "?T (H_f a (h c))".
 *)
  Defined.
End Prim.


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

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

(** These are the notations whose level and associativity are imposed by Coq *)

(** Notations for propositional connectives *)

Reserved Notation "x <-> y" (at level 95, no associativity).
Reserved Notation "x /\ y" (at level 80, right associativity).
Reserved Notation "x \/ y" (at level 85, right associativity).
Reserved Notation "~ x" (at level 75, right associativity).

(** Notations for equality and inequalities *)

Reserved Notation "x = y  :>  T"
(at level 70, y at next level, no associativity).
Reserved Notation "x = y" (at level 70, no associativity).
Reserved Notation "x = y = z"
(at level 70, no associativity, y at next level).

Reserved Notation "x <> y  :>  T"
(at level 70, y at next level, no associativity).
Reserved Notation "x <> y" (at level 70, no associativity).

Reserved Notation "x <= y" (at level 70, no associativity).
Reserved Notation "x < y" (at level 70, no associativity).
Reserved Notation "x >= y" (at level 70, no associativity).
Reserved Notation "x > y" (at level 70, no associativity).

Reserved Notation "x <= y <= z" (at level 70, y at next level).
Reserved Notation "x <= y < z" (at level 70, y at next level).
Reserved Notation "x < y < z" (at level 70, y at next level).
Reserved Notation "x < y <= z" (at level 70, y at next level).

(** Arithmetical notations (also used for type constructors) *)

Reserved Notation "x + y" (at level 50, left associativity).
Reserved Notation "x - y" (at level 50, left associativity).
Reserved Notation "x * y" (at level 40, left associativity).
Reserved Notation "x / y" (at level 40, left associativity).
Reserved Notation "- x" (at level 35, right associativity).
Reserved Notation "/ x" (at level 35, right associativity).
Reserved Notation "x ^ y" (at level 30, right associativity).

(** Notations for booleans *)

Reserved Notation "x || y" (at level 50, left associativity).
Reserved Notation "x && y" (at level 40, left associativity).

(** Notations for pairs *)

Reserved Notation "( x , y , .. , z )" (at level 0).

(** Notation "{ x }" is reserved and has a special status as component
    of other notations such as "{ A } + { B }" and "A + { B }" (which
    are at the same level than "x + y");
    "{ x }" is at level 0 to factor with "{ x : A | P }" *)

Reserved Notation "{ x }" (at level 0, x at level 99).

(** Notations for sigma-types or subsets *)

Reserved Notation "{ x  |  P }" (at level 0, x at level 99).
Reserved Notation "{ x  |  P  & Q }" (at level 0, x at level 99).

Reserved Notation "{ x : A  |  P }" (at level 0, x at level 99).
Reserved Notation "{ x : A  |  P  & Q }" (at level 0, x at level 99).

Reserved Notation "{ x : A  & P }" (at level 0, x at level 99).
Reserved Notation "{ x : A  & P  & Q }" (at level 0, x at level 99).

Delimit Scope type_scope with type.
Delimit Scope core_scope with core.

Open Scope core_scope.
Open Scope type_scope.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

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 2.1 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 GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Reals.
Require Export Rfunction_def.

Open Scope Rfun_scope.

(** Compatibility of extensional equality *)

Ltac extensional_reflexivity H Heq :=
let swap H1 H2 :=
  clear H1;
  assert (H1 := H2);
  clear H2
in
let rec refl_aux H :=
match goal with
| |- forall x, _ =>
  let x := fresh "x" in
  let nH := fresh in
  intros x;
  assert (nH := H x);
  swap H nH;
  refl_aux H
| |- exists x, _ =>
  let x := fresh "x" in
  destruct H as [x H];
  exists x;
  refl_aux H
| |- ?P /\ ?Q =>
  let Hl := fresh "H" in
  let Hr := fresh "H" in
  destruct H as [Hl Hr];
  split; [refl_aux Hl|refl_aux Hr]
| |- ?P \/ ?Q =>
  let Hl := fresh "H" in
  let Hr := fresh "H" in
  destruct H as [Hl|Hr];
  [refl_aux Hl|refl_aux Hr]
| _ =>
  repeat (rewrite <- Heq); apply H
end in
compute in H |- *; refl_aux H.

Section Rfun_eq.

Variables f g : R -> R.
Hypothesis Heq : f == g.

Lemma Rfun_continuity_pt_eq_compat :
  forall x, continuity_pt f x -> continuity_pt g x.
Proof.
  intros x Hct eps H.
  specialize (Hct eps H).
  destruct Hct as (alp & pos & HH).
  exists alp. split; auto.
  intros x0 H0.
  specialize (HH x0 H0).
  eauto.
  repeat rewrite <-Heq.
  auto.
Qed.

Lemma Rfun_continuity_eq_compat :
  continuity f -> continuity g.
Proof.
  intros H i a p.
  destruct (H i a p).
  exists x. intuition.
  repeat rewrite <-Heq.
  eauto.
Qed.

End Rfun_eq.


(* 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                                                     *)

(* A set, with the axiom of decidability of the equality,               *)
(* is enumerable if it exists a list of its elements.                   *)

(* the following notions are defined :                                  *)
(*      - U_enumerable : set with a list of its elements                *)
(*      - U_canon : list with unique occurrence of its elements         *)
(*              constructors : U_canon_nil, U_canon_cons.               *)
(*      - U_sum : sommation of the images of a list.                    *)

Require Export Sets.
Require Export List.

Section ENUMERATION.

Variable U : Set.

Hypothesis U_separable : forall x y : U, {x = y} + {x <> y}.

Definition U_list := list U.

Definition U_enumerable (E : U_set U) :=
  {ul : U_list | forall x : U, E x -> In x ul}.

Inductive U_canon : U_list -> Prop :=
  | U_canon_nil : U_canon nil
  | U_canon_cons :
      forall (x : U) (ul : U_list),
      U_canon ul -> ~ In x ul -> U_canon (x :: ul).

Lemma U_in_dec : forall (x : U) (ul : U_list), {In x ul} + {~ In x ul}.
Proof.
        simple induction ul; intros.
        right; red in |- *; intros; inversion H.

        case (U_separable x a); intros.
        left; rewrite e; simpl in |- *; auto.

        case H; intros.
        left; simpl in |- *; auto.

        right; red in |- *; intros; inversion H0.
        elim n; auto.

        elim n0; auto.
Qed.

Variable f : U -> nat.

Fixpoint U_sum (ul : U_list) : nat :=
  match ul with
  | nil => 0
  | x :: ul' => f x + U_sum ul'
  end.

Lemma U_enumerable_sum : forall E : U_set U, U_enumerable E -> nat.
Proof.
        intros; elim H; intros.
        apply (U_sum x).
Defined.

End ENUMERATION.