Require Import VST.floyd.proofauto.
Require Import sha.sha.
Require Import sha.SHA256.
Require Import sha.spec_sha.
Require Import sha.sha_lemmas.
Local Open Scope nat.
Local Open Scope logic.
Import LiftNotation.

Lemma Zlength_list_repeat:
  forall {A} n (x:A), Zlength (list_repeat (Z.to_nat n) x) = Z.max 0 n.
Proof.
intros.
rewrite Zlength_correct, length_list_repeat.
destruct (zlt n 0).
rewrite Z.max_l by omega.
rewrite Z2Nat_neg by auto. reflexivity.
rewrite Z2Nat.id by omega.
rewrite Z.max_r by omega.
auto.
Qed.

Import field_at_wand.SegmentHole.

Lemma splice_into_list_simplify0:
  forall {A} n (src dst: list A),
    Zlength src = n ->
    Zlength dst = n ->
    splice_into_list 0 n src dst = src.
Proof.
 intros.
 unfold splice_into_list.
rewrite !sublist_nil.
rewrite app_nil_l.
pose proof (Zlength_nonneg src).
rewrite sublist_nil' by omega.
rewrite app_nil_r.
auto.
Qed.

Lemma splice_into_list_self:
  forall {A} lo hi (l: list A),
    (0 <= lo <= hi)%Z ->
    (hi <= Zlength l)%Z ->
    splice_into_list lo hi (sublist lo hi l) l = l.
Proof.
 intros.
 unfold splice_into_list.
 autorewrite with sublist.
 auto.
Qed.
(*
Lemma splice_into_list_simplify1:
  forall lo hi src tgt,
    lo = Zlength tgt ->
    (hi-lo = Zlength src)%Z ->
    splice_into_list lo hi src tgt = tgt++src.
Proof.
intros; subst; unfold splice_into_list.
pose proof (Zlength_nonneg tgt).
pose proof (Zlength_nonneg src).
rewrite H0.
rewrite Z.sub_diag.
change (Z.to_nat 0) with 0%nat; simpl.
rewrite <- app_nil_end.
rewrite sublist_same by omega.
f_equal.
rewrite (sublist_nil hi), <- app_nil_end.
rewrite sublist_app by (rewrite ?Zlength_list_repeat, ?Z.max_r; omega).
rewrite ?Z.min_l by omega.
rewrite ?Z.max_r by omega.
rewrite sublist_nil, <- app_nil_end.
apply sublist_same; omega.
Qed.

Lemma splice_into_list_simplify2:
  forall lo hi src tgt,
    lo = Zlength tgt ->
    (lo <= hi)%Z ->
    (hi-lo <= Zlength src)%Z ->
    splice_into_list lo hi hi src tgt = tgt++ sublist 0 (hi-lo) src.
Proof.
intros; subst; unfold splice_into_list.
pose proof (Zlength_nonneg tgt).
pose proof (Zlength_nonneg src).
repeat rewrite Z.sub_diag.
change (Z.to_nat 0) with 0.
unfold list_repeat at 1.
rewrite <- app_nil_end.
rewrite sublist_same by omega.
f_equal.
rewrite sublist_nil, <- app_nil_end by omega.
rewrite sublist_app by (rewrite ?Zlength_list_repeat, ?Z.max_r; omega).
rewrite ?Z.min_l by omega.
rewrite ?Z.max_r by omega.
rewrite sublist_nil, <- app_nil_end by omega.
auto.
Qed.
*)
Lemma JMeq_skipn:
  forall ta tb n (la: list ta) (lb: list tb),
     ta=tb ->
     JMeq la lb ->
     JMeq (skipn n la) (skipn n lb).
Proof.
intros. subst tb. apply JMeq_eq in H0. subst lb. auto.
Qed.

Lemma JMeq_firstn:
  forall ta tb n (la: list ta) (lb: list tb),
    ta=tb -> JMeq la lb -> JMeq (firstn n la) (firstn n lb).
Proof.
intros. subst tb. apply JMeq_eq in H0. subst lb. auto.
Qed.

Lemma JMeq_length:
  forall ta tb (la: list ta) (lb: list tb),
     ta=tb -> JMeq la lb -> length la = length lb.
Proof.
intros. subst tb.  apply JMeq_eq in H0. subst lb. auto.
Qed.

Lemma JMeq_sublist:
  forall ta tb lo hi (la: list ta) (lb: list tb),
    ta=tb -> JMeq la lb -> JMeq (sublist lo hi la) (sublist lo hi lb).
Proof.
intros. subst tb. apply JMeq_eq in H0. subst lb. auto.
Qed.

 Definition fsig_of_funspec (fs: funspec)  :=
  match fs with mk_funspec fsig _ _ _ _ _ _=> fsig end.

Lemma part1_splice_into_list:
  forall {A} lo hi (al bl: list A),
    (0 <= lo <= Zlength bl)%Z ->
    sublist 0 lo (splice_into_list lo hi al bl) = sublist 0 lo bl.
Proof.
 intros.
 unfold splice_into_list.
 rewrite (sublist_app); rewrite ?Zlength_list_repeat, ?Z.max_l by omega; try omega;
 rewrite ?Zlength_sublist by omega;
 try (rewrite ?Zlength_correct; omega).
rewrite ?Z.min_l by omega.
rewrite ?Z.max_r by omega.
rewrite sublist_nil, <- app_nil_end by omega.
rewrite sublist_same; auto.
rewrite Zlength_sublist; omega.
Qed.

Lemma part3_splice_into_list:
  forall {A} lo hi n (al bl: list A),
    (0 <= lo <= hi)%Z -> (hi <= n)%Z ->
   (Zlength bl = n)%Z ->
   (Zlength al = hi-lo)%Z ->
    sublist hi n (splice_into_list lo hi al bl) = sublist hi n bl.
Proof.
 intros.
 unfold splice_into_list.
rewrite <- app_ass.
 rewrite (sublist_app); rewrite ?Zlength_list_repeat, ?Z.max_r, ?Z.max_l by omega; try omega;
 rewrite ?Zlength_sublist by omega;
 try (rewrite ?Zlength_correct; omega).
rewrite !Zlength_app.
rewrite Zlength_sublist; try omega.
rewrite ?Z.min_r by omega.
rewrite ?Z.max_r by omega.
rewrite sublist_nil by omega.
simpl.
rewrite Z.max_l by omega.
rewrite sublist_sublist by omega.
f_equal. omega.
rewrite !Zlength_app.
rewrite !Zlength_sublist; omega.
Qed.

Lemma Zlength_splice_into_list:
  forall {A} lo hi (al bl: list A),
    (0 <= lo <= hi)%Z -> (hi <= Zlength bl)%Z ->
    (hi - lo = Zlength al)%Z ->
    Zlength (splice_into_list lo hi al bl) = Zlength bl.
Proof.
intros.
unfold splice_into_list.
rewrite !Zlength_app.
rewrite !Zlength_sublist; rewrite ?Zlength_app; rewrite ?Zlength_list_repeat; try omega.
Qed.

Local Arguments nested_field_type cs t gfs : simpl never.

Lemma semax_call_id0_alt:
 forall Espec {cs: compspecs} Delta P Q R id bl argsig tfun retty cc A x Pre Post
   (GLBL: (var_types Delta) ! id = None),
       (glob_specs Delta) ! id = Some (NDmk_funspec (argsig, retty) cc A Pre Post) ->
       (glob_types Delta) ! id = Some (type_of_funspec (NDmk_funspec (argsig, retty) cc A Pre Post)) ->
   tfun = type_of_params argsig ->
  @semax cs Espec Delta (tc_exprlist Delta (argtypes argsig) bl
                  && |>((`(Pre x) (make_args' (argsig,retty) (eval_exprlist (argtypes argsig) bl))
                         * PROPx P (LOCALx Q (SEPx R)))))
    (Scall None (Evar id (Tfunction tfun retty cc)) bl)
    (normal_ret_assert
       ((ifvoid retty (`(Post x) (make_args nil nil))
                                                   (EX v:val, `(Post x) (make_args (ret_temp::nil) (v::nil))))
         * PROPx P (LOCALx Q (SEPx R)))).
Proof.
intros.
subst tfun.
apply (@semax_call_id0 Espec cs Delta P Q R id bl (NDmk_funspec (argsig, retty) cc A Pre Post) argsig retty cc (rmaps.ConstType A) nil x
                  (fun _ => Pre) (fun _ => Post)
               (const_super_non_expansive _ _)
               (const_super_non_expansive _ _)); auto.
apply funspec_sub_refl.
Qed.

Lemma call_memcpy_tuchar:  (* Uses CompSpecs from sha. *)
  forall (shp : share) (tp: type) (pathp: list gfield) (lop: Z) (vp': list val) (p: val)
           (shq: share) (tq: type) (pathq: list gfield) (loq: Z) (contents: list int) (q: val)
           (len : Z)
           (R': list mpred)
           (np nq : Z)
           (vp vp'': reptype (nested_field_type tp pathp))
           (vq : reptype (nested_field_type tq pathq))
           (e_p e_q e_n : expr)
           Espec Delta P Q R,
      typeof e_p = tptr tuchar ->
      typeof e_q = tptr tuchar ->
      typeof e_n = tuint ->
      (var_types Delta) ! _memcpy = None ->
     (glob_specs Delta) ! _memcpy = Some (snd memcpy_spec) ->
     (glob_types Delta) ! _memcpy = Some (type_of_funspec (snd memcpy_spec)) ->
     writable_share shp ->  readable_share shq ->
     nested_field_type tp pathp = tarray tuchar np ->
     nested_field_type tq pathq = tarray tuchar nq ->
     (0 <= lop)%Z ->
     (0 <= len <= Int.max_unsigned)%Z ->
     (lop + len <= np)%Z ->
     (0 <= loq)%Z ->  (loq + len <=  (*Zlength contents <=*) nq)%Z ->
     JMeq vq (map Vint contents) ->
     JMeq vp vp' ->
     JMeq vp'' (splice_into_list lop (lop+len) (sublist loq (loq + len) (map Vint contents)) vp') ->
     ENTAIL Delta, PROPx P (LOCALx Q (SEPx R)) |--
         tc_exprlist Delta [tptr tvoid; tptr tvoid; tuint] [e_p; e_q; e_n]  &&
         local (`(eq (field_address0 tp (ArraySubsc lop :: pathp) p)) (eval_expr e_p)) &&
         local (`(eq (field_address0 tq (ArraySubsc loq :: pathq) q)) (eval_expr e_q)) &&
         local (`(eq (Vint (Int.repr len))) (eval_expr e_n)) &&
         PROP () (LOCALx Q (SEPx (field_at shp tp pathp vp p ::
                                                 field_at shq tq pathq vq q :: R'))) ->
   @semax _ Espec Delta
    (PROPx P (LOCALx Q (SEPx R)))
    (Scall None
             (Evar _memcpy
               (Tfunction
                (Tcons (tptr tvoid) (Tcons (tptr tvoid) (Tcons tuint Tnil)))
                  (tptr tvoid) cc_default))
              [e_p; e_q; e_n])
    (normal_ret_assert (PROPx P (LOCALx Q
     (SEPx (field_at shp tp pathp vp'' p ::
               field_at shq tq pathq vq q :: R'))))).
Proof.
intros until R.
intros TCp TCq TCn Hvar Hspec Hglob ? SHq ? ? Hlop Hlen Hnp Hloq Hnq; intros.
assert_PROP (fold_right and True P); [ old_go_lower; entailer! | ].
apply semax_post' with
   (PROPx nil   (LOCALx Q
           (SEPx
              (field_at shp tp pathp vp'' p
               :: field_at shq tq pathq vq q :: R'))));
 [ old_go_lower; entailer! | ].
clear H6. rename H5 into Hpre.
assert_PROP (Zlength vp' = np /\ Zlength contents = nq). {
eapply derives_trans; [apply Hpre |].
apply andp_left2.
old_go_lower; entailer!.
clear - H7 H9 H0 H1 H2 H3 H Hlop Hloq Hnp Hnq Hlen.
forget (nested_field_type tp pathp) as t0.
forget (nested_field_type tq pathq) as t1.
subst t0 t1.
simplify_value_fits in H7. destruct H7 as [H7 _].
simplify_value_fits in H9. destruct H9 as [H9 _].
apply JMeq_eq in H3. subst vp; auto.
apply JMeq_eq in H2. subst vq; auto.
rewrite Zlength_map in H9.
split; auto.
} destruct H5 as [Hvp' Hvq'].

assert (reptype (tarray tuchar np) = list val) by reflexivity.
rewrite <- H0 in H5.
assert (H99: reptype (nested_field_type tp (ArraySubsc 0 :: pathp)) = val)
  by (rewrite nested_field_type_ind, H0; reflexivity).
assert (exists vpx : list (reptype (nested_field_type tp (ArraySubsc 0 :: pathp))),
                    JMeq vp vpx)
  by (rewrite H99, <- H5; exists vp; auto).
destruct H6 as [vpx Hvpx].
assert_PROP (legal_nested_field tp pathp /\ legal_nested_field tq pathq). {
  eapply derives_trans; [apply Hpre | apply andp_left2].
old_go_lower; entailer!.
} destruct H6 as [LNFp LNFq].

pose (witness := ((shq,shp),
                              field_address0 tp (ArraySubsc lop :: pathp) p,
                              field_address0 tq (ArraySubsc loq :: pathq) q,
                              len,  sublist loq (loq+len) contents)).
pose (Frame :=
        array_with_hole shq tuchar loq (loq + len) nq (map Vint contents) (field_address tq pathq q)
          :: array_with_hole shp tuchar lop (lop + len) np vp' (field_address tp pathp p) :: R').
eapply semax_pre_post';
  [ | | eapply semax_call_id0_alt with (x:=witness)(P:=nil)(Q:=Q);
       try eassumption;
       try (rewrite ?Hspec, ?Hglob; reflexivity)].

*
 rewrite <- (andp_dup (local (tc_environ _))), andp_assoc.
 eapply derives_trans; [ apply andp_derives; [apply derives_refl | apply Hpre] | ].
 rewrite !andp_assoc.
 apply andp_right; [apply andp_left2, andp_left1, derives_refl |].
 eapply derives_trans; [ | apply now_later].
 assert_PROP (field_address0 tp (pathp SUB lop) p <> Vundef) as DEFp.
 {
   unfold tc_exprlist.
   simpl typecheck_exprlist.
   rewrite !denote_tc_assert_andp.
   apply derives_trans with (local (tc_environ Delta) && denote_tc_assert (typecheck_expr Delta e_p) && local ((` (eq (field_address0 tp (pathp SUB lop) p))) (eval_expr e_p))); [solve_andp |].
   go_lowerx.
   eapply derives_trans; [apply typecheck_expr_sound; auto |].
   apply prop_derives; intros.
   rewrite <- H7 in H8.
   intro.
   rewrite H9 in H8.
   revert H8; apply tc_val_Vundef.
 }
 assert_PROP (field_address0 tq (pathq SUB loq) q <> Vundef) as DEFq.
 {
   unfold tc_exprlist.
   simpl typecheck_exprlist.
   rewrite !denote_tc_assert_andp.
   apply derives_trans with (local (tc_environ Delta) && denote_tc_assert (typecheck_expr Delta e_q) && local ((` (eq (field_address0 tq (pathq SUB loq) q))) (eval_expr e_q))); [solve_andp |].
   go_lowerx.
   eapply derives_trans; [apply typecheck_expr_sound; auto |].
   apply prop_derives; intros.
   rewrite <- H7 in H8.
   intro.
   rewrite H9 in H8.
   revert H8; apply tc_val_Vundef.
 }
 apply andp_left2, andp_left2.
 subst witness. cbv beta iota. simpl @fst; simpl @snd.
 clear Hpre.
 autorewrite with norm1 norm2.
 rewrite PROP_combine.
 unfold app at 1.
 instantiate (1:=Frame).
 unfold app at 2.
 go_lowerx.
 apply andp_right.
 apply prop_right.
 unfold make_args'. simpl.
 unfold eval_id, env_set.
 rewrite TCp, TCq, TCn.  simpl.
 unfold_lift; simpl.
 rewrite <- H6, <- H7, <- H8.
 split3; try (repeat split; auto; congruence).
 apply andp_right.
 apply prop_right; split3; auto.
 subst Frame.
 normalize.
 cancel.
 rewrite !field_at_data_at.
 rewrite (data_at_type_changable _ _ _ _ _ H0 H3).
 rewrite (data_at_type_changable _ _ _ _ _ H1 H2).
 sep_apply (array_with_hole_intro shp tuchar lop (lop + len) np vp' (field_address tp pathp p)); [omega | ].
 sep_apply (array_with_hole_intro shq tuchar loq (loq + len) nq (map Vint contents) (field_address tq pathq q)); [omega | ].
 cancel.
 apply sepcon_derives.
 - apply derives_refl'.
   rewrite <- H1.
   rewrite <- field_address0_app by congruence.
   simpl app.
   apply equal_f.
   apply data_at_type_changable.
   + f_equal; clear; omega.
   + rewrite <- sublist_map.
     apply JMeq_sublist; auto.
 - replace (memory_block shp len) with
     (memory_block shp (sizeof (nested_field_array_type tp pathp lop (lop + len)))).
   2: {
     f_equal. unfold nested_field_array_type.
     rewrite nested_field_type_ind. rewrite H0. simpl.
     rewrite Z.max_r by omega. rewrite Z.mul_1_l. clear; omega.
   }
   eapply derives_trans; [ | apply data_at__memory_block_cancel]; cancel.
   rewrite <- H0.
   rewrite <- field_address0_app by congruence.
   simpl app.
   unfold nested_field_array_type, tarray.
   rewrite nested_field_type_ind, H0.
   apply data_at_data_at_.
 *
 intros. apply andp_left2.
 go_lowerx. unfold_lift.
 simpl.
 Intros x. rewrite prop_true_andp by auto.
 rewrite map_sublist.
 clear witness Frame.
 normalize in H7.
 subst x.
 simpl.
 clear Hpre H6 P Q rho .
assert (exists (vpy : list (reptype (nested_field_type tp (ArraySubsc 0 :: pathp)))),
                  JMeq vp'' vpy)
  by (rewrite H99; eauto).
destruct H6 as [vpy H7].
assert (Zlength vpy = np). {
 assert (JMeq vpy  (splice_into_list lop (lop + len)
          (sublist loq (loq + len) (map Vint contents)) vp')) by (eapply JMeq_trans; [apply @JMeq_sym |]; eassumption).
 transitivity (Zlength  (splice_into_list lop (lop + len)
          (sublist loq (loq + len) (map Vint contents)) vp')).
 clear - H6 H99 H5.
 forget (splice_into_list lop (lop + len)
          (sublist loq (loq + len) (map Vint contents)) vp') as vv.
 forget val as t. subst t. apply JMeq_eq in H6. subst; auto.
 rewrite Zlength_splice_into_list; try omega.
 autorewrite with sublist; auto.
}
cancel.
change (ArraySubsc loq :: pathq) with ([ArraySubsc loq] ++ pathq).
change (ArraySubsc lop :: pathp) with ([ArraySubsc lop] ++ pathp).
rewrite !field_address0_app by congruence.
rewrite H0, H1.
erewrite (data_at_type_changable shq _ (tarray tuchar (loq + len - loq)));
[| f_equal; omega | apply JMeq_refl].
erewrite (data_at_type_changable shp _ (tarray tuchar (lop + len - lop)));
[| f_equal; omega | apply JMeq_refl].
sep_apply (array_with_hole_elim shp tuchar lop (lop + len) np (sublist loq (loq + len) (map Vint contents)) vp' (field_address tp pathp p)).
sep_apply (array_with_hole_elim shq tuchar loq (loq + len) nq (sublist loq (loq + len) (map Vint contents)) (map Vint contents) (field_address tq pathq q)).
rewrite !field_at_data_at.
rewrite sepcon_comm.
apply sepcon_derives.
- apply derives_refl'.
  apply equal_f.
  apply data_at_type_changable; auto.
- apply derives_refl'.
  apply equal_f.
  apply data_at_type_changable; auto.
  eapply JMeq_trans; [| apply JMeq_sym, H2].
  apply eq_JMeq.
  apply splice_into_list_self.
  { omega. }
  { autorewrite with sublist. omega. }
Qed.

Lemma call_memset_tuchar:
  forall (shp : share) (tp: type) (pathp: list gfield) (lop: Z) (vp': list val) (p: val)
           (c: int) (len : Z)
           (R': list mpred)
           (np : Z)
           (vp vp'': reptype (nested_field_type tp pathp))
           (e_p e_c e_n : expr)
           Espec Delta P Q R (s: signedness)
   (TCp : typeof e_p = tptr tuchar)
   (TCc : typeof e_c = tint)
   (TCn : typeof e_n = Tint I32 s noattr)
   (Hvar : (var_types Delta) ! _memset = None)
   (Hspec : (glob_specs Delta) ! _memset = Some (snd memset_spec))
   (Hglob : (glob_types Delta) ! _memset =
        Some (type_of_funspec (snd memset_spec)))
   (H:  writable_share shp)
   (Hlop : (0 <= lop)%Z)
   (Hlen: (0 <= len <= Int.max_unsigned)%Z)
   (H0:  nested_field_type tp pathp = tarray tuchar np)
   (Hnp : (lop + len <= np)%Z)
   (H3:  JMeq vp vp')
   (H4:  JMeq vp'' (splice_into_list lop (lop+len) (list_repeat (Z.to_nat len) (Vint c)) vp'))
   (H5: ENTAIL Delta, PROPx P (LOCALx Q (SEPx R)) |--
         tc_exprlist Delta [tptr tvoid; tint; tuint] [e_p; e_c; e_n] &&
         local (`(eq (field_address0 tp (ArraySubsc lop :: pathp) p)) (eval_expr e_p)) &&
         local (`(eq (Vint c)) (eval_expr e_c)) &&
         local (`(eq (Vint (Int.repr len))) (eval_expr e_n)) &&
         PROP () (LOCALx Q (SEPx (field_at shp tp pathp vp p :: R')))),
   @semax _ Espec Delta
    (PROPx P (LOCALx Q (SEPx R)))
    (Scall None
             (Evar _memset
               (Tfunction
                (Tcons (tptr tvoid) (Tcons tint (Tcons tuint Tnil)))
                  (tptr tvoid) cc_default))
              [e_p; e_c; e_n])
    (normal_ret_assert (PROPx P (LOCALx Q
     (SEPx (field_at shp tp pathp vp'' p :: R'))))).
Proof.
intros.
assert_PROP (fold_right and True P)
  by (old_go_lower; entailer!).
apply semax_post' with
   (PROPx nil   (LOCALx Q
           (SEPx (field_at shp tp pathp vp'' p :: R'))));
 [ old_go_lower; entailer! | ].
rename H5 into Hpre.
clear H1.
assert_PROP (Zlength vp' = np). {
eapply derives_trans; [apply Hpre | apply andp_left2].
old_go_lower; entailer!.
clear - H5 H4 H3 Hnp H0 Hlen Hlop.
forget (nested_field_type tp pathp) as t0.
subst t0.
simplify_value_fits in H5. destruct H5 as [H5 _].
apply JMeq_eq in H3. subst vp; auto.
} rename H1 into Hvp'.
assert (H5: reptype (tarray tuchar np) = list val) by reflexivity.
rewrite <- H0 in H5.
assert (H99: reptype (nested_field_type tp (ArraySubsc 0 :: pathp)) = val).
 clear - H0. unfold nested_field_type in *; simpl in *.
  destruct (nested_field_rec tp pathp); inv H0. destruct p. subst.
 reflexivity.
assert (H6: exists vpx : list (reptype (nested_field_type tp (ArraySubsc 0 :: pathp))),
                    JMeq vp' vpx).
rewrite H99. eauto.
destruct H6 as [vpx Hvpx].
assert_PROP (legal_nested_field tp pathp). {
  eapply derives_trans; [apply Hpre | apply andp_left2].
old_go_lower; entailer!.
} rename H1 into LNFp.
apply (fun H => JMeq_trans H Hvpx) in H3.
assert (LENvpx: Zlength vpx = np). {
clear - H99 Hvp' Hvpx.
forget val as t. subst t.
apply JMeq_eq in Hvpx. subst; auto.
}
erewrite field_at_Tarray in Hpre; try eassumption; auto; try omega.
rewrite (split3seg_array_at shp tp pathp 0 lop (lop+len)) in Hpre by omega.
rewrite !Z.sub_0_r in Hpre.

assert_PROP (field_compatible0 tp (pathp SUB lop) p /\
            field_compatible0 tp (pathp SUB (lop + len)) p)
  as FC. {
 eapply derives_trans; [apply Hpre | clear Hpre].
 go_lowerx. apply andp_left2. normalize.
 saturate_local.
 apply prop_right.
 split; auto.
}
pose (witness := (shp,
                              field_address0 tp (ArraySubsc lop :: pathp) p,
                              len,  c)).
pose (Frame :=
         array_at shp tp pathp (lop + len) np
              (sublist (lop+len) np vpx) p
          :: array_at shp tp pathp 0 lop (sublist 0 lop vpx) p
              :: R').
eapply semax_pre_post';
  [ | | eapply semax_call_id0_alt with (x:=witness)(P:=nil)(Q:=Q);
       try eassumption;
       try (rewrite ?Hspec, ?Hglob; reflexivity)].
*
 rewrite <- (andp_dup (local (tc_environ _))), andp_assoc.
 eapply derives_trans; [ apply andp_derives; [apply derives_refl | apply Hpre] | ].
 rewrite !andp_assoc.
 apply andp_right; [apply andp_left2, andp_left1, derives_refl |].
 eapply derives_trans; [ | apply now_later].
 assert_PROP (field_address0 tp (pathp SUB lop) p <> Vundef) as DEFp.
 {
   unfold tc_exprlist.
   simpl typecheck_exprlist.
   rewrite !denote_tc_assert_andp.
   apply derives_trans with (local (tc_environ Delta) && denote_tc_assert (typecheck_expr Delta e_p) && local ((` (eq (field_address0 tp (pathp SUB lop) p))) (eval_expr e_p))); [solve_andp |].
   go_lowerx.
   eapply derives_trans; [apply typecheck_expr_sound; auto |].
   apply prop_derives; intros.
   rewrite <- H2 in H6.
   intro.
   rewrite H7 in H6.
   revert H6; apply tc_val_Vundef.
 }
 apply andp_left2, andp_left2.
 subst witness. cbv beta iota. simpl @fst; simpl @snd.
 clear Hpre.
 autorewrite with norm1 norm2.
 rewrite PROP_combine.
 unfold app at 1.
 instantiate (1:=Frame).
 unfold app at 2.
 simpl argtypes. unfold eval_exprlist.
 unfold make_args'. simpl map at 2.
 rewrite TCp, TCc, TCn.
 go_lowerx. unfold env_set, eval_id. unfold_lift. simpl.
 autorewrite with gather_prop.
 apply andp_right.
 apply prop_right. split3; try (repeat split; auto; congruence).
 normalize.
 subst Frame.
 cancel.
 rewrite array_at_data_at' by  (try solve [clear - FC; intuition]; omega).
 eapply derives_trans; [apply data_at_data_at_ | ].
 eapply derives_trans; [apply data_at__memory_block_cancel | ].
 apply derives_refl'; f_equal.
  unfold nested_field_array_type.
   rewrite nested_field_type_ind, H0. simpl.
  rewrite Z.max_r by omega. omega.
*
 intros. apply andp_left2.
 unfold ifvoid. unfold tptr at 1.
 Intros v. subst witness. cbv beta zeta iota.
 clear Hpre.
 autorewrite with norm1 norm2.
 rewrite PROP_combine.
 unfold app at 1.
 subst Frame.
 simpl map.
 old_go_lower. normalize.
 cancel.
 clear H1 H2.
 assert (H2: exists (vpy : list (reptype (nested_field_type tp (ArraySubsc 0 :: pathp)))),
                  JMeq vp'' vpy).
 rewrite H99. eauto.
destruct H2 as [vpy H8].
erewrite field_at_Tarray; try eassumption; auto; try omega.
apply (JMeq_trans (JMeq_sym H4)) in H8.
clear dependent vp''. clear dependent e_c. clear dependent e_p. clear dependent e_n.
clear dependent Delta.
assert (Zlength vpy = np). {
clear - H0 H8 Hvp' Hnp Hlop Hlen.
generalize dependent vpy.
rewrite nested_field_type_ind, H0. simpl. rewrite reptype_eq; simpl.
intros.
apply JMeq_eq in H8.
subst.
clear H0.
rewrite Zlength_splice_into_list; try omega.
autorewrite with sublist.
auto.
}
rewrite (split3seg_array_at shp tp pathp 0 lop (lop+len) np) by omega.
rewrite !Z.sub_0_r.
replace (sublist 0 lop vpx) with (sublist 0 lop vpy).
2:{
generalize dependent vpy.
generalize dependent vpx.
rewrite H99.
intros.
apply JMeq_eq in H8. apply JMeq_eq in Hvpx.
subst.
apply part1_splice_into_list; omega.
}
replace (sublist (lop+len) np vpx) with (sublist (lop+len) np vpy).
2:{
generalize dependent vpy.
generalize dependent vpx.
rewrite H99.
intros.
apply JMeq_eq in H8. apply JMeq_eq in Hvpx.
subst.
apply part3_splice_into_list; try omega.
rewrite Zlength_list_repeat. rewrite Z.max_r by omega. omega.
}
cancel.
 rewrite array_at_data_at' by  (try solve [clear - FC; intuition]; omega).
   apply derives_refl'.
   apply equal_f. apply data_at_type_changable.
   unfold nested_field_array_type.
   rewrite nested_field_type_ind, H0.
   unfold tarray; f_equal. clear; omega.
   apply (JMeq_sublist _ _ lop (lop + len) _ _ (eq_sym H99)) in H8.
   eapply JMeq_trans, H8.
   apply eq_JMeq.
   unfold splice_into_list.
   autorewrite with sublist. auto.
Qed.


Require Import Containers.Sets.
Require Containers.SetEqProperties. Module EProps := SetEqProperties.
Require Containers.SetProperties. Module Props := SetProperties.
Require Import SetoidList.
(* Require Import FMapFacts. *)

Set Implicit Arguments.
Unset Strict Implicit.
Generalizable All Variables.
Open Scope set_scope.

(* Parameter fold_ind :  *)
(*   forall (A : Type) (P : K.t -> A -> Type)  *)
(*     (f : E.t -> A -> A) (i : A) (s : K.t), *)
(*     (forall (s s' : K.t) (a : A), K.eq s s' -> P s a -> P s' a) -> *)
(*     P K.empty i ->  *)
(*     (forall e a s',  *)
(*       K.In e s -> ~K.In e s' -> P s' a -> P (K.add e s') (f e a)) -> *)
(*     P s (K.fold f s i). *)

(* Parameter fold_ind2 : *)
(*   forall (A : Type) (P : A -> Type) (f : E.t -> A -> A) (i : A) (s : K.t), *)
(*     P i -> (forall e a, K.In e s -> P a -> P (f e a)) -> *)
(*     P (K.fold f s i). *)

(* Parameter fold_rel :  *)
(*   forall (Acc1 Acc2 : Type) (R : Acc1 -> Acc2 -> Type) *)
(*     (f1 : E.t -> Acc1 -> Acc1) (f2 : E.t -> Acc2 -> Acc2) *)
(*     (i1 : Acc1) (i2 : Acc2) (s : K.t), *)
(*     R i1 i2 -> *)
(*     (forall (k : K.elt) (a1 : Acc1) (a2 : Acc2), *)
(*       K.In k s -> R a1 a2 -> R (f1 k a1) (f2 k a2)) -> *)
(*     R (K.fold f1 s i1) (K.fold f2 s i2). *)

(* Module Type MapFoldInterface (E : DecidableType) (M : FMapInterface.WSfun E). *)
(*   Parameter fold_ind :  *)
(*     forall (A Acc : Type) (P : M.t A -> Acc -> Type) *)
(*       (f : E.t -> A -> Acc -> Acc) (i : Acc) (s : M.t A), *)
(*       (forall (s s' : M.t A) (a : Acc), M.Equal s s' -> P s a -> P s' a) -> *)
(*       P (M.empty A) i -> *)
(*       (forall (k : M.key) (e : A) (a : Acc) (s' : M.t A), *)
(*         M.MapsTo k e s -> ~M.In k s' -> P s' a -> P (M.add k e s') (f k e a))-> *)
(*       P s (M.fold f s i). *)

(*   Parameter fold_ind2 : *)
(*     forall (A Acc : Type) (P : Acc -> Type)  *)
(*       (f : E.t -> A -> Acc -> Acc) (i : Acc) (s : M.t A), *)
(*       P i -> (forall k e a, M.MapsTo k e s -> P a -> P (f k e a)) -> *)
(*       P (M.fold f s i). *)

(*   Parameter fold_rel : *)
(*     forall (A Acc1 Acc2 : Type) (R : Acc1 -> Acc2 -> Type) *)
(*       (f1 : E.t -> A -> Acc1 -> Acc1) (f2 : E.t -> A -> Acc2 -> Acc2) *)
(*       (i1 : Acc1) (i2 : Acc2) (s : M.t A), *)
(*       R i1 i2 -> *)
(*       (forall (k : M.key) (e : A) (a1 : Acc1) (a2 : Acc2), *)
(*         M.MapsTo k e s -> R a1 a2 -> R (f1 k e a1) (f2 k e a2)) -> *)
(*       R (M.fold f1 s i1) (M.fold f2 s i2). *)
(* End MapFoldInterface. *)

Section Reverse_Induction.
  Variable A : Type.

  Lemma rev_list_rec :
    forall P:list A-> Type,
      P nil ->
      (forall (a:A) (l:list A), P (rev l) -> P (rev (a :: l))) ->
      forall l:list A, P (rev l).
  Proof.
    induction l; auto.
  Qed.

  Theorem rev_rec :
    forall P:list A -> Type,
      P nil ->
      (forall (x:A) (l:list A), P l -> P (app l (x :: nil))) ->
      forall l:list A, P l.
  Proof.
    intros.
    generalize (rev_involutive l).
    intros E; rewrite <- E.
    apply rev_list_rec.
    auto.
    simpl in |- *.
    intros.
    apply (X0 a (rev l0)).
    auto.
  Qed.
End Reverse_Induction.

Module SetFoldInd.
  Import SetInterface.
  Section fold_induction.
    Context `{FSetSpecs : @SetInterface.FSetSpecs elt elt_OT F}.
    Variable A : Type.
    Variable P : set elt -> A -> Type.

    Variable f : elt -> A -> A.
    Variable i : A.
    Variable s : set elt.

    Hypothesis P_m : forall s s' a, s [=] s' -> P s a -> P s' a.
    Hypothesis Hi : P {} i.
    Hypothesis Hstep : forall e a s',
      e \In s -> ~e \In s' -> P s' a -> P {e; s'} (f e a).

    Definition Pl (l : list elt) (a : A) :=
      forall s, equivlistA _eq (elements s) l -> P s a.
    Lemma Hli : Pl nil i.
    Proof.
      intros s' Hs'.
      assert (Hemp : Empty s'). intros e He.
      rewrite elements_iff in He.
      rewrite (Hs' e) in He; inversion He.
      assert (Hemp' := Props.empty_is_empty_1 Hemp).
      exact (P_m (symmetry Hemp') Hi).
    Qed.

    Fixpoint set_of_list (l : list elt) : set elt :=
      match l with
        | nil => {}
        | a::q => {a; set_of_list q}
      end.
    Remark sofl_1 :
      forall l, equivlistA _eq (elements (set_of_list l)) l.
    Proof.
      induction l; simpl; intro e.
      rewrite Props.elements_empty; reflexivity.
      rewrite <- elements_iff; rewrite add_iff; rewrite elements_iff.
      split; intro H.
      destruct H; [constructor | constructor 2; rewrite <- (IHl e)]; auto.
      inversion H; [left | right]; auto.
      rewrite (IHl e); auto.
    Qed.

    Lemma fold_ind_aux : Pl (elements s) (fold f s i).
    Proof.
      rewrite fold_1.
      assert (forall e, InA _eq e (elements s) -> e \In s).
      intros; auto with set.
      assert (H2 := elements_3w s).
      revert H2 H; pattern (elements s); apply rev_rec.
      intros; simpl; exact Hli.
      intros x L IH IHdup IHin; rewrite fold_left_app; simpl.
      intros s' Hs'.
      cut ({x; set_of_list L} [=] s'); [intro Heq |].
      assert (NoDupA _eq (x::(app L nil))).
      refine (NoDupA_swap _ IHdup); intuition.
      refine (P_m Heq _); apply Hstep.
      apply IHin; rewrite InA_app_iff; intuition.
      rewrite elements_iff.
      rewrite (sofl_1 L x); inversion H; rewrite <- app_nil_end in H2; auto.
      apply IH.
      inversion H; rewrite <- app_nil_end in H3; auto.
      intros e He; apply IHin.
      rewrite InA_alt in He |- *; destruct He as [y [Hy1 Hy2]].
      exists y; intuition.
      apply sofl_1.
      (** - cut : (K.add x (set_of_list L)) [=] s' *)
      intro l; rewrite add_iff; split; intro Hl.
      apply elements_2; rewrite (Hs' l); destruct Hl.
      rewrite InA_alt; exists x; intuition.
      assert (X:= (proj1 (sofl_1 L l)) (elements_1 H)).
      rewrite InA_alt in X |- *; destruct X; exists x0; intuition.
      rewrite elements_iff in Hl; rewrite (Hs' l) in Hl.
      destruct (InA_app Hl); [right | left].
      apply elements_2; rewrite (sofl_1 L l); auto.
      inversion H; try inversion H1; intuition.
    Qed.

    Theorem fold_ind : P s (fold f s i).
    Proof.
      apply fold_ind_aux.
      induction (elements s); constructor; intuition.
    Qed.
  End fold_induction.
  Corollary fold_ind2 `{FSetSpecs : @SetInterface.FSetSpecs elt elt_OT F} :
    forall (A : Type) (P : A -> Type) (f : elt -> A -> A) (i : A) (s : set elt),
      P i -> (forall e a, e \In s -> P a -> P (f e a)) ->
      P (fold f s i).
  Proof.
    refine (fun A P f i s Hi Hstep =>
      @fold_ind elt elt_OT F FSetSpecs A (fun _ => P) f i s _ Hi _).
    trivial.
    exact (fun e a _ H _ Ha => Hstep e a H Ha).
  Qed.

  Section fold_relation.
    Context `{FSetSpecs : @SetInterface.FSetSpecs elt elt_OT F}.
    Variables A Acc1 Acc2 : Type.
    Variable R : Acc1 -> Acc2 -> Type.

    Variable f1 : elt -> Acc1 -> Acc1.
    Variable f2 : elt -> Acc2 -> Acc2.
    Variable i1 : Acc1.
    Variable i2 : Acc2.
    Variable s : set elt.

    Hypothesis Hi : R i1 i2.
    Hypothesis Hstep : forall k a1 a2,
      k \In s -> R a1 a2 -> R (f1 k a1) (f2 k a2).

    Lemma fold_rel : R (fold f1 s i1) (fold f2 s i2).
    Proof.
      assert (Hin : forall k, InA _eq k (elements s) -> k \In s).
      intros; apply elements_2; auto.
      revert Hin; do 2 rewrite fold_1; pattern (elements s).
      apply rev_rec; simpl; auto.
      intros k L IH Hin; do 2 rewrite fold_left_app; simpl; apply Hstep.
      apply Hin; rewrite <- InA_rev; auto; rewrite rev_unit; constructor.
      reflexivity.
      apply IH; intros k0 Hk0; apply Hin.
      rewrite InA_alt in Hk0 |- *; destruct Hk0 as [y [Hy1 Hy2]].
      exists y; intuition.
    Qed.
  End fold_relation.

End SetFoldInd.

(* Module MapFoldInd (E : DecidableType) (M : FMapInterface.WSfun E) *)
(*   : MapFoldInterface(E)(M). *)

(*   Module Import P := FMapFacts.WProperties_fun(E)(M). *)

(*   Section fold_induction. *)
(*     Variables A Acc : Type. *)
(*     Variable P : M.t A -> Acc -> Type. *)

(*     Variable f : E.t -> A -> Acc -> Acc. *)
(*     Variable i : Acc. *)
(*     Variable s : M.t A. *)

(*     Let eqke := (@M.eq_key_elt A). *)
(*     Hypothesis P_m :  *)
(*       forall s s' a, M.Equal s s' -> P s a -> P s' a. *)
(*     Hypothesis Hi : P (M.empty A) i. *)
(*     Hypothesis Hstep : forall k e a s', *)
(*       M.MapsTo k e s -> ~M.In k s' -> P s' a ->  *)
(*       P (M.add k e s') (f k e a). *)

(*     Definition cPl (l : list (E.t * A)) (a : Acc) := *)
(*       forall s, equivlistA eqke (M.elements s) l -> P s a. *)
(*     Lemma cHli : cPl nil i. *)
(*     Proof. *)
(*       intros s' Hs'. *)
(*       assert (Hemp : M.Empty s'). intros k e He. *)
(*       rewrite F.elements_mapsto_iff in He. *)
(*       unfold eqke in Hs'; rewrite (Hs' (k,e)) in He; inversion He. *)
(*       refine (P_m _ Hi); intro k; transitivity (@None A); [|symmetry]. *)
(*       rewrite <- F.not_find_in_iff; rewrite F.empty_in_iff; intuition. *)
(*       rewrite <- F.not_find_in_iff; intros [e He]. *)
(*       contradiction (Hemp k e He). *)
(*     Qed. *)

(*     Fixpoint cmap_of_list (l : list (E.t * A)) : M.t A := *)
(*       match l with *)
(*         | nil => M.empty A *)
(*         | (k,e)::q => M.add k e (cmap_of_list q) *)
(*       end. *)

(*     Lemma cmofl_1 : *)
(*       forall l, NoDupA (@M.eq_key A) l ->  *)
(*         equivlistA eqke (M.elements (cmap_of_list l)) l. *)
(*     Proof. *)
(*       induction l; simpl; intros Hnodup [k e]. *)
(*       rewrite elements_empty; reflexivity. *)
(*       destruct a as [ka ea]; unfold eqke; rewrite <- F.elements_mapsto_iff. *)
(*       rewrite F.add_mapsto_iff; rewrite F.elements_mapsto_iff. *)
(*       cut ({E.eq ka k} + {~E.eq ka k}); [intros [E|N] |]. *)
(*       inversion Hnodup; subst; intuition. *)
(*       constructor 1; split; auto. *)
(*       left; split; auto; inversion H0; subst. *)
(*       exact (sym_eq (proj2 H4)). *)
(*       elim H1; rewrite InA_alt in H4 |- *;  *)
(*         destruct H4 as [[k' e'] [[H' _] H'']]; simpl in *. *)
(*       exists (k',e'); split; unfold M.eq_key; simpl; try rewrite E; auto. *)
(*       inversion Hnodup; subst; intuition. *)
(*       constructor 2; fold eqke; rewrite <- (H (k,e)); exact H4. *)
(*       right; split; auto; inversion H0; subst. *)
(*       elim N; exact (E.eq_sym (proj1 H4)). *)
(*       unfold eqke in H; rewrite (H (k,e)); assumption. *)
(*       destruct (E.eq_dec ka k); intuition. *)
(*     Qed. *)

(*     Lemma cfold_ind_aux : cPl (M.elements s) (M.fold f s i). *)
(*     Proof. *)
(*       rewrite M.fold_1. *)
(*       assert (forall k e, InA eqke (k,e) (M.elements s) ->  *)
(*         M.MapsTo k e s). *)
(*       intros; unfold eqke in H;  *)
(*         rewrite <- F.elements_mapsto_iff in H; exact H. *)
(*       assert (H2 := M.elements_3w s). *)
(*       revert H2 H; pattern (M.elements s); apply rev_rec. *)
(*       intros; simpl; exact cHli. *)
(*       intros x L IH IHdup IHin; rewrite fold_left_app; simpl. *)
(*       intros s' Hs'. *)
(*       cut (M.Equal  *)
(*         (M.add (fst x) (snd x) (cmap_of_list L)) s'); [intro Heq |]. *)
(*       assert (NoDupA (@M.eq_key _) (x::L++nil)). *)
(*       refine (NoDupA_swap _ IHdup); unfold M.eq_key in *; intuition. *)
(*       refine (P_m Heq _); apply Hstep. *)
(*       apply IHin; rewrite <- InA_rev; rewrite rev_unit; constructor. *)
(*       unfold eqke; destruct x; simpl; split; intuition. *)
(*       rewrite F.elements_in_iff; fold eqke; intros [e He]. *)
(*       inversion H; rewrite <- app_nil_end in *. *)
(*       rewrite (cmofl_1 H3 (fst x, e)) in He; apply H2. *)
(*       rewrite InA_alt in He |- *;  *)
(*         destruct He as [y [[Hy _] HL]]; exists y; intuition. *)
(*       apply IH. *)
(*       inversion H; rewrite <- app_nil_end in H3; auto. *)
(*       intros k e He; apply IHin. *)
(*       rewrite InA_alt in He |- *; destruct He as [y [Hy1 Hy2]]. *)
(*       exists y; intuition. *)
(*       apply cmofl_1.  *)
(*       inversion H; rewrite <- app_nil_end in H3; auto. *)
(*       (** - cut : (KSet.add x (set_of_list L)) [=] s' *) *)
(*       assert (dup : NoDupA (@M.eq_key A) (x :: rev L)). *)
(*       rewrite <- rev_unit; apply NoDupA_rev;  *)
(*         intros; unfold M.eq_key; intuition. transitivity (fst y); auto. *)
(*       assert (dup' : NoDupA (@M.eq_key A) L). *)
(*       inversion dup; rewrite <- rev_involutive; apply NoDupA_rev;  *)
(*         intros; unfold M.eq_key; intuition. transitivity (fst y); auto. *)
(*       intro l; case_eq (M.find l s'); [intros el Hl2 | intro Hl2]. *)
(*       apply M.find_1; assert (Hl2' := M.find_2 Hl2). *)
(*       rewrite F.add_mapsto_iff; rewrite F.elements_mapsto_iff. *)
(*       rewrite F.elements_mapsto_iff in Hl2'; fold eqke in Hl2'. *)
(*       rewrite (Hs' (l,el)) in Hl2'; destruct (InA_app Hl2'). *)
(*       right; split; [intro Heq |]. *)
(*       inversion dup as [|x0 L0 Hnotx dup2]; subst; apply Hnotx. *)
(*       rewrite InA_rev; rewrite InA_alt in H |- *. *)
(*       destruct H as [y [[Hy1 _] Hy2]]; exists y; intuition.  *)
(*       unfold M.eq_key; transitivity l; intuition. *)
(*       fold eqke; rewrite (cmofl_1 dup' (l,el)); assumption. *)
(*       left; inversion H; subst. destruct H1; intuition. inversion H1. *)
(*       rewrite <- F.not_find_in_iff in Hl2 |- *; intro Hl1; apply Hl2. *)
(*       rewrite F.add_in_iff in Hl1; rewrite F.elements_in_iff in Hl1 |- *. *)
(*       destruct Hl1 as [Heq |[el H1]]. *)
(*       exists (snd x); fold eqke; rewrite (Hs' (l, snd x)). *)
(*       rewrite <- InA_rev; rewrite rev_unit; constructor; split; intuition. *)
(*       exists el; fold eqke; rewrite (Hs' (l,el)). *)
(*       rewrite <- InA_rev; rewrite rev_unit; constructor 2; rewrite InA_rev. *)
(*       fold eqke in H1; exact ((proj1 (cmofl_1 dup' (l,el))) H1). *)
(*     Qed. *)

(*     Theorem fold_ind : P s (M.fold f s i). *)
(*     Proof. *)
(*       apply cfold_ind_aux. *)
(*       induction (M.elements s); constructor; intuition. *)
(*     Qed. *)
(*   End fold_induction. *)
(*   Corollary fold_ind2 : *)
(*   forall (A Acc : Type) (P : Acc -> Type)  *)
(*     (f : E.t -> A -> Acc -> Acc) (i : Acc) (s : M.t A), *)
(*     P i -> (forall k e a, M.MapsTo k e s -> P a -> P (f k e a)) -> *)
(*     P (M.fold f s i). *)
(*   Proof. *)
(*     refine (fun A Acc P f i s Hi Hstep =>  *)
(*       @fold_ind A Acc (fun _ => P) f i s _ Hi _). *)
(*     trivial. *)
(*     exact (fun k e a _ H _ Ha => Hstep k e a H Ha). *)
(*   Qed. *)

(*   Section fold_relation. *)
(*     Variables A Acc1 Acc2 : Type. *)
(*     Variable R : Acc1 -> Acc2 -> Type. *)

(*     Variable f1 : E.t -> A -> Acc1 -> Acc1. *)
(*     Variable f2 : E.t -> A -> Acc2 -> Acc2. *)
(*     Variable i1 : Acc1. *)
(*     Variable i2 : Acc2. *)
(*     Variable s : M.t A. *)

(*     Let eqke := (@M.eq_key_elt A). *)
(*     Hypothesis Hi : R i1 i2. *)
(*     Hypothesis Hstep : forall k e a1 a2,  *)
(*       M.MapsTo k e s -> R a1 a2 -> R (f1 k e a1) (f2 k e a2). *)

(*     Lemma fold_rel : R (M.fold f1 s i1) (M.fold f2 s i2). *)
(*     Proof. *)
(*       assert (Hin : *)
(*         forall k e, InA eqke (k,e) (M.elements s) -> M.MapsTo k e s). *)
(*       intros; unfold eqke in H; rewrite <- F.elements_mapsto_iff in H; auto. *)
(*       revert Hin; do 2 rewrite M.fold_1; pattern (M.elements s). *)
(*       apply rev_rec; simpl; auto. *)
(*       intros [k e] L IH Hin; do 2 rewrite fold_left_app; simpl; apply Hstep. *)
(*       apply Hin; rewrite <- InA_rev; rewrite rev_unit; constructor. *)
(*       split; reflexivity. *)
(*       apply IH; intros k0 e0 Hke0; apply Hin. *)
(*       rewrite InA_alt in Hke0 |- *; destruct Hke0 as [y [Hy1 Hy2]]. *)
(*       exists y; intuition. *)
(*     Qed. *)
(*   End fold_relation. *)

(* End MapFoldInd. *)


From iris_examples.logrel.F_mu_ref_conc Require Export lang.
From iris.prelude Require Import options.

Inductive type :=
  | TUnit : type
  | TNat : type
  | TBool : type
  | TProd : type → type → type
  | TSum : type → type → type
  | TArrow : type → type → type
  | TRec (τ : {bind 1 of type})
  | TVar (x : var)
  | TForall (τ : {bind 1 of type})
  | TExist (τ : {bind 1 of type})
  | Tref (τ : type).

Global Instance Ids_type : Ids type. derive. Defined.
Global Instance Rename_type : Rename type. derive. Defined.
Global Instance Subst_type : Subst type. derive. Defined.
Global Instance SubstLemmas_typer : SubstLemmas type. derive. Qed.

Definition binop_res_type (op : binop) : type :=
  match op with
  | Add => TNat | Sub => TNat | Mult => TNat
  | Eq => TBool | Le => TBool | Lt => TBool
  end.

Inductive EqType : type → Prop :=
  | EqTUnit : EqType TUnit
  | EqTNat : EqType TNat
  | EqTBool : EqType TBool
  | EQRef τ : EqType (Tref τ).

Reserved Notation "Γ ⊢ₜ e : τ" (at level 74, e, τ at next level).

Inductive typed (Γ : list type) : expr → type → Prop :=
  | Var_typed x τ : Γ !! x = Some τ → Γ ⊢ₜ Var x : τ
  | Unit_typed : Γ ⊢ₜ Unit : TUnit
  | Nat_typed n : Γ ⊢ₜ #n n : TNat
  | Bool_typed b : Γ ⊢ₜ #♭ b : TBool
  | BinOp_typed op e1 e2 :
     Γ ⊢ₜ e1 : TNat → Γ ⊢ₜ e2 : TNat → Γ ⊢ₜ BinOp op e1 e2 : binop_res_type op
  | Pair_typed e1 e2 τ1 τ2 : Γ ⊢ₜ e1 : τ1 → Γ ⊢ₜ e2 : τ2 → Γ ⊢ₜ Pair e1 e2 : TProd τ1 τ2
  | Fst_typed e τ1 τ2 : Γ ⊢ₜ e : TProd τ1 τ2 → Γ ⊢ₜ Fst e : τ1
  | Snd_typed e τ1 τ2 : Γ ⊢ₜ e : TProd τ1 τ2 → Γ ⊢ₜ Snd e : τ2
  | InjL_typed e τ1 τ2 : Γ ⊢ₜ e : τ1 → Γ ⊢ₜ InjL e : TSum τ1 τ2
  | InjR_typed e τ1 τ2 : Γ ⊢ₜ e : τ2 → Γ ⊢ₜ InjR e : TSum τ1 τ2
  | Case_typed e0 e1 e2 τ1 τ2 τ3 :
     Γ ⊢ₜ e0 : TSum τ1 τ2 → τ1 :: Γ ⊢ₜ e1 : τ3 → τ2 :: Γ ⊢ₜ e2 : τ3 →
     Γ ⊢ₜ Case e0 e1 e2 : τ3
  | If_typed e0 e1 e2 τ :
     Γ ⊢ₜ e0 : TBool → Γ ⊢ₜ e1 : τ → Γ ⊢ₜ e2 : τ → Γ ⊢ₜ If e0 e1 e2 : τ
  | Rec_typed e τ1 τ2 :
     TArrow τ1 τ2 :: τ1 :: Γ ⊢ₜ e : τ2 → Γ ⊢ₜ Rec e : TArrow τ1 τ2
  | Lam_typed e τ1 τ2 :
      τ1 :: Γ ⊢ₜ e : τ2 → Γ ⊢ₜ Lam e : TArrow τ1 τ2
  | LetIn_typed e1 e2 τ1 τ2 :
      Γ ⊢ₜ e1 : τ1 → τ1 :: Γ ⊢ₜ e2 : τ2 → Γ ⊢ₜ LetIn e1 e2 : τ2
  | Seq_typed e1 e2 τ1 τ2 :
      Γ ⊢ₜ e1 : τ1 → Γ ⊢ₜ e2 : τ2 → Γ ⊢ₜ Seq e1 e2 : τ2
  | App_typed e1 e2 τ1 τ2 :
     Γ ⊢ₜ e1 : TArrow τ1 τ2 → Γ ⊢ₜ e2 : τ1 → Γ ⊢ₜ App e1 e2 : τ2
  | TLam_typed e τ :
     subst (ren (+1)) <$> Γ ⊢ₜ e : τ → Γ ⊢ₜ TLam e : TForall τ
  | TApp_typed e τ τ' : Γ ⊢ₜ e : TForall τ → Γ ⊢ₜ TApp e : τ.[τ'/]
  | Pack_typed e τ τ' :
     Γ ⊢ₜ e : τ.[τ'/] → Γ ⊢ₜ Pack e : TExist τ
  | UnpackIn_typed e1 e2 τ τ' :
     Γ ⊢ₜ e1 : TExist τ →
     τ :: (subst (ren (+1)) <$> Γ) ⊢ₜ e2 : τ'.[ren (+1)] →
     Γ ⊢ₜ UnpackIn e1 e2 : τ'
  | TFold e τ : Γ ⊢ₜ e : τ.[TRec τ/] → Γ ⊢ₜ Fold e : TRec τ
  | TUnfold e τ : Γ ⊢ₜ e : TRec τ → Γ ⊢ₜ Unfold e : τ.[TRec τ/]
  | TFork e : Γ ⊢ₜ e : TUnit → Γ ⊢ₜ Fork e : TUnit
  | TAlloc e τ : Γ ⊢ₜ e : τ → Γ ⊢ₜ Alloc e : Tref τ
  | TLoad e τ : Γ ⊢ₜ e : Tref τ → Γ ⊢ₜ Load e : τ
  | TStore e e' τ : Γ ⊢ₜ e : Tref τ → Γ ⊢ₜ e' : τ → Γ ⊢ₜ Store e e' : TUnit
  | TCAS e1 e2 e3 τ :
     EqType τ → Γ ⊢ₜ e1 : Tref τ → Γ ⊢ₜ e2 : τ → Γ ⊢ₜ e3 : τ →
     Γ ⊢ₜ CAS e1 e2 e3 : TBool
  | TFAA e1 e2 : Γ ⊢ₜ e1 : Tref TNat → Γ ⊢ₜ e2 : TNat → Γ ⊢ₜ FAA e1 e2 : TNat
where "Γ ⊢ₜ e : τ" := (typed Γ e τ).

Fixpoint env_subst (vs : list val) : var → expr :=
  match vs with
  | [] => ids
  | v :: vs' => (of_val v) .: env_subst vs'
  end.

Lemma env_subst_lookup vs x v :
  vs !! x = Some v → env_subst vs x = of_val v.
Proof.
  revert vs; induction x as [|x IH] => vs.
  - by destruct vs; inversion 1.
  - destruct vs as [|w vs]; first by inversion 1.
    rewrite -lookup_tail /=.
    apply IH.
Qed.

Lemma typed_n_closed Γ τ e : Γ ⊢ₜ e : τ → (∀ f, e.[upn (length Γ) f] = e).
Proof.
  intros H. induction H => f; asimpl; simpl in *; auto with f_equal.
  - rename select (_ !! _ = Some _) into H.
    apply lookup_lt_Some in H. rewrite iter_up. destruct lt_dec; auto with lia.
  - f_equal. eauto.
  - f_equal. rewrite ->map_length in *. done.
  - rewrite ->map_length in *; by f_equal.
Qed.

(** Weakening *)
Lemma context_gen_weakening ξ Γ' Γ e τ :
  Γ' ++ Γ ⊢ₜ e : τ →
  Γ' ++ ξ ++ Γ ⊢ₜ e.[upn (length Γ') (ren (+ (length ξ)))] : τ.
Proof.
  intros H1.
  remember (Γ' ++ Γ) as Ξ eqn:HeqΞ. revert Γ' Γ ξ HeqΞ.
  induction H1 => Γ1 Γ2 ξ HeqΞ; subst; asimpl; eauto using typed.
  - rename select (_ !! _ = Some _) into Hlookup.
    rewrite iter_up; destruct lt_dec as [Hl | Hl].
    + constructor. rewrite lookup_app_l; trivial. by rewrite lookup_app_l in Hlookup.
    + asimpl. constructor. rewrite lookup_app_r; auto with lia.
      rewrite lookup_app_r; auto with lia.
      rewrite lookup_app_r in Hlookup; auto with lia.
      rename select var into x.
      match goal with
        |- _ !! ?A = _ => by replace A with (x - length Γ1) by lia
      end.
  - econstructor; eauto.
    all: match goal with H : context[_ → _ ⊢ₜ _ : _] |- _ => by apply (H (_::_)) end.
  - constructor.
    match goal with H : context[_ → _ ⊢ₜ _ : _] |- _ => by apply (H (_::_::_)) end.
  - constructor.
    match goal with H : context[_ → _ ⊢ₜ _ : _] |- _ => by apply (H (_::_)) end.
  - econstructor; eauto.
    match goal with H : context[_ → _ ⊢ₜ _ : _] |- _ => by apply (H (_::_)) end.
  - constructor.
    match goal with H : context[_ → _ ⊢ₜ _ : _] |- _ => rename H into IH end.
    specialize (IH
      (subst (ren (+1)) <$> Γ1) (subst (ren (+1)) <$> Γ2) (subst (ren (+1)) <$> ξ)).
    rewrite ?map_length in IH.
    repeat rewrite fmap_app. apply IH.
    by repeat rewrite fmap_app.
  - econstructor; eauto.
    match goal with H : context[_ → _ ⊢ₜ _ : _.[ren (+1)]] |- _ => rename H into IH end.
    match goal with H : context[_ → _ ⊢ₜ _ : TExist ?t] |- _ => rename t into τ end.
    specialize (IH
      (τ :: (subst (ren (+1)) <$> Γ1)) (subst (ren (+1)) <$> Γ2) (subst (ren (+1)) <$> ξ)).
    asimpl in IH. rewrite ?map_length in IH.
    repeat rewrite fmap_app. apply IH.
    by repeat rewrite fmap_app.
Qed.

Lemma context_weakening ξ Γ e τ :
  Γ ⊢ₜ e : τ → ξ ++ Γ ⊢ₜ e.[(ren (+ (length ξ)))] : τ.
Proof. eapply (context_gen_weakening _ []). Qed.

Lemma closed_context_weakening ξ Γ e τ :
  (∀ f, e.[f] = e) → Γ ⊢ₜ e : τ → ξ ++ Γ ⊢ₜ e : τ.
Proof. intros H1 H2. erewrite <- H1. by eapply context_weakening. Qed.


From Hammer Require Import Hammer.

From hahn Require Import HahnBase HahnRelationsBasic.
Require Import Setoid.
Set Implicit Arguments.

Section FunEq.

Variable A B : Type.
Variable f : A -> B.

Definition funeq (r : relation A) := forall a b (H: r a b), f a = f b.

Lemma funeq_union r t (H1: funeq r) (H2: funeq t) : funeq (r ∪ t).
Proof. hammer_hook "HahnFuneq" "HahnFuneq.funeq_union". firstorder. Qed.

Lemma funeq_inter_l r t (H1: funeq r) : funeq (r ∩ t).
Proof. hammer_hook "HahnFuneq" "HahnFuneq.funeq_inter_l". firstorder. Qed.

Lemma funeq_inter_r r t (H1: funeq t) : funeq (r ∩ t).
Proof. hammer_hook "HahnFuneq" "HahnFuneq.funeq_inter_r". firstorder. Qed.

Lemma funeq_seq r t (H1: funeq r) (H2: funeq t) : funeq (r ⨾ t).
Proof. hammer_hook "HahnFuneq" "HahnFuneq.funeq_seq". eby red; ins; destruct H; desc; etransitivity; [apply H1 | apply H2]. Qed.

Lemma funeq_ct r (H: funeq r) : funeq r⁺.
Proof. hammer_hook "HahnFuneq" "HahnFuneq.funeq_ct". eby red; ins; induction H0; eauto; etransitivity. Qed.

Lemma funeq_cr r (H: funeq r) : funeq r^?.
Proof. hammer_hook "HahnFuneq" "HahnFuneq.funeq_cr". red; ins; red in H0; desf; subst; auto. Qed.

Lemma funeq_rt r (H: funeq r) : funeq r＊.
Proof. hammer_hook "HahnFuneq" "HahnFuneq.funeq_rt". eby red; ins; induction H0; eauto; etransitivity. Qed.

Lemma funeq_restr r (H: funeq r) dom : funeq (restr_rel dom r).
Proof. hammer_hook "HahnFuneq" "HahnFuneq.funeq_restr". firstorder. Qed.

Lemma funeq_restr_eq r (H: funeq r) C (dom : A -> C) : funeq (restr_eq_rel dom r).
Proof. hammer_hook "HahnFuneq" "HahnFuneq.funeq_restr_eq". firstorder. Qed.

Lemma funeq_restr_eq_rel r : funeq (restr_eq_rel f r).
Proof. hammer_hook "HahnFuneq" "HahnFuneq.funeq_restr_eq_rel". firstorder. Qed.

Lemma funeq_eqv_rel dom : funeq ⦗dom⦘.
Proof. hammer_hook "HahnFuneq" "HahnFuneq.funeq_eqv_rel". by red; ins; red in H; desc; subst. Qed.

Lemma funeq_transp r (H: funeq r) : funeq r⁻¹.
Proof. hammer_hook "HahnFuneq" "HahnFuneq.funeq_transp". firstorder. Qed.

Lemma funeq_minus r t (H: funeq r) : funeq (r \ t).
Proof. hammer_hook "HahnFuneq" "HahnFuneq.funeq_minus". firstorder. Qed.

Lemma funeq_irreflexive r t (H: funeq r)
(IRR: irreflexive (restr_eq_rel f t ⨾ r)) : irreflexive (t ⨾ r).
Proof. hammer_hook "HahnFuneq" "HahnFuneq.funeq_irreflexive".
unfold funeq, irreflexive, seq, restr_eq_rel in *.
ins; desf; eauto 8 using eq_sym.
Qed.

End FunEq.

Hint Unfold funeq : unfolderDb.
Hint Resolve funeq_union funeq_inter_l funeq_inter_r : hahn.
Hint Resolve funeq_seq funeq_ct funeq_cr funeq_rt : hahn.
Hint Resolve funeq_restr funeq_restr_eq funeq_restr_eq_rel : hahn.
Hint Resolve funeq_eqv_rel funeq_transp funeq_minus : hahn.

Add Parametric Morphism A B f : (@funeq A B f) with signature
inclusion --> Basics.impl as funeq_mori.
Proof.
unfold inclusion, funeq, Basics.impl; eauto.
Qed.

Add Parametric Morphism A B f : (@funeq A B f) with signature
same_relation ==> iff as funeq_more.
Proof.
unfold same_relation; split; desc; [rewrite H0|rewrite H]; eauto.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O E Eprime A B C AB BC ABC BCprime Bprime Cprime : Universe, ((wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ BC O /\ (wd_ Bprime O /\ (wd_ BC BCprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E AB /\ (col_ O E C /\ (col_ O E BC /\ (col_ O E ABC /\ (col_ O Eprime BCprime /\ (col_ O Eprime Bprime /\ (col_ O Eprime Cprime /\ col_ O Eprime B)))))))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(** Programs and Proofs Ilya Sergey *)
(* http://ilyasergey.net/pnp/ *)

(** * 「Hoare Type Theory の基礎」から抜粋 *)
(** * Elements of Hoare Type Theory *)

Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
Add LoadPath "./../htt".
Require Import prelude pred pcm unionmap heap heaptac
        stmod stsep stlog stlogR.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(**
Hoare Type とは、依存型に基づいて、
Hoareスタイルのspecificationをコード化したもの。
 *)
(* All these observation resulted in a series of works on Hoare Type
Theory (or just HTT), which defines a notion of an indexed Hoare monad
(or, Hoare type) as a mechanism to encode Hoare-style specifications
as dependent types and reduce the verification of effectful
progress to proving propositions in Coq. *)

(** * Structuring the program verification in HTT *)

(* NOTE: the current implementation of HTT does not support
value/type dependencies in the logical variables (e.g., {T (x: T)}),
so such cases won't be properly handled by the ghR lemma. *)

(** Hoare Type  *)
Definition alter_x_tp A (x : ptr) (v : A) :=
  (* Aは任意の型の意味。 *)
  {(y : ptr) (Y : nat)},                    (* Y の型はなんでもいい。 *)
  STsep (
      (** pre-condition : heap -> Prop *)
      fun h => exists B (w : B), h = x :-> w \+ y :-> Y,
      (** post-condition : unit -> heap -> Prop
          この場合、実行結果は unit（いわゆるvoid）である。 *)
      [vfun (tt : unit) h => h = x :-> v \+ y :-> Y]
    ).

(** 証明するもの。 *)
Program Definition alter_x A (x : ptr) (v : A) : alter_x_tp x v :=
  Do (x ::= v).                             (* 命令文 *)
Next Obligation.
  apply: ghR.                               (* y と Y を外に出す。 *)

  move=> h1 [y Y] [B] [w] H.                (* h1 はpre-condのheap *)
  (* H は、h1 = ......  *)
  rewrite H.                                (* h1 を展開する。 *)
  move=> _ /=.                              (* .1 と .2 を計算する。 *)

  (* 「verify 前提のheap 命令文 実行結果」 のかたちになる。  *)
  Search (verify _ (_ ::= _) _).
  apply: val_writeR => _ /=.                (* validの項は捨ててよい。 *)
  by [].
(* 代わりに by heval. でもよい。 *)
Qed.

(* END *)


Require Export List.
Require Export Util.

Implicit Arguments map_injective.

Module Type RED_LANG.

  Parameters term closure closureC value valueC redex frame frameC : Set.
  Definition context := list frame.
  Definition empty : context := nil.
  Definition contextC := list frameC.
  Definition emptyC : contextC := nil.

  Definition env  := list closure.
  Definition envC := list closureC.

  Parameter atom_plug : closure -> frame -> closure.
  Definition plug (c : closure) (E : context) : closure := fold_left atom_plug E c.
  Definition compose (E E0 : context) : context := E ++ E0.
  Definition composeC (E E0 : contextC) : contextC := E ++ E0.

  Parameter pair : term -> env -> closure.
  Parameter pairC : term -> envC -> closureC.

  Parameter value_to_closure : value -> closure.
  Parameter redex_to_closure : redex -> closure.

  Parameter valueC_to_closureC : valueC -> closureC.

  Parameter valueC_to_value : valueC -> value.
  Parameter closureC_to_closure : closureC -> closure.
  Parameter frameC_to_frame : frameC -> frame.

  Axiom value_to_closure_injective : forall v v0, value_to_closure v = value_to_closure v0 -> v = v0.
  Axiom redex_to_closure_injective : forall r r0, redex_to_closure r = redex_to_closure r0 -> r = r0.

  Axiom valueC_to_closureC_injective : forall v v0, valueC_to_closureC v = valueC_to_closureC v0 -> v = v0.

  Axiom closureC_to_closure_injective : forall c c0, closureC_to_closure c = closureC_to_closure c0 -> c = c0.
  Axiom valueC_to_value_injective : forall v v0, valueC_to_value v = valueC_to_value v0 -> v = v0.
  Axiom frameC_to_frame_injective : forall f f0, frameC_to_frame f = frameC_to_frame f0 -> f = f0.

  Axiom pairC_pair : forall t sC, closureC_to_closure (pairC t sC) = pair t (map closureC_to_closure sC).
  Axiom pairC_injective : forall t t0 sC sC0, pairC t sC = pairC t0 sC0 -> t = t0 /\ sC = sC0.
  Axiom valueC_to_closure_commutes : forall vC, value_to_closure (valueC_to_value vC) = closureC_to_closure (valueC_to_closureC vC).
  Definition envC_to_env : envC -> env := map closureC_to_closure.
  Definition envC_to_env_injective : forall sC sC0, envC_to_env sC = envC_to_env sC0 -> sC = sC0 :=
    map_injective closureC_to_closure closureC_to_closure_injective.
  Definition contextC_to_context : contextC -> context := map frameC_to_frame.
  Definition contextC_to_context_injective : forall E E0, contextC_to_context E = contextC_to_context E0 -> E = E0 :=
    map_injective frameC_to_frame frameC_to_frame_injective.

  Parameter contract : redex -> option closure.

  Definition only_empty (c : closure) : Prop := forall c0 E, plug c0 E = c -> E = empty.
  Definition only_trivial (c : closure) : Prop := forall c0 E, plug c0 E = c -> E = empty \/ exists v, c0 = value_to_closure v.

  Axiom closureC_only_empty : forall cC, only_empty (closureC_to_closure cC).
  Axiom value_trivial : forall v : value, only_trivial (value_to_closure v).
  Axiom redex_trivial : forall r : redex, only_trivial (redex_to_closure r).
  Axiom value_redex : forall (v : value) (r : redex), value_to_closure v <> redex_to_closure r.
  Axiom trivial_val_red : forall c : closure, only_trivial c ->
    (exists v : value, c = value_to_closure v) \/ (exists r : redex, c = redex_to_closure r).

  Parameter closureC_dec : forall cC : closureC,
    {p : term * envC + valueC | match p with
	| inl (t, sC) => cC = pairC t sC
	| inr vC => cC = valueC_to_closureC vC
    end}.
  Axiom dec_pairC : forall t sC, proj1_sig (closureC_dec (pairC t sC)) = inl _ (t, sC).

  (** Datatype of decompositions -- either a value or a redex in a context (analogous to the decompose lemma) *)
  Inductive decomp : Set :=
  | d_val : value -> decomp
  | d_red : redex -> context -> decomp.

  Inductive interm_dec : Set :=
  | in_red : redex -> interm_dec
  | in_val : value -> interm_dec
  | in_clo : closure -> frame -> interm_dec.

  Definition decomp_to_closure (d : decomp) : closure :=
  match d with
    | d_val v => value_to_closure v
    | d_red r c0 => plug (redex_to_closure r) c0
  end.

End RED_LANG.

Module Type LANG_PROP (R : RED_LANG).

  Import R.
  Notation " E · E0 " := (compose E E0) (at level 40) : red_scope.
  Notation " E × E0 " := (composeC E E0) (at level 40) : red_scope.
  Notation " E [ c ] " := (plug c E) (at level 50) : red_scope.
  Open Scope red_scope.

  Axiom plug_empty : forall c, empty [c] = c.
  Axiom compose_empty : forall c : context, c =  c · empty.
  Axiom composeC_emptyC : forall Ec : contextC, Ec = Ec × emptyC.
  Axiom plug_compose : forall (E E0 : context) (c : closure), E · E0 [ c ] = E0 [ E [ c ] ].
  Axiom composeC_compose : forall Ec Ec0, contextC_to_context (Ec × Ec0) = contextC_to_context Ec · contextC_to_context Ec0.

  Close Scope red_scope.

End LANG_PROP.

Module Type RED_REF_LANG.

  Declare Module Lang : RED_LANG.
  Import Lang.

  Parameter dec_closure : closure -> interm_dec.
  Parameter dec_context : frame -> value -> interm_dec.

  Inductive subclosure_one_step : closure -> closure -> Prop :=
  | scl : forall cl cl0 f (AP : cl = atom_plug cl0 f), subclosure_one_step cl0 cl.
  Axiom subclosure_one_step_wf : well_founded subclosure_one_step.

  Definition closure_order : closure -> closure -> Prop := clos_trans_n1 _ subclosure_one_step.
  Notation " cl <| cl0 " := (closure_order cl cl0) (at level 40) : red_scope.
  Definition closure_order_wf : well_founded closure_order := wf_clos_trans_r _ _ subclosure_one_step_wf.

  Parameter frame_order : frame -> frame -> Prop.
  Notation " f <: f0 " := (frame_order f f0) (at level 40) : red_scope.
  Axiom frame_order_wf : well_founded frame_order.

  Open Scope red_scope.

  Axiom dec_closure_red_empty  : forall c r, dec_closure c = in_red r -> only_empty c.
  Axiom dec_closure_val_empty  : forall c v, dec_closure c = in_val v -> only_empty c.
  Axiom dec_closure_clo_top    : forall c c0 f, dec_closure c = in_clo c0 f -> forall f0, ~f <: f0.
  Axiom dec_context_red_bot    : forall f v r, dec_context f v = in_red r -> forall f0, ~ f0 <: f.
  Axiom dec_context_val_bot    : forall f v v0, dec_context f v = in_val v0 -> forall f0, ~ f0 <: f.
  Axiom dec_context_clo_next   : forall f f0 v c, dec_context f v = in_clo c f0 -> f0 <: f /\ forall f1, f1 <: f -> ~ f0 <: f1.

  Axiom dec_closure_correct : forall c, match dec_closure c with
    | in_red r => redex_to_closure r = c
    | in_val v => value_to_closure v = c
    | in_clo c0 f =>  atom_plug c0 f = c
    end.
  Axiom dec_context_correct : forall f v, match dec_context f v with
    | in_red r  => redex_to_closure r  = atom_plug (value_to_closure v) f
    | in_val v0 => value_to_closure v0 = atom_plug (value_to_closure v) f
    | in_clo c f0 => atom_plug c f0 = atom_plug (value_to_closure v) f
    end.

  Axiom frame_order_antisym : forall f f0, f <: f0 -> ~ f0 <: f.
  Axiom dec_frame_ord : forall c c0 f f0, atom_plug c f = atom_plug c0 f0 -> f <: f0 \/ f0 <: f \/ (c = c0 /\ f = f0).
  Axiom frame_det : forall c c0 f f0, f <: f0 -> atom_plug c f = atom_plug c0 f0 -> exists v, c0 = value_to_closure v.

  Definition dcl c cC ofC : Prop :=
  match ofC with
  | None => c = closureC_to_closure cC
  | Some fC => dec_closure c = in_clo (closureC_to_closure cC) (frameC_to_frame fC)
  end.

  Parameter closure_red : forall cC r cl (DCL : dec_closure (closureC_to_closure cC) = in_red r) (CTR : contract r = Some cl),
    {p : closureC * option frameC | match p with (cC, ofC) => dcl cl cC ofC end }.
  Parameter context_red : forall fC vC r cl (DCT : dec_context (frameC_to_frame fC) (valueC_to_value vC) = in_red r) (CTR : contract r = Some cl),
    {p : closureC * option frameC | match p with (cC, ofC) => dcl cl cC ofC end}.
  Parameter closure_val : forall cC v (DCL : dec_closure (closureC_to_closure cC) = in_val v), { vC : valueC | v = valueC_to_value vC}.
  Parameter context_val : forall fC vC v (DCT : dec_context (frameC_to_frame fC) (valueC_to_value vC) = in_val v),
    {vC0 : valueC | v = valueC_to_value vC0}.
  Parameter context_clo : forall fC vC cl f (DCT : dec_context (frameC_to_frame fC) (valueC_to_value vC) = in_clo cl f),
    { p : closureC * frameC | match p with
      (cC, fC) => cl = closureC_to_closure (cC) /\ f = frameC_to_frame fC
    end}.

  Close Scope red_scope.

End RED_REF_LANG.

  Ltac prove_st_wf := intro a; constructor; induction a; (intros y H;
    inversion H as [c c0 f DECT]; subst; destruct f; inversion DECT; subst; constructor; auto).
  Ltac prove_ec_wf := intro a; destruct a; repeat (constructor; intros f T; destruct f; inversion T; subst; clear T).

Module Type ABSTRACT_MACHINE.

  Parameters term value configuration : Set.
  Parameter c_init : term -> configuration.
  Parameter c_final : value -> configuration.
  Parameter transition : configuration -> configuration -> Prop.

  Inductive trans_close : configuration -> configuration -> Prop :=
  | one_step   : forall (c0 c1 : configuration), transition c0 c1 -> trans_close c0 c1
  | multi_step : forall (c0 c1 c2 : configuration), transition c0 c1 -> trans_close c1 c2 -> trans_close c0 c2.

  Inductive eval : term -> value -> Prop :=
  | e_intro : forall (t : term) (v : value), trans_close (c_init t) (c_final v) -> eval t v.

End ABSTRACT_MACHINE.


Require Import LogicMain.
Import ListNotations.

Obligation Tactic := congruence.

Inductive ports := A | B | C | D | E | F | G.

Program Instance portsEq : EqDec ports eq :=
	{equiv_dec x y :=
		match x, y with
		| A,A => in_left
		| B,B => in_left
		| C,C => in_left
		| D,D => in_left
		| E,E => in_left
		| F,F => in_left
		| G,G => in_left
		| A,B => in_right
		| A,C => in_right
		| A,D => in_right
		| A,E => in_right
		| A,F => in_right
		| A,G => in_right
		| B,A => in_right
		| B,C => in_right
		| B,D => in_right
		| B,E => in_right
		| B,F => in_right
		| B,G => in_right
		| C,A => in_right
		| C,B => in_right
		| C,D => in_right
		| C,E => in_right
		| C,F => in_right
		| C,G => in_right
		| D,A => in_right
		| D,B => in_right
		| D,C => in_right
		| D,E => in_right
		| D,F => in_right
		| D,G => in_right
		| E,A => in_right
		| E,B => in_right
		| E,C => in_right
		| E,D => in_right
		| E,F => in_right
		| E,G => in_right
		| F,A => in_right
		| F,B => in_right
		| F,C => in_right
		| F,D => in_right
		| F,E => in_right
		| F,G => in_right
		| G,A => in_right
		| G,B => in_right
		| G,C => in_right
		| G,D => in_right
		| G,E => in_right
		| G,F => in_right
		end
	}.

Inductive statesLossyFifo := D_A | D_B | D_C | D_BFIFOC.

Program Instance statesLossyFifoEqDec : EqDec statesLossyFifo eq :=
	{equiv_dec x y :=
		match x, y with
		| D_A,D_A => in_left
		| D_B,D_B => in_left
		| D_C,D_C => in_left
		| D_BFIFOC,D_BFIFOC => in_left
    | D_A,D_B => in_right
		| D_A,D_C => in_right
		| D_A,D_BFIFOC => in_right
    | D_B,D_A => in_right
		| D_B,D_C => in_right
		| D_B,D_BFIFOC => in_right
    | D_C,D_A => in_right
		| D_C,D_B => in_right
    | D_C, D_BFIFOC => in_right
		| D_BFIFOC,D_A => in_right
    | D_BFIFOC,D_B => in_right
		| D_BFIFOC,D_C => in_right

		end
	}.

Inductive statesSequencer := DA | DB | DC | DD | DE | DF | DG | D_DFIFOE | D_EFIFOF | D_FFIFOG.

Program Instance statesEqDec : EqDec statesSequencer eq :=
	{equiv_dec x y :=
		match x, y with
		| DA,DA => in_left
		| DB,DB => in_left
    | DD,DD => in_left
		| DC,DC => in_left
		| DE,DE => in_left
		| DF,DF => in_left
		| DG,DG => in_left
		| D_DFIFOE,D_DFIFOE => in_left
		| D_EFIFOF,D_EFIFOF => in_left
		| D_FFIFOG,D_FFIFOG => in_left
		| DA,DB => in_right
		| DA,DC => in_right
    | DA,DD => in_right
		| DA,DE => in_right
		| DA,DF => in_right
		| DA,DG => in_right
		| DA,D_DFIFOE => in_right
		| DA,D_EFIFOF => in_right
		| DA,D_FFIFOG => in_right
		| DB,DA => in_right
		| DB,DC => in_right
    | DB,DD => in_right
		| DB,DE => in_right
		| DB,DF => in_right
		| DB,DG => in_right
		| DB,D_DFIFOE => in_right
		| DB,D_EFIFOF => in_right
		| DB,D_FFIFOG => in_right
		| DC,DA => in_right
		| DC,DB => in_right
    | DC,DD => in_right
		| DC,DE => in_right
		| DC,DF => in_right
		| DC,DG => in_right
		| DC,D_DFIFOE => in_right
		| DC,D_EFIFOF => in_right
		| DC,D_FFIFOG => in_right
		| DE,DA => in_right
		| DE,DB => in_right
    | DE,DD => in_right
		| DE,DC => in_right
		| DE,DF => in_right
		| DE,DG => in_right
		| DE,D_DFIFOE => in_right
		| DE,D_EFIFOF => in_right
		| DE,D_FFIFOG => in_right
		| DF,DA => in_right
		| DF,DB => in_right
    | DF,DD => in_right
		| DF,DC => in_right
		| DF,DE => in_right
		| DF,DG => in_right
		| DF,D_DFIFOE => in_right
		| DF,D_EFIFOF => in_right
		| DF,D_FFIFOG => in_right
		| DG,DA => in_right
		| DG,DB => in_right
		| DG,DC => in_right
    | DG,DD => in_right
		| DG,DE => in_right
		| DG,DF => in_right
		| DG,D_DFIFOE => in_right
		| DG,D_EFIFOF => in_right
		| DG,D_FFIFOG => in_right
		| D_DFIFOE,DA => in_right
		| D_DFIFOE,DB => in_right
		| D_DFIFOE,DC => in_right
		| D_DFIFOE,DD => in_right
		| D_DFIFOE,DE => in_right
		| D_DFIFOE,DF => in_right
		| D_DFIFOE,DG => in_right
		| D_DFIFOE,D_EFIFOF => in_right
		| D_DFIFOE,D_FFIFOG => in_right
		| D_EFIFOF,DA => in_right
		| D_EFIFOF,DB => in_right
		| D_EFIFOF,DC => in_right
		| D_EFIFOF,DD => in_right
		| D_EFIFOF,DE => in_right
		| D_EFIFOF,DF => in_right
		| D_EFIFOF,DG => in_right
		| D_EFIFOF,D_DFIFOE => in_right
		| D_EFIFOF,D_FFIFOG => in_right
		| D_FFIFOG,DA => in_right
		| D_FFIFOG,DB => in_right
		| D_FFIFOG,DC => in_right
		| D_FFIFOG,DD => in_right
		| D_FFIFOG,DE => in_right
		| D_FFIFOG,DF => in_right
		| D_FFIFOG,DG => in_right
		| D_FFIFOG,D_DFIFOE => in_right
		| D_FFIFOG,D_EFIFOF => in_right
    | DD,DA => in_right
    | DD,DB => in_right
		| DD,DC => in_right
		| DD,DE => in_right
		| DD,DF => in_right
		| DD,DG => in_right
		| DD,D_DFIFOE => in_right
		| DD,D_EFIFOF => in_right
		| DD,D_FFIFOG => in_right
		end
	}.

Close Scope Q_scope.

Program Instance dataProp_eqdec2 {name data : Type} `{EqDec name eq} `{EqDec data eq} : EqDec (dataProp name data) eq :=
    {
      equiv_dec x y :=
        match x, y with
          | dataInPorts a x, dataInPorts b y => if a == b then if x == y then in_left else in_right else in_right
          | dataInFifo a x b, dataInFifo c y d => if a == c then if b == d then if x == y then in_left else in_right else in_right else in_right
          | dataBothPorts _ a b, dataBothPorts _ c d => if a == c then if b == d then in_left else in_right else in_right
          | dataInPorts a x , dataInFifo b y c => in_right
          | dataInPorts a x , dataBothPorts _ b y => in_right
          | dataInFifo a x b , dataInPorts c y => in_right
          | dataInFifo a x b , dataBothPorts _ c y => in_right
          | dataBothPorts _ a b , dataInPorts c y => in_right
          | dataBothPorts _ a b , dataInFifo c y d  => in_right
        end
     }.

(** Sequencer - Simplified**)
Definition SequencerProgram := [flowFifo nat D E; flowSync nat E A; flowFifo nat E F;
flowSync nat F B; flowFifo nat F G; flowSync nat G C; flowSync nat G D].

(* experimental *)
Definition sequencerLambda (s: statesSequencer) (port: ports) : QArith_base.Q := 1.

(* We define \delta \colon S \to T as follows.*)
Definition deltaSequencer (s:statesSequencer) :=
  match s with
  | DA => [dataPorts A 0;dataPorts A 1]
  | DB => [dataPorts B 0;dataPorts B 1]
  | DC => [dataPorts C 0;dataPorts C 1]
  | DD => [dataPorts D 0;dataPorts D 1]
  | DE => [dataPorts E 0;dataPorts E 1]
  | DF => [dataPorts F 0;dataPorts F 1]
  | DG => [dataPorts G 0;dataPorts G 1]
  | D_EFIFOF => [fifoData E 0 F; fifoData E 1 F]
  | D_FFIFOG => [fifoData F 0 G; fifoData F 1 G]
  | D_DFIFOE => [fifoData D 0 E; fifoData D 1 E]
  end.

Definition sequencerFrame := mkframe [DA;DB;DC;DD;DE;DF;DG;D_DFIFOE;D_EFIFOF;D_FFIFOG]
                    [(DD,D_DFIFOE);(D_DFIFOE,DE);(DE,DA);(DE,D_EFIFOF);(D_EFIFOF,DF);(DF,DB);(DF,D_FFIFOG);
                      (D_FFIFOG,DG);(DG,DC);(DG,DD)] sequencerLambda deltaSequencer.

(* Idea  - map a natural number to a proposition. Then, our valuation function state -> set nat
  tells us which propositions are valid in a state. This is entirely controlled by the user's model. *)

(* Definition sequencerPropositions (n: nat) : Prop :=
  match n with
  | 1 => dataInPort (dataPorts A 0) n
  | 2 => dataInPort (dataPorts B 0) n
  | 3 => dataInPort (dataPorts C 0) n
  | 4 => dataInPort (dataPorts D 0) n
  | _ => False
  end. *)

Definition getPropositionSequencer (s: statesSequencer) :=
  match s with
  | DA => [dataInPorts A 0; dataInPorts A 1]
  | DB => [dataInPorts B 0; dataInPorts B 1]
  | DC => [dataInPorts C 0; dataInPorts C 1]
  | DD => [dataInPorts D 0; dataInPorts D 1]
  | DE => []
  | DF => []
  | DG => []
  | D_EFIFOF => []
  | D_FFIFOG => []
  | D_DFIFOE => []
  end.

Definition sequencerValuation (s: statesSequencer) (p : (dataProp ports nat)) :=
  existsb (fun x : (dataProp ports nat) => equiv_decb p x) (getPropositionSequencer s).

Definition sequencerModel := mkmodel sequencerFrame sequencerValuation.

Definition pi := sProgram (reoProg SequencerProgram []).

Definition piStar' := star (reoProg SequencerProgram []).

Definition t := [dataPorts D 1].

Eval compute in singleFormulaVerify sequencerModel
(box t pi (proposition (dataInPorts B 1))) t.

(* Example 1 *)

Eval compute in singleFormulaVerify sequencerModel
      (box t pi
        (((neg ((and (and (proposition (dataInPorts A 1)) (proposition (dataInPorts B 1)))
           (proposition (dataInPorts C 1)))))))) t.

(* Example 2 *)
Eval compute in singleFormulaVerify sequencerModel
      (imp
          (box t piStar' (proposition (dataInPorts D 1)))
           (box t piStar' (proposition (dataInPorts C 1))))  t.

(*Example 1 - TABLEAUX 2021*)

Definition example1Relo := Eval compute in constructModel [A ; B ; C ; D ; E ; F ; G] [t]
  (imp (box t piStar'((((((((proposition (dataInPorts C 1))))))))))
        (box t piStar'((((((((proposition (dataInPorts B 1))))))))))) (length(SequencerProgram) * 3).

Eval compute in example1Relo.

(*The validity of the formula is checked by the below definition*)

Definition validityExample1Relo := singleFormulaVerify example1Relo
  (imp (box t piStar'((((((((proposition (dataInPorts C 1))))))))))
        (box t piStar'((((((((proposition (dataInPorts B 1))))))))))) t.

Eval compute in validityExample1Relo.


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

Definition peep_inc_dec_nop_example : code :=
  Pinc EAX :: Pdec EAX :: nil.

Section INC_DEC_NOP.

  Variable concrete : code.

  Variable r1 : ireg.

  Definition peep_inc_dec_nop_defs : rewrite_defs :=
    {|
      fnd :=
        Pinc r1 :: Pdec r1 :: nil
      ; rpl :=
          Pnop :: Pnop :: nil
      ; lv_in := IR r1 :: PC :: nil
      ; lv_out := IR r1 :: PC :: nil
      ; clobbered := flags
    |}.

  Lemma peep_inc_dec_nop_selr :
    StepEquiv.step_through_equiv_live (fnd peep_inc_dec_nop_defs) (rpl peep_inc_dec_nop_defs) (lv_in peep_inc_dec_nop_defs) (lv_out peep_inc_dec_nop_defs).
  Proof.
    prep_l.
    step_l.
    step_l.
    prep_r.
    step_r.
    step_r.
    finish_r.
    prep_eq.
    split.
    2: eq_mem_tac.
    intros.
    simpl_and_clear.
    (*r1*)
    break_or'. subst reg.
    subst_max.
    preg_simpl.
    unfold Val.add.
    unfold Val.sub.
    simpl.
    repeat (break_match_sm; try congruence).
    simpl.
    P0 _simpl val_eq.
    rewrite <- H0.
    f_equal.
    ring.
    simpl.
    P0 _simpl val_eq.
    assumption.
    (*PC*)
    break_or'.
    2: inv_false.
    subst reg.
    preg_simpl.
    repeat find_rewrite_goal.
    simpl.
    f_equal.
  Qed.

  Definition peep_inc_dec_nop_proofs : rewrite_proofs :=
    {|
      defs := peep_inc_dec_nop_defs
      ; selr := peep_inc_dec_nop_selr
    |}.

  Definition peep_inc_dec_nop :
    concrete = fnd peep_inc_dec_nop_defs ->
    StepEquiv.rewrite.
  Proof.
    intros.
    peep_tac_mk_rewrite peep_inc_dec_nop_defs peep_inc_dec_nop_proofs.
  Qed.

End INC_DEC_NOP.

Definition peep_inc_dec_nop_rewrite (c : code) : option StepEquiv.rewrite.
  name peep_inc_dec_nop p.
  unfold peep_inc_dec_nop_defs in p.
  simpl in p.
  specialize (p c).
  do 2 set_code_cons c.
  set_code_nil c.
  set_instr_eq i 0%nat peep_inc_dec_nop_example.
  set_instr_eq i0 1%nat peep_inc_dec_nop_example.
  set_ireg_eq rd rd0.
  specialize (p _ eq_refl). exact (Some p).
Defined.

Definition inc_dec_nop (c : code) : list StepEquiv.rewrite :=
  collect (map peep_inc_dec_nop_rewrite (ParamSplit.matched_pat peep_inc_dec_nop_example c)).