Require Import VST.floyd.proofauto.
Require Import VST.progs.strlib.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition strchr_spec :=
 DECLARE _strchr
  WITH sh: share, str : val, s : list byte, c : byte
  PRE  [ _str OF tptr tschar, _c OF tint ]
    PROP (readable_share sh; c <> Byte.zero)
    LOCAL (temp _str str; temp _c (Vbyte c))
    SEP (cstring sh s str)
  POST [ tptr tschar ]
   EX r : val,
    PROP ((exists i, Znth i s = c /\ Forall (fun d => d<>c) (sublist 0 i s)
                     /\ r = offset_val i str)
       \/ (Forall (fun d => d<>c) s /\ r = nullval))
    LOCAL (temp ret_temp r)
    SEP (cstring sh s str).

Definition strcat_spec :=
 DECLARE _strcat
  WITH sh: share, sh': share, dest : val, sd : list byte, n : Z, src : val, ss : list byte
  PRE  [ _dest OF tptr tschar, _src OF tptr tschar ]
    PROP (writable_share sh; readable_share sh'; Zlength sd + Zlength ss < n)
    LOCAL (temp _dest dest; temp _src src)
    SEP (cstringn sh sd n dest; cstring sh' ss src)
  POST [ tptr tschar ]
    PROP ()
    LOCAL (temp ret_temp dest)
    SEP (cstringn sh (sd ++ ss) n dest; cstring sh' ss src).

Definition strcmp_spec :=
 DECLARE _strcmp
  WITH sh1: share, sh2: share, str1 : val, s1 : list byte, str2 : val, s2 : list byte
  PRE [ _str1 OF tptr tschar, _str2 OF tptr tschar ]
    PROP (readable_share sh1; readable_share sh2)
    LOCAL (temp _str1 str1; temp _str2 str2)
    SEP (cstring sh1 s1 str1; cstring sh2 s2 str2)
  POST [ tint ]
   EX i : int,
    PROP (if Int.eq_dec i Int.zero then s1 = s2 else s1 <> s2)
    LOCAL (temp ret_temp (Vint i))
    SEP (cstring sh1 s1 str1; cstring sh2 s2 str2).

Definition strcpy_spec :=
 DECLARE _strcpy
  WITH sh: share, sh': share, dest : val, n : Z, src : val, s : list byte
  PRE [ _dest OF tptr tschar, _src OF tptr tschar ]
    PROP (writable_share sh; readable_share sh'; Zlength s < n)
    LOCAL (temp _dest dest; temp _src src)
    SEP (data_at_ sh (tarray tschar n) dest; cstring sh' s src)
  POST [ tptr tschar ]
    PROP ()
    LOCAL (temp ret_temp dest)
    SEP (cstringn sh s n dest; cstring sh' s src).

Definition strlen_spec :=
 DECLARE _strlen
  WITH sh: share, s : list byte, str: val
  PRE [ _str OF tptr tschar ]
    PROP (readable_share sh)
    LOCAL (temp _str str)
    SEP (cstring sh s str)
  POST [ tptr tschar ]
    PROP ()
    LOCAL (temp ret_temp (Vptrofs (Ptrofs.repr (Zlength s))))
    SEP (cstring sh s str).

Definition Gprog : funspecs :=
         ltac:(with_library prog [ strchr_spec; strcat_spec; strcmp_spec ]).

Hint Rewrite Z.add_simpl_r Z.sub_simpl_r : norm entailer_rewrite.

Lemma body_strlen: semax_body Vprog Gprog f_strlen strlen_spec.
Proof.
start_function.
unfold cstring in *.
rename s into ls.
Intros.
forward.
forward_loop (EX i : Z,
  PROP (0 <= i < Zlength ls + 1)
  LOCAL (temp _str str; temp _i (Vptrofs (Ptrofs.repr i)))
  SEP (data_at sh (tarray tschar (Zlength ls + 1))
          (map Vbyte (ls ++ [Byte.zero])) str))
 continue: (EX i : Z,
  PROP (0 <= i < Zlength ls + 1)
  LOCAL (temp _str str; temp _i (Vptrofs (Ptrofs.repr (i-1))))
  SEP (data_at sh (tarray tschar (Zlength ls + 1))
          (map Vbyte (ls ++ [Byte.zero])) str)).
*
Exists 0. entailer!.
*
Intros i.
assert (Zlength (ls ++ [Byte.zero]) = Zlength ls + 1) by (autorewrite with sublist; auto).
forward.
forward_if.
forward.
entailer!. f_equal. f_equal. cstring.
forward.
Exists (i+1).
entailer!. cstring.
*
Intros i.
forward.
Exists i.
entailer!.
Qed.

Lemma body_strchr: semax_body Vprog Gprog f_strchr strchr_spec.
Proof.
start_function.
forward.
unfold cstring in *.
rename s into ls.
Intros.
forward_loop (EX i : Z,
  PROP (0 <= i < Zlength ls + 1; Forall (fun d => d <> c) (sublist 0 i ls))
  LOCAL (temp _str str; temp _c (Vbyte c); temp _i (Vint (Int.repr i)))
  SEP (data_at sh (tarray tschar (Zlength ls + 1))
          (map Vbyte (ls ++ [Byte.zero])) str))
 continue: (EX i : Z,
  PROP (0 <= i < Zlength ls + 1; Forall (fun d => d <> c) (sublist 0 i ls))
  LOCAL (temp _str str; temp _c (Vbyte c); temp _i (Vint (Int.repr (i-1))))
  SEP (data_at sh (tarray tschar (Zlength ls + 1))
          (map Vbyte (ls ++ [Byte.zero])) str)).
  Exists 0; rewrite sublist_nil; entailer!.
- Intros i.
  assert (Zlength (ls ++ [Byte.zero]) = Zlength ls + 1) by (autorewrite with sublist; auto).
  forward. normalize.
  forward. fold_Vbyte.
 forward_if.
  { forward. simpl.
    Exists (offset_val i str).
    entailer!.
    left. exists i. split3; auto. rewrite app_Znth1; auto. cstring. }
  { forward_if.
    { forward.
      Exists nullval; rewrite !map_app; entailer!.
      right. split; auto.
      assert (i = Zlength ls) by cstring.
      subst i.
     autorewrite with sublist in H2; auto. }
  forward.
  Exists (i+1); entailer!.
  assert (i <> Zlength ls) by cstring.
  split. omega.
  rewrite (sublist_split 0 i) by rep_omega. rewrite Forall_app. split; auto.
  rewrite sublist_len_1 by rep_omega. repeat constructor.
  rewrite app_Znth1 in H4 by rep_omega. auto.
  }
-
  Intros i.
  forward.
  Exists i.
 entailer!.
Qed.

Lemma split_data_at_app_tschar:
 forall sh n (al bl: list val) p ,
   n = Zlength (al++bl) ->
   data_at sh (tarray tschar n) (al++bl) p =
         data_at sh (tarray tschar (Zlength al)) al p
        * data_at sh (tarray tschar (n - Zlength al)) bl
                 (field_address0 (tarray tschar n) [ArraySubsc (Zlength al)] p).
Proof.
intros.
apply (split2_data_at_Tarray_app _ n  sh tschar al bl ); auto.
rewrite Zlength_app in H.
change ( Zlength bl = n - Zlength al); omega.
Qed.

Lemma body_strcat: semax_body Vprog Gprog f_strcat strcat_spec.
Proof.
start_function.
unfold cstringn, cstring in *.
rename sd into ld. rename ss into ls.
Intros.
forward.
forward_loop (EX i : Z,
    PROP (0 <= i < Zlength ld + 1)
    LOCAL (temp _i (Vint (Int.repr i)); temp _dest dest; temp _src src)
    SEP (data_at sh (tarray tschar n)
          (map Vbyte (ld ++ [Byte.zero]) ++
           list_repeat (Z.to_nat (n - (Zlength ld + 1))) Vundef) dest;
   data_at sh' (tarray tschar (Zlength ls + 1))
     (map Vbyte (ls ++ [Byte.zero])) src))
 continue: (EX i : Z,
    PROP (0 <= i < Zlength ld + 1)
    LOCAL (temp _i (Vint (Int.repr (i-1))); temp _dest dest; temp _src src)
    SEP (data_at sh (tarray tschar n)
          (map Vbyte (ld ++ [Byte.zero]) ++
           list_repeat (Z.to_nat (n - (Zlength ld + 1))) Vundef) dest;
   data_at sh' (tarray tschar (Zlength ls + 1))
     (map Vbyte (ls ++ [Byte.zero])) src))
  break: (PROP ( )
   LOCAL (temp _i (Vint (Int.repr (Zlength ld))); temp _dest dest;
   temp _src src)
   SEP (data_at sh (tarray tschar n)
          (map Vbyte (ld ++ [Byte.zero]) ++
           list_repeat (Z.to_nat (n - (Zlength ld + 1))) Vundef) dest;
   data_at sh' (tarray tschar (Zlength ls + 1))
     (map Vbyte (ls ++ [Byte.zero])) src)).
-
  Exists 0; entailer!.
-
  Intros i.
  forward.
  { entailer!. }
  { entailer!. autorewrite with sublist. normalize.  }
  autorewrite with sublist; normalize.
  forward.
  forward_if.
  + forward.
    entailer!. f_equal. f_equal. cstring.
  +
    forward.
    Exists (i+1); entailer!. cstring.
- Intros i.
   forward.
   Exists i. entailer!.
-
  abbreviate_semax.
  forward.
  forward_loop (EX j : Z,
    PROP (0 <= j < Zlength ls + 1)
    LOCAL (temp _j (Vint (Int.repr j)); temp _i (Vint (Int.repr (Zlength ld)));
           temp _dest dest; temp _src src)
    SEP (data_at sh (tarray tschar n)
          (map Vbyte (ld ++ sublist 0 j ls) ++
           list_repeat (Z.to_nat (n - (Zlength ld + j))) Vundef) dest;
         data_at sh' (tarray tschar (Zlength ls + 1))
           (map Vbyte (ls ++ [Byte.zero])) src))
   continue: (EX j : Z,
    PROP (0 <= j < Zlength ls + 1)
    LOCAL (temp _j (Vint (Int.repr (j-1))); temp _i (Vint (Int.repr (Zlength ld)));
           temp _dest dest; temp _src src)
    SEP (data_at sh (tarray tschar n)
          (map Vbyte (ld ++ sublist 0 j ls) ++
           list_repeat (Z.to_nat (n - (Zlength ld + j))) Vundef) dest;
         data_at sh' (tarray tschar (Zlength ls + 1))
           (map Vbyte (ls ++ [Byte.zero])) src)).
  { Exists 0; entailer!.  autorewrite with sublist.
    rewrite !map_app. rewrite <- app_assoc.
    rewrite split_data_at_app_tschar by list_solve.
    rewrite (split_data_at_app_tschar _ n) by list_solve.
    autorewrite with sublist.
    cancel.
   }
  { Intros j.
  assert (Zlength (ls ++ [Byte.zero]) = Zlength ls + 1) by (autorewrite with sublist; auto).
  forward. normalize.
  forward. fold_Vbyte.
  forward.
  entailer!.
  clear H3.
  rewrite upd_Znth_app2 by list_solve.
  autorewrite with sublist.
  forward_if.
  + forward.
      autorewrite with sublist.
      rewrite prop_true_andp
        by (intro Hx; apply in_app in Hx; destruct Hx; contradiction).
      cancel.
    assert (j = Zlength ls) by cstring; subst.
    autorewrite with sublist.
    apply derives_refl'.
    unfold data_at; f_equal.
    replace (n - (Zlength ld + Zlength ls))
     with (1 + (n - (Zlength ld + Zlength ls+1))) by rep_omega.
    rewrite <- list_repeat_app' by rep_omega.
    rewrite upd_Znth_app1 by list_solve.
    rewrite app_assoc.
    simpl.
    rewrite !map_app.
    reflexivity.
 +
  forward.
  Exists (j+1).
  destruct (zlt j (Zlength ls)); [ | cstring].
  entailer!.
  change (field_at Tsh (tarray tschar n) []) with (data_at Tsh (tarray tschar n)).
  rewrite (sublist_split 0 j (j+1)) by rep_omega.
  rewrite (app_assoc ld). rewrite !map_app.
  rewrite <- (app_assoc (_ ++ _)).
  rewrite (split_data_at_app_tschar _ n) by list_solve.
  rewrite (split_data_at_app_tschar _ n) by list_solve.
  replace (n - (Zlength ld + j))
    with (1 + (n - (Zlength ld + (j + 1)))) by rep_omega.
  rewrite <- list_repeat_app' by rep_omega.
  cancel.
  rewrite upd_Znth_app1 by (autorewrite with sublist; rep_omega).
  rewrite app_Znth1 by list_solve.
  rewrite sublist_len_1 by rep_omega.
  cancel.
  }
 + Intros j. forward. Exists j. entailer!.
Qed.

Lemma body_strcmp: semax_body Vprog Gprog f_strcmp strcmp_spec.
Proof.
start_function.
unfold cstring in *.
rename s1 into ls1. rename s2 into ls2.
forward.
Intros.
forward_loop (EX i : Z,
  PROP (0 <= i < Zlength ls1 + 1; 0 <= i < Zlength ls2 + 1;
        sublist 0 i ls1 = sublist 0 i ls2)
  LOCAL (temp _str1 str1; temp _str2 str2; temp _i (Vint (Int.repr i)))
  SEP (data_at sh1 (tarray tschar (Zlength ls1 + 1))
          (map Vbyte (ls1 ++ [Byte.zero])) str1;
       data_at sh2 (tarray tschar (Zlength ls2 + 1))
          (map Vbyte (ls2 ++ [Byte.zero])) str2))
  continue: (EX i : Z,
  PROP (0 <= i < Zlength ls1 + 1; 0 <= i < Zlength ls2 + 1;
        sublist 0 i ls1 = sublist 0 i ls2)
  LOCAL (temp _str1 str1; temp _str2 str2; temp _i (Vint (Int.repr (i-1))))
  SEP (data_at sh1 (tarray tschar (Zlength ls1 + 1))
          (map Vbyte (ls1 ++ [Byte.zero])) str1;
       data_at sh2 (tarray tschar (Zlength ls2 + 1))
          (map Vbyte (ls2 ++ [Byte.zero])) str2)).
- Exists 0; entailer!.
- Intros i.
  assert (Zlength (ls1 ++ [Byte.zero]) = Zlength ls1 + 1) by (autorewrite with sublist; auto).
  forward. normalize.
  assert (Zlength (ls2 ++ [Byte.zero]) = Zlength ls2 + 1) by (autorewrite with sublist; auto).
  forward. fold_Vbyte.
  assert (Znth i (ls1 ++ [Byte.zero]) = Byte.zero <-> i = Zlength ls1) as Hs1.
  { split; [|intro; subst; rewrite app_Znth2, Zminus_diag by omega; auto].
    destruct (zlt i (Zlength ls1)); [|omega].
    intro X; lapply (Znth_In i ls1); [|omega]. cstring. }
  assert (Znth i (ls2 ++ [Byte.zero]) = Byte.zero <-> i = Zlength ls2) as Hs2.
  { split; [|intro; subst; rewrite app_Znth2, Zminus_diag by omega; auto].
    destruct (zlt i (Zlength ls2)); [|omega].
    intro X; lapply (Znth_In i ls2); [|omega]. cstring. }
  forward. normalize.
  forward. fold_Vbyte.
  forward_if (temp _t'1 (Val.of_bool (Z.eqb i (Zlength ls1) && Z.eqb i (Zlength ls2)))).
  { forward.
    simpl force_val.
    rewrite Hs1 in *.
    destruct (Byte.eq_dec (Znth i (ls2 ++ [Byte.zero])) Byte.zero).
    + rewrite e; simpl force_val.
         assert (i = Zlength ls2) by cstring.
        rewrite  (proj2 Hs1 H6).
     rewrite (proj2 (Z.eqb_eq i (Zlength ls1)) H6).
     rewrite (proj2 (Z.eqb_eq i (Zlength ls2)) H7).
     entailer!.
  +
    rewrite Int.eq_false.
     rewrite (proj2 (Z.eqb_eq i (Zlength ls1)) H6).
     rewrite Hs2 in n.
     rewrite (proj2 (Z.eqb_neq i (Zlength ls2))) by auto.
    entailer!.
     contradict n.
     apply repr_inj_signed in n; try rep_omega. normalize in n.
 }
  { forward.
    entailer!.
    destruct (i =? Zlength ls1) eqn: Heq; auto.
    rewrite Z.eqb_eq in Heq; tauto. }
  forward_if.
 +
  rewrite andb_true_iff in H6; destruct H6.
  rewrite Z.eqb_eq in H6,H7.
  forward.
  Exists (Int.repr 0).
  entailer!. simpl.
  autorewrite with sublist in H3.
  auto.
 +
  deadvars!.
  rewrite andb_false_iff in H6. rewrite !Z.eqb_neq in H6.
  forward_if.
  *
    forward. Exists (Int.repr (-1)). entailer!.
    simpl. intro; subst. omega.
 *
   forward_if.
   forward.
   Exists (Int.repr 1). entailer!. simpl. intro. subst. omega.

   assert (H17: Byte.signed (Znth i (ls1 ++ [Byte.zero])) =
     Byte.signed (Znth i (ls2 ++ [Byte.zero]))) by omega.
   normalize in H17. clear H7 H8.
   forward.
   Exists (i+1).
   entailer!.
   clear H7 H8.
   clear H13 H14 H12 PNstr1 PNstr2.
   clear H10 H11 H9.
   destruct (zlt i (Zlength ls1)).
  2:{
         rewrite app_Znth2 in Hs1 by rep_omega.
         destruct (zeq i (Zlength ls1)); [ | omega].
         subst.
         destruct H6; [congruence | ].
         assert (Zlength ls1 < Zlength ls2) by omega.
         rewrite app_Znth2 in H17 by rep_omega.
         rewrite app_Znth1 in H17 by rep_omega.
         rewrite Z.sub_diag in H17. contradiction H0.
         change (Znth 0 [Byte.zero]) with Byte.zero in H17. rewrite H17.
         apply Znth_In. omega.
   }
  destruct (zlt i (Zlength ls2)).
  2:{
         rewrite app_Znth2 in Hs2 by rep_omega.
         destruct (zeq i (Zlength ls2)); [ | omega].
         subst.
         destruct H6; [ | congruence].
         assert (Zlength ls1 > Zlength ls2) by omega.
         rewrite app_Znth1 in H17 by rep_omega.
         rewrite app_Znth2 in H17 by rep_omega.
         rewrite Z.sub_diag in H17. contradiction H.
         change (Znth 0 [Byte.zero]) with Byte.zero in H17. rewrite <- H17.
         apply Znth_In. omega.
   }
  rewrite (sublist_split 0 i (i+1)) by omega.
  rewrite (sublist_split 0 i (i+1)) by omega.
  f_equal; auto.
  rewrite !sublist_len_1 by omega.
  rewrite !app_Znth1 in H17 by list_solve.
  split. rep_omega. split. rep_omega.
  f_equal; auto. f_equal. auto.
 -
  Intros i.
  forward.
  Exists i.
  entailer!.
Qed.

Lemma body_strcpy: semax_body Vprog Gprog f_strcpy strcpy_spec.
Proof.
start_function.
unfold cstring,cstringn in *.
rename s into ls.
forward.
Intros.
forward_loop (EX i : Z,
  PROP (0 <= i < Zlength ls + 1)
  LOCAL (temp _i (Vint (Int.repr i)); temp _dest dest; temp _src src)
  SEP (data_at sh (tarray tschar n)
        (map Vbyte (sublist 0 i ls) ++ list_repeat (Z.to_nat (n - i)) Vundef) dest;
       data_at sh' (tarray tschar (Zlength ls + 1)) (map Vbyte (ls ++ [Byte.zero])) src))
 continue: (EX i : Z,
  PROP (0 <= i < Zlength ls + 1)
  LOCAL (temp _i (Vint (Int.repr (i-1))); temp _dest dest; temp _src src)
  SEP (data_at sh (tarray tschar n)
        (map Vbyte (sublist 0 i ls) ++ list_repeat (Z.to_nat (n - i)) Vundef) dest;
       data_at sh' (tarray tschar (Zlength ls + 1)) (map Vbyte (ls ++ [Byte.zero])) src)).
*
 Exists 0. rewrite Z.sub_0_r; entailer!. simpl. entailer!.
*
 Intros i.
 assert (Zlength (ls ++ [Byte.zero]) = Zlength ls + 1) by (autorewrite with sublist; auto).
 forward. normalize.
 forward. fold_Vbyte.
 forward.
 forward_if.
+ forward.
   entailer!.
  assert (i = Zlength ls) by cstring. subst i.
  change (field_at Tsh (tarray tschar n) []) with (data_at Tsh (tarray tschar n)).
  rewrite upd_Znth_app2 by list_solve.
  autorewrite with sublist.
  rewrite !map_app.
  rewrite <- app_assoc.
   rewrite (split_data_at_app_tschar _ n) by list_solve.
   rewrite (split_data_at_app_tschar _ n) by list_solve.
   autorewrite with sublist.
   replace (n - Zlength ls) with (1 + (n - (Zlength ls + 1))) at 2 by list_solve.
  rewrite <- list_repeat_app' by omega.
  rewrite upd_Znth_app1 by list_solve.
  rewrite !split_data_at_app_tschar by list_solve.
  cancel.
+
   assert (i < Zlength ls) by cstring.
  forward.
  Exists (i+1). entailer!.
  autorewrite with sublist.
  rewrite (sublist_split 0 i (i+1)) by list_solve.
  rewrite !map_app. rewrite <- app_assoc.
  autorewrite with sublist.
  change (field_at Tsh (tarray tschar n) []) with (data_at Tsh (tarray tschar n)).
  rewrite !(split_data_at_app_tschar _ n) by list_solve.
  autorewrite with sublist.
   replace (n - i) with (1 + (n-(i+ 1))) at 2 by list_solve.
  rewrite <- list_repeat_app' by omega.
  autorewrite with sublist.
  cancel.
  rewrite !split_data_at_app_tschar by list_solve.
  autorewrite with sublist.
  rewrite sublist_len_1 by omega.
  simpl. cancel.
*
  Intros i.
  forward.
  Exists i.
  entailer!.
Qed.

Module Alternate.

(* Alternate proofs of these functions, using the form of "forward_loop"
  that relies on semax_loop_nocontinue *)

Lemma body_strlen: semax_body Vprog Gprog f_strlen strlen_spec.
Proof.
start_function.
unfold cstring in *.
rename s into ls.
Intros.
forward.
forward_loop  (EX i : Z,
  PROP (0 <= i < Zlength ls + 1)
  LOCAL (temp _str str; temp _i (Vptrofs (Ptrofs.repr i)))
  SEP (data_at sh (tarray tschar (Zlength ls + 1))
          (map Vbyte (ls ++ [Byte.zero])) str)).
*
Exists 0. entailer!.
*
Intros i.
assert (Zlength (ls ++ [Byte.zero]) = Zlength ls + 1) by (autorewrite with sublist; auto).
forward.
normalize.
forward_if.
forward.
entailer!. f_equal. f_equal. cstring.
forward. (* entailer!.  *)
Exists (i+1).
entailer!. cstring.
Qed.

Lemma body_strchr: semax_body Vprog Gprog f_strchr strchr_spec.
Proof.
start_function.
forward.
unfold cstring in *.
rename s into ls.
Intros.
forward_loop (EX i : Z,
  PROP (0 <= i < Zlength ls + 1; Forall (fun d => d <> c) (sublist 0 i ls))
  LOCAL (temp _str str; temp _c (Vbyte c); temp _i (Vint (Int.repr i)))
  SEP (data_at sh (tarray tschar (Zlength ls + 1))
          (map Vbyte (ls ++ [Byte.zero])) str)).
  Exists 0; rewrite sublist_nil; entailer!.
- Intros i.
  assert (Zlength (ls ++ [Byte.zero]) = Zlength ls + 1) by (autorewrite with sublist; auto).
  forward. normalize.
  forward. fold_Vbyte.
  forward_if (Znth i (ls ++ [Byte.zero]) <> c).

  { forward. simpl.
    Exists (offset_val i str).
    entailer!.
    left. exists i. split3; auto. rewrite app_Znth1; auto. cstring. }
  { forward.
    entailer!. }
  Intros.
  forward_if.
  { forward.
    Exists nullval; rewrite !map_app; entailer!.
    right. split; auto.
    assert (i = Zlength ls) by cstring.
    subst i.
    autorewrite with sublist in H2; auto. }
  forward. (* entailer!. *)
  Exists (i+1); entailer!.
  assert (i <> Zlength ls) by cstring.
  split. omega.
  rewrite (sublist_split 0 i) by rep_omega. rewrite Forall_app. split; auto.
  rewrite sublist_len_1 by rep_omega. repeat constructor.
  rewrite app_Znth1 in H4 by rep_omega. auto.
Qed.

Lemma body_strcat: semax_body Vprog Gprog f_strcat strcat_spec.
Proof.
start_function.
unfold cstringn, cstring in *.
rename sd into ld. rename ss into ls.
Intros.
forward.
forward_loop (EX i : Z,
    PROP (0 <= i < Zlength ld + 1)
    LOCAL (temp _i (Vint (Int.repr i)); temp _dest dest; temp _src src)
    SEP (data_at sh (tarray tschar n)
          (map Vbyte (ld ++ [Byte.zero]) ++
           list_repeat (Z.to_nat (n - (Zlength ld + 1))) Vundef) dest;
   data_at sh' (tarray tschar (Zlength ls + 1))
     (map Vbyte (ls ++ [Byte.zero])) src))
  break: (PROP ( )
   LOCAL (temp _i (Vint (Int.repr (Zlength ld))); temp _dest dest;
   temp _src src)
   SEP (data_at sh (tarray tschar n)
          (map Vbyte (ld ++ [Byte.zero]) ++
           list_repeat (Z.to_nat (n - (Zlength ld + 1))) Vundef) dest;
   data_at sh' (tarray tschar (Zlength ls + 1))
     (map Vbyte (ls ++ [Byte.zero])) src)).
-
  Exists 0; entailer!.
-
  Intros i.
  forward.
  { entailer!. }
  { entailer!. autorewrite with sublist. normalize.  }
  autorewrite with sublist; normalize.
  forward.
  forward_if (*  (Znth i (ld ++ [Byte.zero]) Byte.zero <> Byte.zero). *)
  + forward.
   (*  entailer!. f_equal. f_equal. cstring. *)
  +
    forward. entailer!. f_equal. f_equal. cstring.
  +
    forward.
    Exists (i+1); entailer!. cstring.
-
  abbreviate_semax.
  forward.
  forward_loop (EX j : Z,
    PROP (0 <= j < Zlength ls + 1)
    LOCAL (temp _j (Vint (Int.repr j)); temp _i (Vint (Int.repr (Zlength ld)));
           temp _dest dest; temp _src src)
    SEP (data_at sh (tarray tschar n)
          (map Vbyte (ld ++ sublist 0 j ls) ++
           list_repeat (Z.to_nat (n - (Zlength ld + j))) Vundef) dest;
         data_at sh' (tarray tschar (Zlength ls + 1))
           (map Vbyte (ls ++ [Byte.zero])) src)).
  { Exists 0; entailer!.  autorewrite with sublist.
    rewrite !map_app. rewrite <- app_assoc.
    rewrite split_data_at_app_tschar by list_solve.
    rewrite (split_data_at_app_tschar _ n) by list_solve.
    autorewrite with sublist.
    cancel.
   }
  { Intros j.
  assert (Zlength (ls ++ [Byte.zero]) = Zlength ls + 1) by (autorewrite with sublist; auto).
  forward. normalize.
  forward. fold_Vbyte.
  forward.
  entailer!.
  clear H3.
  rewrite upd_Znth_app2 by list_solve.
  autorewrite with sublist.
  forward_if.
  + forward.
      autorewrite with sublist.
      rewrite prop_true_andp
        by (intro Hx; apply in_app in Hx; destruct Hx; contradiction).
      cancel.
    assert (j = Zlength ls) by cstring; subst.
    autorewrite with sublist.
    apply derives_refl'.
    unfold data_at; f_equal.
    replace (n - (Zlength ld + Zlength ls))
     with (1 + (n - (Zlength ld + Zlength ls+1))) by rep_omega.
    rewrite <- list_repeat_app' by rep_omega.
    rewrite upd_Znth_app1 by list_solve.
    rewrite app_assoc.
    simpl.
    rewrite !map_app.
    reflexivity.
 +
  forward. (* entailer!. *)
  Exists (j+1).
  destruct (zlt j (Zlength ls)); [ | cstring].
  entailer!.
  rewrite (sublist_split 0 j (j+1)) by rep_omega.
  rewrite (app_assoc ld). rewrite !map_app.
  rewrite <- (app_assoc (_ ++ _)).
  rewrite (split_data_at_app_tschar _ n) by list_solve.
  rewrite (split_data_at_app_tschar _ n) by list_solve.
  replace (n - (Zlength ld + j))
    with (1 + (n - (Zlength ld + (j + 1)))) by rep_omega.
  rewrite <- list_repeat_app' by rep_omega.
  cancel.
  rewrite upd_Znth_app1 by (autorewrite with sublist; rep_omega).
  rewrite app_Znth1 by list_solve.
  rewrite sublist_len_1 by rep_omega.
  cancel.
 }
Qed.

Lemma body_strcmp: semax_body Vprog Gprog f_strcmp strcmp_spec.
Proof.
start_function.
unfold cstring in *.
rename s1 into ls1. rename s2 into ls2.
forward.
Intros.
forward_loop (EX i : Z,
  PROP (0 <= i < Zlength ls1 + 1; 0 <= i < Zlength ls2 + 1;
        sublist 0 i ls1 = sublist 0 i ls2)
  LOCAL (temp _str1 str1; temp _str2 str2; temp _i (Vint (Int.repr i)))
  SEP (data_at sh1 (tarray tschar (Zlength ls1 + 1))
          (map Vbyte (ls1 ++ [Byte.zero])) str1;
       data_at sh2 (tarray tschar (Zlength ls2 + 1))
          (map Vbyte (ls2 ++ [Byte.zero])) str2)).
- Exists 0; entailer!.
- Intros i.
  assert (Zlength (ls1 ++ [Byte.zero]) = Zlength ls1 + 1) by (autorewrite with sublist; auto).
  forward. normalize.
  assert (Zlength (ls2 ++ [Byte.zero]) = Zlength ls2 + 1) by (autorewrite with sublist; auto).
  forward. fold_Vbyte.
  assert (Znth i (ls1 ++ [Byte.zero]) = Byte.zero <-> i = Zlength ls1) as Hs1.
  { split; [|intro; subst; rewrite app_Znth2, Zminus_diag by omega; auto].
    destruct (zlt i (Zlength ls1)); [|omega].
    intro X; lapply (Znth_In i ls1); [|omega]. cstring. }
  assert (Znth i (ls2 ++ [Byte.zero]) = Byte.zero <-> i = Zlength ls2) as Hs2.
  { split; [|intro; subst; rewrite app_Znth2, Zminus_diag by omega; auto].
    destruct (zlt i (Zlength ls2)); [|omega].
    intro X; lapply (Znth_In i ls2); [|omega]. cstring. }
  forward. normalize.
  forward. fold_Vbyte.
  forward_if (temp _t'1 (Val.of_bool (Z.eqb i (Zlength ls1) && Z.eqb i (Zlength ls2)))).
  { forward.
    simpl force_val. normalize.
    rewrite Hs1 in *.
    destruct (Byte.eq_dec (Znth i (ls2 ++ [Byte.zero])) Byte.zero).
    + rewrite e; simpl force_val.
         assert (i = Zlength ls2) by cstring.
        rewrite  (proj2 Hs1 H6).
     rewrite (proj2 (Z.eqb_eq i (Zlength ls1)) H6).
     rewrite (proj2 (Z.eqb_eq i (Zlength ls2)) H7).
     entailer!.
  +
    rewrite Int.eq_false.
     rewrite (proj2 (Z.eqb_eq i (Zlength ls1)) H6).
     rewrite Hs2 in n.
     rewrite (proj2 (Z.eqb_neq i (Zlength ls2))) by auto.
    entailer!.
     contradict n.
     apply repr_inj_signed in n; try rep_omega. normalize in n.
 }
  { forward.
    entailer!.
    destruct (i =? Zlength ls1) eqn: Heq; auto.
    rewrite Z.eqb_eq in Heq; tauto. }
  forward_if.
 +
  rewrite andb_true_iff in H6; destruct H6.
  rewrite Z.eqb_eq in H6,H7.
  forward.
  Exists (Int.repr 0).
  entailer!. simpl.
  autorewrite with sublist in H3.
  auto.
 +
  rewrite andb_false_iff in H6. rewrite !Z.eqb_neq in H6.
  forward_if.
  *
    forward. Exists (Int.repr (-1)). entailer!.
    simpl. intro; subst. omega.
 *
   forward_if.
   forward.
   Exists (Int.repr 1). entailer!. simpl. intro. subst. omega.

   assert (H17: Byte.signed (Znth i (ls1 ++ [Byte.zero])) =
     Byte.signed (Znth i (ls2 ++ [Byte.zero]))) by omega.
   normalize in H17. clear H7 H8.
   forward.
   Exists (i+1).
   entailer!.
   clear - H17 H6 Hs1 Hs2 H3 H1 H2 H H0.
   destruct (zlt i (Zlength ls1)).
  2:{
         assert (i = Zlength ls1) by omega. subst.
         destruct H6; [congruence | ].
         assert (Zlength ls1 < Zlength ls2) by omega.
         rewrite app_Znth2 in H17 by rep_omega.
         rewrite app_Znth1 in H17 by rep_omega.
         rewrite Z.sub_diag in H17. contradiction H0.
         change (Znth 0 [Byte.zero]) with Byte.zero in H17.
         rewrite H17. apply Znth_In. omega.
   }
  destruct (zlt i (Zlength ls2)).
  2:{
         assert (i = Zlength ls2) by omega. subst.
         destruct H6; [ | congruence].
         assert (Zlength ls1 > Zlength ls2) by omega.
         rewrite app_Znth1 in H17 by rep_omega.
         rewrite app_Znth2 in H17 by rep_omega.
         rewrite Z.sub_diag in H17. contradiction H.
         change (Znth 0 [Byte.zero]) with Byte.zero in H17.
         rewrite <- H17.  apply Znth_In. omega.
   }
  rewrite (sublist_split 0 i (i+1)) by omega.
  rewrite (sublist_split 0 i (i+1)) by omega.
  f_equal; auto.
  rewrite !sublist_len_1 by omega.
  autorewrite with sublist in H17.
  split. rep_omega. split. rep_omega.
  f_equal; auto. f_equal. auto.
Qed.

Lemma body_strcpy: semax_body Vprog Gprog f_strcpy strcpy_spec.
Proof.
start_function.
unfold cstring,cstringn in *.
rename s into ls.
forward.
Intros.
forward_loop (EX i : Z,
  PROP (0 <= i < Zlength ls + 1)
  LOCAL (temp _i (Vint (Int.repr i)); temp _dest dest; temp _src src)
  SEP (data_at sh (tarray tschar n)
        (map Vbyte (sublist 0 i ls) ++ list_repeat (Z.to_nat (n - i)) Vundef) dest;
       data_at sh' (tarray tschar (Zlength ls + 1)) (map Vbyte (ls ++ [Byte.zero])) src)).
*
 Exists 0. rewrite Z.sub_0_r; entailer!. simpl; entailer!.
*
 Intros i.
 assert (Zlength (ls ++ [Byte.zero]) = Zlength ls + 1) by (autorewrite with sublist; auto).
 forward. normalize.
 forward. fold_Vbyte.
 forward.
 forward_if.
+ forward.
   entailer!.
  assert (i = Zlength ls) by cstring. subst i.
  autorewrite with sublist.
  rewrite !map_app.
  rewrite <- app_assoc.
   rewrite (split_data_at_app_tschar _ n) by list_solve.
   rewrite (split_data_at_app_tschar _ n) by list_solve.
   autorewrite with sublist.
   replace (n - Zlength ls) with (1 + (n - (Zlength ls + 1))) at 2 by list_solve.
  rewrite <- list_repeat_app' by omega.
  autorewrite with sublist.
  rewrite !split_data_at_app_tschar by list_solve.
  cancel.
+
   assert (i < Zlength ls) by cstring.
  forward.
  Exists (i+1). entailer!.
  rewrite upd_Znth_app2 by list_solve.
  assert (i < Zlength ls) by cstring.
  rewrite (sublist_split 0 i (i+1)) by list_solve.
  rewrite !map_app. rewrite <- app_assoc.
  autorewrite with sublist.
  rewrite !(split_data_at_app_tschar _ n) by list_solve.
  autorewrite with sublist.
   replace (n - i) with (1 + (n-(i+ 1))) at 2 by list_solve.
  rewrite <- list_repeat_app' by omega.
  autorewrite with sublist.
  cancel.
  rewrite !split_data_at_app_tschar by list_solve.
  autorewrite with sublist.
  rewrite sublist_len_1 by omega.
  simpl. cancel.
Qed.

End Alternate.


(*

  Copyright 2014 Cornell University

  This file is part of CFGV project.

  CFGV is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  CFGV 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 General Public License
  along with CFGV.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/CFGVLFMTP2014/
  Authors: Abhishek Anand & Vincent Rahli

*)
Require Export AlphaEqProps.
Require Import Omega.
Set Implicit Arguments.

(* [lVars] is explicitly a function on [vc].
    the typechecker will then happily export
    the transport in the [pvleaf] clause of [pRenBinders]. *)
Definition lVars {G : CFGV}
  ( vc  : VarSym G) := list (vType vc).

(** renames all binding variables
    to distinct ones that are not
    in [lvAvoid] *)
Fixpoint pRenBinders {G : CFGV}
  { vc  : VarSym G}
  {gs : (GSym G)}
  (lvAvoid : lVars vc)
  (p : Pattern gs)
   {struct p} : Pattern gs  :=
match p in Pattern gs return Pattern gs with
| ptleaf tc t =>  ptleaf tc t
| pvleaf vcc var => pvleaf vcc
                    (match (DeqVarSym vc vcc) with
                    | left eqq => (vFreshVar (transport eqq lvAvoid) var)
                    | right _ => var
                    end)
| pnode p mix => pnode p (mRenBinders lvAvoid mix)
| embed p t => embed p t
end
with mRenBinders {G : CFGV}
  { vc  : VarSym G}
  {lgs : list (bool * GSym G)}
  (lvAvoid : list (vType vc))
   (pts : Mixture lgs)
   {struct pts} : Mixture lgs  :=
match pts with
| mnil => mnil
| mtcons _ _ ph ptl =>  mtcons ph (mRenBinders lvAvoid ptl)
| mpcons _ _ ph ptl => let phr := (pRenBinders lvAvoid ph) in
                       let phrb := pBndngVars vc phr in
                       mpcons phr
                              (mRenBinders (lvAvoid ++ phrb) ptl)
end.

Lemma RenBindersSpec : forall {G : CFGV} (vc  : VarSym G),
(   forall (s : GSym G) (nt : Term s), True)
*
(   forall (s : GSym G) (pt : Pattern s)  (lvAvoid : lVars vc),
    let ptr := (pRenBinders lvAvoid pt) in
    no_repeats (pBndngVars vc ptr)
    # disjoint (pBndngVars vc ptr) lvAvoid
)
*
(   forall (l : list (bool # GSym G)) (m : Mixture l)
    (lvAvoid : lVars vc),
    let mr := (mRenBinders lvAvoid m) in
    no_repeats (mBndngVars vc mr)
    # disjoint (mBndngVars vc mr) lvAvoid
).
Proof.
 intros. GInduction; cpx;[|].
- Case "pvleaf".  allsimpl. intros.
  dands; rewrite DeqSym; ddeq; subst;
  allsimpl; try constructor; cpx.
  repeat (disjoint_reasoning).
  apply vFreshVarSpec.

- Case "mpcons".
  introns Hyp.
  allsimpl. intros.
  specialize (Hyp0 (lvAvoid ++ (pBndngVars vc (pRenBinders lvAvoid ph)))).
  specialize (Hyp lvAvoid ).
  allrw no_repeats_app.
  repnd; dands;cpx; repeat (disjoint_reasoning); cpx.
Qed.

Lemma RenBindersSpec2 : forall {G : CFGV} (vc  : VarSym G),
(   forall (s : GSym G) (nt : Term s), True)
*
(   forall (s : GSym G) (pt : Pattern s)  (lvAvoid : lVars vc),
    pAlreadyBndBinders vc pt
      = pAlreadyBndBinders vc (pRenBinders lvAvoid pt)
)
*
(   forall (l : list (bool # GSym G)) (m : Mixture l)
    (lvAvoid : lVars vc),
    mAlreadyBndBinders vc m
      = mAlreadyBndBinders vc (mRenBinders lvAvoid m)
).
Proof.
  intros; GInduction; allsimpl; cpx;[|]; intros; f_equal; cpx.
Qed.

Lemma RenBindersSpec3 : forall {G : CFGV} (vc  : VarSym G),
(   forall (s : GSym G) (nt : Term s), True)
*
(   forall (s : GSym G) (pt : Pattern s)  (lvAvoid : lVars vc),
    pAllButBinders vc pt
      = pAllButBinders vc (pRenBinders lvAvoid pt)
)
*
(   forall (l : list (bool # GSym G)) (m : Mixture l)
    (lvAvoid : lVars vc),
    mAllButBinders vc m
      = mAllButBinders vc (mRenBinders lvAvoid m)
).
Proof.
  intros; GInduction; allsimpl; cpx;
      [|]; intros; f_equal; cpx.
Qed.

(*
Fixpoint mSwapTermEmbed
       {G  : CFGV}
       {vc : VarSym G}
       {lgs : list (bool * GSym G)}
       (pts : Mixture lgs)
       (sw : list (Swapping vc))
       {struct pts}
     : Mixture lgs  :=
match pts with
| mnil => mnil
| mtcons _ _ th ttl =>
    mtcons (tSwap th (lhead sw))
           (mSwapTermEmbed ttl (tail sw))
| mpcons _ _ ph ptl =>
    mpcons (pSwapEmbed ph  (lhead sw))
           (mSwapTermEmbed ptl  (tail sw))
end.
*)

Fixpoint mLSwapTermEmbed
       {G  : CFGV}
       {vc : VarSym G}
       {lgs : list (bool * GSym G)}
       (pts : Mixture lgs)
       (llbvOld llbvNew : list (lVars vc))
       {struct pts}
     : Mixture lgs  :=
match pts with
| mnil => mnil
| mtcons _ _ th ttl =>
    mtcons (tSwap th (combine (lhead llbvOld) (lhead llbvNew)))
           (mLSwapTermEmbed ttl (tail llbvOld) (tail llbvNew))
| mpcons _ _ ph ptl =>
    mpcons (pSwapEmbed ph (combine (lhead llbvOld) (lhead llbvNew)))
           (mLSwapTermEmbed ptl (tail llbvOld) (tail llbvNew))
end.

Definition nodeRenAlphaAux
   {G : CFGV} {vc : VarSym G}
   {mp : MixtureParam}
   (lln : list (list nat))
   (rmix : Mixture mp)
   (lvAvoid : list (vType vc))
  : Mixture mp :=

  if (decDisjointV vc (mBndngVars vc rmix) lvAvoid)
  then
    rmix
  else
    let llbvOld := lBoundVars vc lln rmix in
    let rmixPR := mRenBinders (lvAvoid ++ (mAllVars rmix)) rmix in
    let llbvNew := lBoundVars vc lln rmixPR in
    mLSwapTermEmbed rmixPR llbvOld llbvNew.

Fixpoint tRenAlpha {G : CFGV} {vc : VarSym G}
  {gs : (GSym G)} (pt : Term gs)
   (lvAvoid : list (vType vc))
   {struct pt} :  Term gs :=
match pt in Term gs return Term gs with
| tleaf a b => tleaf a b
| vleaf vcc var => vleaf vcc var
| tnode p mix => tnode p
      ( let rmix := mRenAlpha mix lvAvoid in
        nodeRenAlphaAux (bndngPatIndices p) rmix lvAvoid
        )
end

with pRenAlpha {G : CFGV} {vc : VarSym G}
  {gs : (GSym G)} (pt : Pattern gs)
  (lvAvoid : list (vType vc)) {struct pt} : Pattern gs  :=
match pt with
| ptleaf a v => ptleaf a v
| pvleaf vcc var => pvleaf vcc var
| pnode p lpt => pnode p (mRenAlpha lpt lvAvoid)
| embed p nt => embed p (tRenAlpha nt lvAvoid)
end

with mRenAlpha {G : CFGV} {vc : VarSym G}
  {lgs : list (bool * GSym G)} (pts : Mixture lgs)
  (lvAvoid : list (vType vc))
 {struct pts}
      : Mixture lgs  :=
match pts in Mixture lgs return Mixture lgs with
| mnil  => mnil
| mtcons _ _ th ttl =>
        mtcons (tRenAlpha th lvAvoid)
               (mRenAlpha ttl lvAvoid)
| mpcons _ _ ph ptl =>
        mpcons  (pRenAlpha ph lvAvoid)
                (mRenAlpha ptl lvAvoid)
end.

Definition AvRenaming {G : CFGV} {vc : VarSym G}
(lvA : list (vType vc)) (sw : Swapping vc)
:= no_repeats (ALRange sw)
    # disjoint (ALDom sw) (ALRange sw)
    # disjoint (ALRange sw) lvA .

Lemma AvRenamingSubset : forall
   {G : CFGV} {vc : VarSym G}
(lvl lvr : list (vType vc))
(sw : Swapping vc),
subset lvr lvl
-> AvRenaming lvl sw
-> AvRenaming lvr sw.
Proof.
  unfold AvRenaming.
  introv Hs Hav. repnd.
  dands; cpx.
  SetReasoning.
Qed.

Lemma ndRenAlAxSpecDisjAux : forall
   {G : CFGV} {vc : VarSym G}
   {mp : MixtureParam}
   (pts : Mixture mp)
  (llbvOld llbvNew : list (lVars vc))
  (lvA : list (vType vc)),
  disjoint (mAlreadyBndBinders vc pts) lvA
  -> lForall no_repeats llbvNew
  -> disjoint (flatten llbvNew) (lvA ++
          mAllButBinders vc pts ++ flatten llbvOld)
  -> map (@length _) llbvOld =  map (@length _) llbvNew
  -> length llbvOld = length mp
  -> disjoint (mAlreadyBndBinders vc pts ++ mBndngVars vc pts) lvA
  -> disjoint (mBndngVarsDeep vc (mLSwapTermEmbed pts llbvOld llbvNew))
             lvA.
Proof.
  induction pts; cpx;[|].
- introv H1a H2a H3a H4a H5a H6a.
  applydup map_eq_length_eq in H4a.
  allsimpl. dlist_len llbvOld. allsimpl.
  dlist_len llbvNew. allsimpl.
  inverts H4a.
  allrw no_repeats_app.
  repeat (disjoint_reasoning).
  + GC.
    apply tSwapBndngVarsDisjoint; cpx;
    repeat(disjoint_reasoning).
  + allsimpl. exrepnd.
    apply IHpts; cpx; repeat(disjoint_reasoning).

- introv H1a H2a H3a H4a H5a H6a.
  applydup map_eq_length_eq in H4a.
  allsimpl. dlist_len llbvOld. allsimpl.
  dlist_len llbvNew. allsimpl.
  inverts H4a.
  allrw no_repeats_app.
  repeat (disjoint_reasoning).
  + GC. apply disjoint_sym.
    apply (pcase SwapEmbedSpec); cpx;
    autorewrite with fast; try congruence;
     cpx;  repeat (disjoint_reasoning).
  + allsimpl. exrepnd.
    apply IHpts; cpx; repeat(disjoint_reasoning).
Qed.

Lemma mRenBindersSpec3 : forall
  {G : CFGV} {vc  : VarSym G}
   {mp : MixtureParam}
   (pts : Mixture mp)
   (lln : list (list nat))
   (lvAvoid : list (vType vc)),
   validBsl (length mp) lln
  ->
lForall no_repeats
  (lBoundVars vc lln (mRenBinders (lvAvoid) pts)).
Proof.
  intros.
  pose proof  ((mcase (RenBindersSpec vc)) _ pts lvAvoid)  as Hs.
  simpl in Hs.
  repnd.
  rewrite mBndngVarsAsNth in Hs0. clear Hs.
  rw (@lForallSame (list (vType vc))).
  unfold lBoundVars.
  introv Hin.
  apply in_map_iff in Hin.
  exrepnd. subst. rename a0 into ln.
  apply X in Hin1.
  repnud Hin1.
  induction ln; cpx.
  allrw no_repeats_cons.
  allsimpl. repnd.
  apply IHln in Hin2; cpx;[].
  clear IHln.
  allrw no_repeats_app.
  dands;cpx.
  - apply  no_rep_flat_map_seq1 with (n:=0) (len := length mp); sp.
    apply LInSeqIff; dands; omega.
  - intros. introv Hin Hinc.
    apply lin_flat_map in Hinc.
    exrepnd.
    destruct (deq_nat x a); subst; cpx.
    (* for diff indices, they are disjoint *)
    eapply no_rep_flat_map_seq2 in n; eauto.
    + disjoint_lin_contra.
    + rw (@lForallSame nat) in Hin1.
      apply Hin1 in Hinc1.
      apply LInSeqIff; dands; omega.
    + apply LInSeqIff; dands; omega.
Qed.

Theorem renBindersSameLength: forall
{G : CFGV} {vc : VarSym G},
(   forall (s : GSym G) (nt : Term s), True)
*
(   forall (s : GSym G) (pt : Pattern s) (lvA : lVars vc),
    length (pBndngVars vc pt)
      = length (pBndngVars  vc (pRenBinders lvA pt))
)
*
(   forall (l : list (bool # GSym G)) (m : Mixture l)
    (lvA : lVars vc)
    (nn : nat),
    length (getBVarsNth vc m nn) =
        length (getBVarsNth vc (mRenBinders lvA m) nn)
).
Proof.
  intros.
 GInduction; allsimpl; introns Hyp; intros; cpx;
[ | | | ].
  - Case "pvleaf". rewrite DeqSym.
    symmetry. rewrite DeqSym.
    ddeq; subst; sp.

  - Case "pnode".
    simpl. simpl pBndngVars.
    rewrite mBndngVarsAsNth.
    rewrite mBndngVarsAsNth.
    rewrite len_flat_map.
    rewrite len_flat_map.
    f_equal.
    apply eq_maps.
    cpx.
  - simpl. destruct nn; cpx.
  - simpl. destruct nn; cpx.
Qed.

Lemma renBindersLBVLenSame :
forall {G : CFGV} {vc : VarSym G}
(l : list (bool # GSym G)) (pts : Mixture l)
    (lvA : lVars vc)
    (lln : list (list nat)),
map (@length _) (lBoundVars vc lln pts) =
map (@length _) (lBoundVars vc lln (mRenBinders lvA pts)).
Proof.
  intros.
  apply lBoundVarsLenSameifNth.
  pose proof (@renBindersSameLength G vc).
  dands; cpx.
Qed.

Hint Resolve (fun G vc => mcase (@ bindersAllvarsSubset G vc))
 lBoundVarsmBndngVars :
  SetReasoning.

Lemma ndRenAlAxSpecDisj : forall
  {G : CFGV} {vc  : VarSym G}
   {mp : MixtureParam}
   (pts : Mixture mp)
   (lln : list (list nat))
   (lvAvoid : list (vType vc)),
   validBsl (length mp) lln
  -> length lln = length mp
  -> disjoint (mAlreadyBndBinders vc pts) lvAvoid
  -> disjoint (mBndngVarsDeep vc (nodeRenAlphaAux lln pts lvAvoid))
             lvAvoid.
Proof.
  introv Hnr Hlen Hdis.
  unfold nodeRenAlphaAux.
  cases_ifd Hdddd; cpx;
    [ apply disjointDeepShallowPlusAlready;
      repeat (disjoint_reasoning) |].
  pose proof ((mcase (RenBindersSpec vc)) _ pts (lvAvoid ++ mAllVars pts))  as Hs.
  simpl in Hs. exrepnd.
  apply ndRenAlAxSpecDisjAux;
  try rewrite <- (mcase (RenBindersSpec2 vc));
  try rewrite <- (mcase (RenBindersSpec3 vc)); cpx.
  - apply mRenBindersSpec3; cpx.
  - eapply subset_disjointLR; eauto.
    + apply lBoundVarsmBndngVars.
    + apply subset_app_lr; eauto;[].
      apply subset_app. dands;
      eauto 2 with SetReasoning.
  - apply renBindersLBVLenSame.
  - unfold lBoundVars.
    autorewrite with fast. trivial.
  - repeat (disjoint_reasoning).
Qed.

Lemma RenAlphaAvoid : forall {G : CFGV} {vc  : VarSym G},
(  (forall (s : GSym G) (ta : Term s)
  (lvA : list (vType vc)),
      disjoint (tBndngVarsDeep vc (tRenAlpha ta lvA)) lvA)
   *
  (forall (s : GSym G) (pta : Pattern s)
  (lvA : list (vType vc)),
      disjoint (pAlreadyBndBinders vc (pRenAlpha pta lvA)) lvA)

   *
  (forall (l : MixtureParam) (ma: Mixture l)
  (lvA : list (vType vc)),
      disjoint (mAlreadyBndBinders vc (mRenAlpha ma lvA)) lvA)).
Proof.
intros. GInduction; intros; cpx;
  try (allsimpl; repeat (disjoint_reasoning); cpx; fail);[].
  Case "tnode".
  allsimpl.
  specialize (H lvA).
  remember (mRenAlpha m lvA) as pts.
  apply ndRenAlAxSpecDisj; auto.
  - rewrite length_pRhsAugIsPat.
    apply bndngPatIndicesValid2; auto.

  - unfold bndngPatIndices.
    unfold tpRhsAugIsPat. unfold prhsIsBound.
    rw combine_length.
    unfold tpRhsSym. simpl.
    autorewrite with fast.
    rw min_eq; auto.
Qed.

Theorem lbShallowNoChange: forall
  {G : CFGV} {vc : VarSym G},
(   forall (s : GSym G) (nt : Term s), True)
*
(   forall (s : GSym G) (pt : Pattern s)
    (lvA : list (vType vc)),
    pBndngVars vc pt = pBndngVars  vc (pRenAlpha pt lvA)
)
*
(   forall (l : list (bool # GSym G)) (m : Mixture l)
    (lvA : list (vType vc))
    (nn : nat),
    getBVarsNth vc m nn = @getBVarsNth
                            _ vc _ (mRenAlpha m lvA) nn
).
 intros.
  GInduction; allsimpl; introns Hyp; intros; cpx;[ | | ].
  - Case "pnode". simpl. simpl pBndngVars.
    rewrite mBndngVarsAsNth.
    rewrite mBndngVarsAsNth.
    autorewrite with fast.
    apply eq_flat_maps.
    intros nn Hin. cpx.
  - simpl. destruct nn; cpx.
  - simpl. destruct nn; cpx.
Qed.

Lemma  mRenlBinderShallowSame : forall
  {G : CFGV} {vc : VarSym G}
 (l : MixtureParam) (m : Mixture l)
 (lvA : list (vType vc))
  (la : list (list nat)),
lBoundVars vc la m =  lBoundVars vc la (mRenAlpha m lvA).
Proof.
  intros. apply lBoundVarsSameifNth.
  apply (mcase lbShallowNoChange).
Qed.

Lemma  mBndngVarsShallowSame : forall
  {G : CFGV} {vc : VarSym G}
 (l : MixtureParam) (m : Mixture l)
 (lvA : list (vType vc)),
  mBndngVars vc m =  mBndngVars vc (mRenAlpha m lvA).
Proof.
  intros. apply mBndngVarsSameIfNth.
  apply (mcase lbShallowNoChange).
Qed.

Lemma mLSwapTermEmbedSameBinders : forall
   {G : CFGV} {vc : VarSym G}
   {mp : MixtureParam}
   (m : Mixture mp)
   (lla llb : list (list (vType vc))),
(mBndngVars vc (mLSwapTermEmbed m lla llb))
  = mBndngVars vc m.
Proof.
  induction m; cpx;[].
  simpl. intros.
  f_equal; cpx;[].
  symmetry.
  apply (pcase SwapEmbedSameBinders).
Qed.

Lemma mLSwapTermEmbedSameNthBinder : forall
   {G : CFGV} {vc : VarSym G}
   {mp : MixtureParam}
   (m : Mixture mp)
   (lla llb : list (list (vType vc)))
   (nn : nat),
    getBVarsNth vc m nn = getBVarsNth
                             vc (mLSwapTermEmbed m lla llb) nn.
Proof.
  induction m; cpx; intros ; destruct nn; allsimpl; cpx.
  apply (pcase SwapEmbedSameBinders).
Qed.

Lemma pRenBindersAlpha : forall {G : CFGV} {vc : VarSym G},
(  (forall (s : GSym G) (ta : Term s), True)
   *
  (forall (s : GSym G) (pta : Pattern s)
  (lvA : list (vType vc)),
      pAlphaEq vc pta (pRenBinders lvA pta))
   *
  (forall (mp : MixtureParam) (ma: Mixture mp)
  (llbv : list (list (vType vc)))
  (lvA : list (vType vc)),
  (forall b s, LIn (b,s) mp -> b= true)
  -> let maR := mRenBinders lvA ma in
    lAlphaEqAbs (MakeAbstractions vc ma llbv)
                (MakeAbstractions vc maR llbv))).
Proof.
intros.
GInduction; cpx; allsimpl;
  try (econstructor; eauto with Alpha; fail).
- Case "pnode". introns Hyp.
  allsimpl. constructor.
  unfold MakeAbstractionsPNode.
  apply Hyp.
  introv Hin.
  apply in_map_iff in Hin; exrepnd; cpx.
Qed.

Lemma mLSwapTermEmbedSameLBV : forall
   {G : CFGV} {vc : VarSym G}
   {mp : MixtureParam}
   (m : Mixture mp)
   (lla llb : list (list (vType vc)))
   (lln : list (list nat)),
    lBoundVars vc lln m = lBoundVars
                             vc  lln (mLSwapTermEmbed m lla llb).
Proof.
  intros.
  apply lBoundVarsSameifNth.
  apply mLSwapTermEmbedSameNthBinder.
Qed.

Definition swapEmbedAbs {G : CFGV} {vc : VarSym G}
           (a : Abstraction G vc)
           (sw : Swapping vc)
    : (Abstraction G vc):=
match a with
| termAbs _ lbv t =>  termAbs _ lbv t
| patAbs _ lbv t => patAbs _ lbv (pSwapEmbed t sw)
end.

Definition swapEmbedLAbs {G : CFGV} {vc : VarSym G}
           (la : list (Abstraction G vc))
           (sw : Swapping vc)
    : list (Abstraction G vc):=
map (fun x => swapEmbedAbs x sw) la.

Lemma MakeLAbsSwapCommute:
forall {G : CFGV} {vc : VarSym G} (mp : MixtureParam)
  (sw : Swapping vc) (m : Mixture mp)
  (lbv : list (lVars vc)),
swapEmbedLAbs (MakeAbstractions vc m lbv) sw =
MakeAbstractions vc (mSwapEmbed m sw) lbv.
Proof.
  unfold swapEmbedLAbs.
  intros G vc np sw m.
  induction m;  intros; allsimpl; cpx; f_equal; cpx;
   destruct lbv; allsimpl; cpx.
Qed.

Lemma ndRenAlAxAlpha : forall
   {G : CFGV} {vc : VarSym G}
   {mp : MixtureParam}
   (m : Mixture mp)
   (lln : list (list nat))
   (lvA : list (vType vc)),
   validBsl (length mp) lln
  ->
lAlphaEqAbs (MakeAbstractionsTNodeAux vc lln m)
  (MakeAbstractionsTNodeAux vc lln (nodeRenAlphaAux lln m lvA)).
Proof.
  unfold MakeAbstractionsTNodeAux.
  introv Hv.
  unfold nodeRenAlphaAux.
  cases_ifd Hdddd; cpx; eauto with Alpha;[]; clear Hddddf.
  rewrite <- mLSwapTermEmbedSameLBV.
  pose proof (renBindersLBVLenSame m (lvA ++ mAllVars m) lln) as Hlen.
  pose proof (@mRenBindersSpec3 G vc
      mp m lln (lvA ++ mAllVars m)) as Hnr.
  apply Hnr in Hv.
  clear Hnr.
  pose proof
    ((mcase (RenBindersSpec vc)) _
      m (lvA ++ mAllVars m))  as Hd.
  simpl in Hd.
  repnd. clear Hd0.
  assert (
      disjoint
        (flatten (lBoundVars vc lln
          (mRenBinders (lvA ++ mAllVars m) m)))
       (lvA ++ (flatten (lBoundVars vc lln m)))
    ) as Hld by
    (apply (subset_disjointLR Hd); auto;
    [ eauto with SetReasoning |
    apply subset_app_lr; eauto 2 with SetReasoning]).

  assert (
      disjoint
        (flatten (lBoundVars vc lln
          (mRenBinders (lvA ++ mAllVars m) m)))
       (lvA ++ (mAllVars m))
    ) as Had by
    (apply (subset_disjointLR Hd); eauto with SetReasoning).

    clear Hd.
  repeat disjoint_reasoning.
  clear Had0 Hld0.
  remember (lBoundVars vc lln m) as lbva.
  remember (lBoundVars vc lln
    (mRenBinders (lvA ++ mAllVars m) m)) as lbvb.
  applydup map_eq_length_eq in Hlen.
  clear Heqlbvb.
  clear Heqlbva.
  remember (lvA ++ mAllVars m) as lv.
  clear Heqlv.
  revert lv.
  generalize dependent lbvb.
  generalize dependent lbva.
  clear lln lvA.
  induction m as [ | ? ? ph ptl Hind| ? ? ph ptl Hind]; cpx.
- allsimpl. intros. constructor; cpx.
  + destruct lbva as [|la lvba]; allsimpl;
    destruct lbvb as [|lb lbvv];
    inverts Hlen0;
    autorewrite with fast; simpl;
    [apply AlphaEqNilAbsT; eauto with Alpha; fail|].
    pose proof (GFreshDistRenWSpec vc la
                (tAllVars ph++
                (tAllVars (tSwap ph (combine la lb)))
                    ++ la ++lb)) as Hfr.
    exrepnd.
    allsimpl. inverts Hlen.
    apply alAbT with (lbnew:=lvn); try congruence;
    repeat (disjoint_reasoning);
    [unfolds_base; simpl; dands; cpx;
    autorewrite with fast;
    repeat(disjoint_reasoning); fail |].

    rewrite (tcase swap_app).
    autorewrite with slow; try congruence;
    cpx; repeat (disjoint_reasoning);
    eauto with Alpha.

  + apply Hind; destruct lbva; destruct lbvb;
    allsimpl; repeat (disjoint_reasoning);
    inverts Hlen0; inverts Hlen; cpx.

- allsimpl. intros. constructor; cpx.
  + eapply alphaEqTransitive.
    instantiate (1 :=
    (patAbs vc (lhead lbvb)
       (pSwap ph
        (combine (lhead lbva) (lhead lbvb))))
   ).

   *  destruct lbva as [|la lvba]; allsimpl;
      destruct lbvb as [|lb lbvv];
      inverts Hlen0;
      autorewrite with fast; simpl;
      [apply AlphaEqNilAbsP; eauto with Alpha; fail|].
      pose proof (GFreshDistRenWSpec vc la
                  (pAllVars ph++
                  (pAllVars (pSwap ph (combine la lb)))
                      ++ la ++lb)) as Hfr.
      exrepnd.
      allsimpl. inverts Hlen.
      apply alAbP with (lbnew:=lvn); try congruence;
      repeat (disjoint_reasoning);
      [unfolds_base; simpl; dands; cpx;
      autorewrite with fast;
      repeat(disjoint_reasoning) |].

      rewrite (pcase swap_app).
      autorewrite with slow; try congruence;
      cpx; repeat (disjoint_reasoning);
      eauto with Alpha.

   * apply AlphaEqNilAbsP.
     apply alphaEqSym.
  eapply alphaEqTransitive.
    instantiate (1 :=
        (pSwap (pRenBinders lv ph)
            (combine (lhead lbva) (lhead lbvb)))
   ).
     apply  (pcase (@pAlphaSwapEmSwap G vc)).
     apply alphaEqSym.
     apply alphaEquiVariant.
     apply pRenBindersAlpha.
  + apply Hind; destruct lbva; destruct lbvb;
    allsimpl; repeat (disjoint_reasoning);
    inverts Hlen0; inverts Hlen; cpx.
Qed.

Lemma RenAlphaAlpha : forall {G : CFGV} {vc : VarSym G},
(  (forall (s : GSym G) (ta : Term s)
  (lvA : list (vType vc)),
      tAlphaEq vc ta (tRenAlpha ta lvA))
   *
  (forall (s : GSym G) (pta : Pattern s)
  (lvA : list (vType vc)),
      pAlphaEq vc pta (pRenAlpha pta lvA))
   *
  (forall (l : MixtureParam) (ma: Mixture l)
  (llbv : list (list (vType vc)))
  (lvA : list (vType vc)),
  let maR := mRenAlpha ma lvA in
    lAlphaEqAbs (MakeAbstractions vc ma llbv)
                (MakeAbstractions vc maR llbv))).
Proof.
intros. GInduction; intros; cpx;
  try (econstructor; eauto; fail);[| |].

- Case "tnode".
  allsimpl.
  constructor.
  unfold MakeAbstractionsTNode.
  unfold nodeRenAlphaAux.

  eapply (alphaEqTransitive);
  [ |apply ndRenAlAxAlpha with (lvA0 := lvA); eauto].
  unfold MakeAbstractionsTNodeAux.
  rw <- (@mRenlBinderShallowSame G vc).
  apply X; cpx.
  unfold tpRhsAugIsPat. unfold prhsIsBound.
  rw combine_length.
  unfold tpRhsSym.
  autorewrite with fast.
  rw min_eq; auto.
  apply bndngPatIndicesValid2; auto.
- Case "mtcons".
  subst maR.
  allunfold MakeAbstractionsTNodeAux.
  simpl. constructor; cpx.
  apply AlphaEqNilAbsT; cpx.

- Case "mpcons".
  subst maR.
  allunfold MakeAbstractionsTNodeAux.
  simpl. constructor; cpx.
  apply AlphaEqNilAbsP; cpx.

Qed.

Ltac addRenSpec :=
match goal with
[ |- context [@tRenAlpha ?G ?vc ?gs ?a ?lv] ]
  =>  let Hala := fresh "Hal" a in
      let Hdis := fresh "Hdis" a in
      pose proof ((tcase (@RenAlphaAlpha G vc))
              gs a lv) as Hala;
      pose proof ((tcase (@RenAlphaAvoid G vc))
              gs a lv) as Hdisa
end.

Lemma RenAlphaNoChange : forall {G : CFGV} {vc : VarSym G},
(  (forall (s : GSym G) (ta : Term s)
  (lvA : list (vType vc)),
    disjoint (tBndngVarsDeep vc ta) lvA
      -> ta = (tRenAlpha ta lvA))
   *
  (forall (s : GSym G) (pta : Pattern s)
  (lvA : list (vType vc)),
    disjoint (pBndngVarsDeep vc pta) lvA
      -> pta = (pRenAlpha pta lvA))
   *
  (forall (l : MixtureParam) (ma: Mixture l)
  (lvA : list (vType vc)),
    disjoint (mBndngVarsDeep vc ma) lvA
    -> ma = mRenAlpha ma lvA)).
Proof.
  intros.
  GInduction; introns Hyp; allsimpl;
  try (f_equal; cpx; fail);[ | | ].

- Case "tnode". f_equal.
  unfolds_base.
  cases_ifd Hdd; cpx.
  rewrite <- mBndngVarsShallowSame in Hddf.
  provefalse. apply Hddf.
  SetReasoning.

- Case "mtcons". allsimpl. repeat (disjoint_reasoning).
  f_equal; cpx.

- Case "mpcons". allsimpl. repeat (disjoint_reasoning).
  f_equal; cpx.
Qed.

Lemma tRenWithSpec :
  forall  {G : CFGV} {vc : VarSym G}
     (s : GSym G) (ta : Term s)
     (lvA : list (vType vc)),
  {tar : Term s $ tAlphaEq vc ta tar #
          disjoint (tBndngVarsDeep vc tar) lvA}.
Proof.
  intros.
  exists (tRenAlpha ta lvA).
  pose proof (@RenAlphaAlpha G vc).
  pose proof (@RenAlphaAvoid G vc).
  repnd.
  dands; cpx.
Qed.

(* only comments below *)

(*
Lemma AllVarsEquivariant :
  forall {G : CFGV} {vc : VarSym G}
  (sw : Swapping vc),
    (forall (gs : GSym G) (t : Term gs), True)
    *
    (forall (gs : GSym G),
    EquiVariantFn (@pSwap _ vc gs)
                  (@pSwap _ vc gs)
                  (fun t => pSwapEmbed t sw))
    *
    (forall (lgs : list (bool * GSym G)),
     EquiVariantFn (@mSwap _ vc lgs)
                (@mSwap _ vc lgs)
                (fun t => mSwapEmbed t sw)).
Proof.
  intros.
  GInduction; auto; introns Hyp; intros; allsimpl ; auto.

- Case "pembed". f_equal.

simpl. rewrite DeqSym. symmetry. rewrite DeqSym.
  destruct_head_match; try subst;  cpx.

- simpl. rewrite DeqSym. symmetry. rewrite DeqSym.
  destruct_head_match; try subst;  cpx.

- unfold swapLVar. rw map_app.
  unfold swapLVar in Hyp0.
  unfold swapLVar in Hyp.
  f_equal; cpx.

- unfold swapLVar. rw map_app.
  unfold swapLVar in Hyp0.
  unfold swapLVar in Hyp.
  f_equal; cpx.
Qed.
*)

(*
Lemma swapDisjChain : forall  {G : CFGV} {vc : VarSym G}
  (vsa vs vsb : lVars vc),
    length vs = length vsa
    -> length vs = length vsb
    -> no_repeats vs
    -> no_repeats vsb
    ->
  ((forall (gs : GSym G) (t : Term gs), True)
  *
  (forall (gs : GSym G) (t : Pattern gs),
       disjoint vs (vsa ++ vsb ++ (pAllVars t))
       -> disjoint vsb (vsa ++ pAllVars t)
       -> (pSwap (pSwapEmbed t (combine vsa vs)) (combine vs vsb))
            = pSwap t (combine vsa vsb))

    *
  (forall (lgs : MixtureParam) (m : Mixture lgs) ,
       disjoint vs (vsa ++ vsb ++ (mAllVars m))
       -> disjoint vsb (vsa ++ mAllVars m)
       -> (mSwap (mSwapEmbed m (combine vsa vs)) (combine vs vsb))
            = mSwap m (combine vsa vsb))).
Proof.
  introv Hlena Hlenb Hnr Hnrb.
  apply GInduction; auto; introns Hdis; allsimpl.

  - Case "vleaf". simpl. f_equal. rewrite DeqSym. symmetry.  rewrite DeqSym.
    destruct_head_match; cpx.
    subst.
    allsimpl. symmetry.
    rewrite swapVarNoChange; allsimpl;
    repeat(disjoint_reasoning); cpx.
    allrewrite (@DeqTrue (VarSym G)); allsimpl;
    repeat(disjoint_reasoning).

  - Case "pnode".
    rw Hdis; simpl; auto.

  - Case "pvleaf". simpl. f_equal. rewrite DeqSym. symmetry.  rewrite DeqSym.
    destruct_head_match; cpx.
    subst.
    simpl. symmetry. apply swapVarDisjChain; auto;
    repeat(disjoint_reasoning); allsimpl;
    allrewrite (@DeqTrue (VarSym G)); allsimpl;
    repeat(disjoint_reasoning).

  - rw Hdis; simpl; auto.
  - rw Hdis; simpl; auto.
  - f_equal.
    + apply Hdis; repeat(disjoint_reasoning).
    + apply Hdis0; repeat(disjoint_reasoning).

  - f_equal.
    + apply Hdis; repeat(disjoint_reasoning).
    + apply Hdis0; repeat(disjoint_reasoning).
Qed.
*)

(*
Lemma alphaSwapEmbedCongr : forall {G : CFGV} {vc : VarSym G},
(
  (forall (s : GSym G) (a b : Term s), tAlphaEq vc a b -> True)
   *
  (forall (s : GSym G),
      EquiVariantRelSame (@pSwapEmbed G vc s) (pAlphaEq vc))
  *
  (EquiVariantRelSame (@swapEmbedAbs G vc) (@AlphaEqAbs G vc))
  *
  (EquiVariantRelSame (@swapEmbedLAbs G vc) (@lAlphaEqAbs G vc))
).
Proof.
  intros. GAlphaInd; introns Hyp; intros;
  allsimpl; try (econstructor; eauto with Alpha; fail);[ | |].
- Case "pembed". constructor.
  apply alphaEquiVariant; eauto.
- Case "pnode". constructor.
  unfold MakeAbstractionsPNode.
  rewrite <-  MakeLAbsSwapCommute.
  rewrite <-  MakeLAbsSwapCommute.
  cpx.

- Case "patAbs".
  specialize (Hyp4 sw).
Qed.
*)


Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Strings.String.

Require Import FFI.
Require Import CakeSem.Namespace.
Require Import CakeSem.CakeAST.
Require Import CakeSem.SemanticsAux.
Require Import CakeSem.Evaluate.

Require Import NoBasis.

Definition init_env : sem_env val := empty_sem_env.
Definition init_store := empty_store val.

Parameter A : Type.
Parameter init_ffi_st : ffi_state A.
Definition init_state := Build_state 0 init_store init_ffi_st 0 0.

Definition noBasisProg := evaluate_decs 100 init_state init_env [ dec_def_0
                                                                ; dec_def_1
                                                                ; dec_def_2
                                                                ; dec_def_3
                                                                ; dec_def_4
                                                                ; dec_def_5
                                                                ; dec_def_6
                                                                ; dec_def_7
                                                                ; dec_def_8
                                                                ; dec_def_9
                                                                ; dec_def_10
                                                                ].

Definition noBasisProg' := evaluate_decs 19 init_state init_env [ dec_def_0
                                                                ; dec_def_1
                                                                ; dec_def_2
                                                                ; dec_def_3
                                                                ; dec_def_4
                                                                ; dec_def_5
                                                                ; dec_def_6
                                                                ; dec_def_7
                                                                ; dec_def_8
                                                                ; dec_def_9
                                                                ].
Eval cbv in noBasisProg.

Definition my_env :=   {|
         sev := [(Short "answer",
                 Conv (Some (TypeStamp "S" 0))
                   [Conv (Some (TypeStamp "S" 0))
                      [Conv (Some (TypeStamp "S" 0))
                         [Conv (Some (TypeStamp "S" 0)) [Conv (Some (TypeStamp "S" 0)) [Conv (Some (TypeStamp "O" 0)) []]]]]]);
                (Short "three",
                Conv (Some (TypeStamp "S" 0))
                  [Conv (Some (TypeStamp "S" 0)) [Conv (Some (TypeStamp "S" 0)) [Conv (Some (TypeStamp "O" 0)) []]]]);
                (Short "two",
                Conv (Some (TypeStamp "S" 0)) [Conv (Some (TypeStamp "S" 0)) [Conv (Some (TypeStamp "O" 0)) []]]);
                (Short "abs_minus",
                Recclosure
                  {|
                  sev := [(Short "minus",
                          Recclosure
                            {|
                            sev := [];
                            sec := [(Short "SubtrahendLargerThanMinuend", (0, ExnStamp 0));
                                   (Short "S", (1, TypeStamp "S" 0)); (Short "O", (0, TypeStamp "O" 0))] |}
                            [("minus", "x",
                             EFun "y"
                               (ELannot
                                  (EMat (ELannot (EVar (Short "y")) [0])
                                     [(Pcon (Some (Short "O")) [], ELannot (EVar (Short "x")) [0]);
                                     (Pcon (Some (Short "S")) [Pvar "yp"],
                                     ELannot
                                       (EMat (ELannot (EVar (Short "x")) [0])
                                          [(Pcon (Some (Short "O")) [],
                                           ELannot
                                             (ERaise (ELannot (ECon (Some (Short "SubtrahendLargerThanMinuend")) []) [0]))
                                             [0]);
                                          (Pcon (Some (Short "S")) [Pvar "xp"],
                                          ELannot
                                            (EApp Opapp
                                               [ELannot
                                                  (EApp Opapp
                                                     [ELannot (EVar (Short "minus")) [0]; ELannot (EVar (Short "xp")) [0]])
                                                  [0]; ELannot (EVar (Short "yp")) [0]]) [0])]) [0])]) [0]))] "minus");
                         (Short "minus",
                         Recclosure
                           {|
                           sev := [];
                           sec := [(Short "SubtrahendLargerThanMinuend", (0, ExnStamp 0));
                                  (Short "S", (1, TypeStamp "S" 0)); (Short "O", (0, TypeStamp "O" 0))] |}
                           [("minus", "x",
                            EFun "y"
                              (ELannot
                                 (EMat (ELannot (EVar (Short "y")) [0])
                                    [(Pcon (Some (Short "O")) [], ELannot (EVar (Short "x")) [0]);
                                    (Pcon (Some (Short "S")) [Pvar "yp"],
                                    ELannot
                                      (EMat (ELannot (EVar (Short "x")) [0])
                                         [(Pcon (Some (Short "O")) [],
                                          ELannot
                                            (ERaise (ELannot (ECon (Some (Short "SubtrahendLargerThanMinuend")) []) [0]))
                                            [0]);
                                         (Pcon (Some (Short "S")) [Pvar "xp"],
                                         ELannot
                                           (EApp Opapp
                                              [ELannot
                                                 (EApp Opapp
                                                    [ELannot (EVar (Short "minus")) [0]; ELannot (EVar (Short "xp")) [0]])
                                                 [0]; ELannot (EVar (Short "yp")) [0]]) [0])]) [0])]) [0]))] "minus")];
                  sec := [(Short "SubtrahendLargerThanMinuend", (0, ExnStamp 0)); (Short "S", (1, TypeStamp "S" 0));
                         (Short "O", (0, TypeStamp "O" 0))] |}
                  [("abs_minus", "x",
                   EFun "y"
                     (ELannot
                        (EHandle
                           (ELannot
                              (EApp Opapp
                                 [ELannot (EApp Opapp [ELannot (EVar (Short "minus")) [0]; ELannot (EVar (Short "x")) [0]])
                                    [0]; ELannot (EVar (Short "y")) [0]]) [0])
                           [(Pcon (Some (Short "SubtrahendLargerThanMinuend")) [],
                            ELannot
                              (EApp Opapp
                                 [ELannot (EApp Opapp [ELannot (EVar (Short "minus")) [0]; ELannot (EVar (Short "y")) [0]])
                                    [0]; ELannot (EVar (Short "x")) [0]]) [0])]) [0]))] "abs_minus");
                (Short "minus",
                Recclosure
                  {|
                  sev := [];
                  sec := [(Short "SubtrahendLargerThanMinuend", (0, ExnStamp 0)); (Short "S", (1, TypeStamp "S" 0));
                         (Short "O", (0, TypeStamp "O" 0))] |}
                  [("minus", "x",
                   EFun "y"
                     (ELannot
                        (EMat (ELannot (EVar (Short "y")) [0])
                           [(Pcon (Some (Short "O")) [], ELannot (EVar (Short "x")) [0]);
                           (Pcon (Some (Short "S")) [Pvar "yp"],
                           ELannot
                             (EMat (ELannot (EVar (Short "x")) [0])
                                [(Pcon (Some (Short "O")) [],
                                 ELannot (ERaise (ELannot (ECon (Some (Short "SubtrahendLargerThanMinuend")) []) [0])) [0]);
                                (Pcon (Some (Short "S")) [Pvar "xp"],
                                ELannot
                                  (EApp Opapp
                                     [ELannot
                                        (EApp Opapp [ELannot (EVar (Short "minus")) [0]; ELannot (EVar (Short "xp")) [0]])
                                        [0]; ELannot (EVar (Short "yp")) [0]]) [0])]) [0])]) [0]))] "minus");
                (Short "mult",
                Recclosure
                  {|
                  sev := [(Short "plus",
                          Recclosure
                            {| sev := []; sec := [(Short "S", (1, TypeStamp "S" 0)); (Short "O", (0, TypeStamp "O" 0))] |}
                            [("plus", "x",
                             EFun "y"
                               (ELannot
                                  (EMat (ELannot (EVar (Short "x")) [0])
                                     [(Pcon (Some (Short "O")) [], ELannot (EVar (Short "y")) [0]);
                                     (Pcon (Some (Short "S")) [Pvar "xp"],
                                     ELannot
                                       (ECon (Some (Short "S"))
                                          [EApp Opapp
                                             [ELannot
                                                (EApp Opapp
                                                   [ELannot (EVar (Short "plus")) [0]; ELannot (EVar (Short "xp")) [0]]) [0];
                                             ELannot (EVar (Short "y")) [0]]]) [0])]) [0]))] "plus")];
                  sec := [(Short "S", (1, TypeStamp "S" 0)); (Short "O", (0, TypeStamp "O" 0))] |}
                  [("mult", "x",
                   EFun "y"
                     (ELannot
                        (EMat (ELannot (EVar (Short "x")) [0])
                           [(Pcon (Some (Short "O")) [], ELannot (ECon (Some (Short "O")) []) [0]);
                           (Pcon (Some (Short "S")) [Pvar "xp"],
                           ELannot
                             (ELet (Some "z")
                                (ELannot
                                   (EApp Opapp
                                      [ELannot
                                         (EApp Opapp [ELannot (EVar (Short "mult")) [0]; ELannot (EVar (Short "xp")) [0]])
                                         [0]; ELannot (EVar (Short "y")) [0]]) [0])
                                (ELannot
                                   (EApp Opapp
                                      [ELannot
                                         (EApp Opapp [ELannot (EVar (Short "plus")) [0]; ELannot (EVar (Short "y")) [0]])
                                         [0]; ELannot (EVar (Short "z")) [0]]) [0])) [0])]) [0]))] "mult");
                (Short "plus2",
                Recclosure
                  {|
                  sev := [(Short "succ",
                          Closure
                            {| sev := []; sec := [(Short "S", (1, TypeStamp "S" 0)); (Short "O", (0, TypeStamp "O" 0))] |}
                            "x" (ELannot (ECon (Some (Short "S")) [EVar (Short "x")]) [0]));
                         (Short "plus",
                         Recclosure
                           {| sev := []; sec := [(Short "S", (1, TypeStamp "S" 0)); (Short "O", (0, TypeStamp "O" 0))] |}
                           [("plus", "x",
                            EFun "y"
                              (ELannot
                                 (EMat (ELannot (EVar (Short "x")) [0])
                                    [(Pcon (Some (Short "O")) [], ELannot (EVar (Short "y")) [0]);
                                    (Pcon (Some (Short "S")) [Pvar "xp"],
                                    ELannot
                                      (ECon (Some (Short "S"))
                                         [EApp Opapp
                                            [ELannot
                                               (EApp Opapp
                                                  [ELannot (EVar (Short "plus")) [0]; ELannot (EVar (Short "xp")) [0]]) [0];
                                            ELannot (EVar (Short "y")) [0]]]) [0])]) [0]))] "plus")];
                  sec := [(Short "S", (1, TypeStamp "S" 0)); (Short "O", (0, TypeStamp "O" 0))] |}
                  [("plus2", "x",
                   EFun "y"
                     (ELannot
                        (EMat (ELannot (EVar (Short "x")) [0])
                           [(Pcon (Some (Short "O")) [], ELannot (EVar (Short "y")) [0]);
                           (Pcon (Some (Short "S")) [Pvar "xp"],
                           ELannot
                             (EApp Opapp
                                [ELannot (EVar (Short "succ")) [0];
                                ELannot
                                  (EApp Opapp
                                     [ELannot
                                        (EApp Opapp [ELannot (EVar (Short "plus")) [0]; ELannot (EVar (Short "xp")) [0]])
                                        [0]; ELannot (EVar (Short "y")) [0]]) [0]]) [0])]) [0]))] "plus2");
                (Short "plus",
                Recclosure {| sev := []; sec := [(Short "S", (1, TypeStamp "S" 0)); (Short "O", (0, TypeStamp "O" 0))] |}
                  [("plus", "x",
                   EFun "y"
                     (ELannot
                        (EMat (ELannot (EVar (Short "x")) [0])
                           [(Pcon (Some (Short "O")) [], ELannot (EVar (Short "y")) [0]);
                           (Pcon (Some (Short "S")) [Pvar "xp"],
                           ELannot
                             (ECon (Some (Short "S"))
                                [EApp Opapp
                                   [ELannot
                                      (EApp Opapp [ELannot (EVar (Short "plus")) [0]; ELannot (EVar (Short "xp")) [0]]) [0];
                                   ELannot (EVar (Short "y")) [0]]]) [0])]) [0]))] "plus");
                (Short "succ",
                Closure {| sev := []; sec := [(Short "S", (1, TypeStamp "S" 0)); (Short "O", (0, TypeStamp "O" 0))] |} "x"
                  (ELannot (ECon (Some (Short "S")) [EVar (Short "x")]) [0]))];
         sec := [(Short "SubtrahendLargerThanMinuend", (0, ExnStamp 0)); (Short "S", (1, TypeStamp "S" 0));
                (Short "O", (0, TypeStamp "O" 0))] |}.

Definition my_st := {| clock := 0; refs := []; ffi := init_ffi_st; next_type_stamp := 1; next_exn_stamp := 1 |}.

Inductive nat_rel_cake_nat (typestamp : nat) : nat -> val -> Prop :=
| zero_rel : nat_rel_cake_nat typestamp 0 (Conv (Some (TypeStamp "O" typestamp)) [])
| suc_rel  : forall (n : nat) (prev : val), nat_rel_cake_nat typestamp n prev -> nat_rel_cake_nat typestamp (S n) (Conv (Some (TypeStamp "S" typestamp)) [prev]).

Theorem plus_vs_cake_plus : forall (m n t : nat) (m_exp n_exp : exp) (m_val n_val m_n_val : val),
    (exists (mf : nat), evaluate_opt my_st my_env [m_exp] mf = (my_st, Rval [m_val])) ->
    (exists (nf : nat), evaluate_opt my_st my_env [n_exp] nf = (my_st, Rval [n_val])) ->
    nat_rel_cake_nat t m m_val ->
    nat_rel_cake_nat t n n_val ->
    (exists (mnf : nat), evaluate_opt my_st my_env [(EApp (Opapp) ((EApp (Opapp) ((EVar (Short ("plus"%string)))::m_exp::nil))::n_exp::nil))] mnf =
    (my_st, Rval [m_n_val])) ->
    nat_rel_cake_nat t (m+n) m_n_val.
Proof.
  intros m n t m_exp n_exp m_val n_val m_n_val.
Abort.


Set Implicit Arguments.

Require Import util.
Require Import Le.
Require Import Plus.
Require Import Minus.
Require Import Lt.
Require Import Arith.
Require Import Recdef.
Require Import Bool_nat.
Require Import List.
Require Import monads.
Require Import Relation_Definitions.
Require Import monoid_monad_trans.
Require Import expec.
Require Import monoid_expec.
Require Import nat_seqs.
Require Import list_utils.
Require Import sums_and_averages.
Require qs_definitions.
Require qs_parts.
Require U.
Require Import sort_order.
Require Import indices.
Require Import qs_sound_cmps.
Require Import Fourier.
Require Import Rbase.
Require Import skip_list.
Require Import nat_below.
Require Vector.

Import qs_definitions.mon_nondet.

Section contents.

  Variables (ee: E) (ol: list ee) (i j: Index ee ol).

  Variable n: nat.
  Variable v: Vector.t (Index ee ol) (S n).
  Variable iltj: (i < j)%nat.

  Let flt x0 cr := filter (fun f: Index ee ol => unsum_bool (cmp_cmp (Ecmp (UE ee ol) f (vec.nth v x0)) cr)) (vec.remove v x0).

  Variable IH: forall (x0: natBelow (S n)) (cr: comparison) (b: nat),
    IndexSeq b (flt x0 cr) ->
    monoid_expec (U.ijcount i j) (qs (U.cmp (e:=ee) (ol:=ol)) U.pick (flt x0 cr)) <= 2 / INR (S (j - i)).

  Variables (b: nat) (is: IndexSeq b v).

  Lemma ndi: NoDup v.
    apply IndexSeq_NoDup with b.
    assumption.
  Qed.

  Variable iin: In i v.
  Variable jin: In j v.
  Variable pi: natBelow (S n).

  Lemma not_In_flt (k: Index ee ol) (dr: comparison) (H0: dr <> Ecmp (UE ee ol) k (vec.nth v pi)):
    ~ In k (flt pi dr).
  Proof with auto.
    unfold flt.
    intros.
    intro.
    destruct (proj1_conj (filter_In _ _ _) H). clear H.
    simpl in H0.
    simpl in H2.
    destruct (Ecmp ee (subscript k) (subscript (vec.nth v pi))); destruct dr; auto; simpl in H2; try discriminate...
  Qed.

  Lemma ndi_flt: forall x0 cr, NoDup (flt x0 cr).
  Proof.
    unfold flt.
    intros.
    apply NoDup_filter.
    apply (NoDup_SkipList ndi).
    cset (vec.SkipList_remove x0 v).
    assumption.
  Qed.

  Hint Immediate ndi_flt.

  Lemma partition_0: nb_val (vec.nth v pi) <> i -> nb_val (vec.nth v pi) <> j ->
    U.ijcount i j (map (fun i0: Index ee ol => U.unordered_nat_pair i0 (vec.nth v pi)) (vec.remove v pi)) = 0%nat.
  Proof.
    intros.
    apply (U.ijcount_0).
    intro.
    destruct (In_map_inv H1). clear H1.
    destruct H2.
    unfold U.unordered_nat_pair in H1.
    destruct (le_lt_dec x (vec.nth v pi)); inversion H1; auto.
  Qed.

  Hint Immediate U.hom_ijcount.
  Hint Immediate vec.remove_perm.

  Lemma pivot_not_In_flt cr: ~ In (vec.nth v pi) (flt pi cr).
  Proof with auto.
    intros H.
    pose proof ndi as H0.
    rewrite (Permutation.Permutation_sym (vec.List_Permutation (vec.remove_perm pi v))) in H0.
    inversion_clear H0...
    destruct (In_filter_inv _ _ _ H)...
  Qed.

  Lemma NoDup_comparisons (x: Index ee ol) (l: list (Index ee ol)):
    NoDup (x :: l) -> NoDup (map (fun i: Index ee ol => U.unordered_nat_pair i x) l).
  Proof with auto.
    intros.
    inversion_clear H.
    apply NoDup_map'...
    intros.
    unfold U.unordered_nat_pair.
    intro.
    apply H3.
    unfold Index in *.
    apply natBelow_unique.
    destruct (le_lt_dec x0 x); destruct (le_lt_dec y x); inversion H4; reflexivity.
  Qed.

  Lemma case_A: (vec.nth v pi < i)%nat ->
    INR (U.ijcount i j (map (fun i0: Index ee ol => U.unordered_nat_pair i0 (vec.nth v pi)) (vec.remove v pi))) +
    monoid_expec (U.ijcount i j)
      (foo <- @U.qs ee ol (flt pi Lt);
      bar <- @U.qs ee ol (flt pi Gt);
      ret  (foo ++ (vec.nth v pi :: flt pi Eq) ++ bar))
    <= 2 * / INR (S (j - i)).
  Proof with auto with real.
    intros.
    rewrite partition_0...
      Focus 2.
      intro.
      rewrite H0 in H.
      apply (lt_asym _ _ H iltj).
    rewrite Rplus_0_l.
    rewrite monoid_expec_plus... Focus 2. intros. repeat rewrite monoid_expec_plus...
    rewrite monoid_expec_plus...
    rewrite monoid_expec_ret...
    rewrite Rplus_0_r.
    rewrite sound_cmp_expec_0...
      Focus 2.
      left.
      apply not_In_flt...
      intro.
      apply (lt_asym _ _ H).
      symmetry in H0.
      apply (IndicesCorrect _ _ H0).
    rewrite Rplus_0_l.
    case_eq (Ecmp ee (subscript i) (subscript (vec.nth v pi))); intro.
        (* i in the Eq part *)
        unfold Rdiv.
        rewrite sound_cmp_expec_0...
        left.
        apply not_In_flt...
        simpl.
        simpl in H0.
        rewrite H0. intro. discriminate.
      (* in the Lt part, impossible *)
      elimtype False.
      apply (lt_irrefl i).
      apply lt_trans with (vec.nth v pi)...
      apply (IndicesCorrect i (vec.nth v pi))...
    (* i in the Gt part. recursive sorting of upper part: *)
    assert (IndexSeq b (vec.nth v pi :: vec.remove v pi)).
      apply IndexSeq_perm with v...
      cset (vec.List_Permutation (vec.remove_perm pi v))...
    apply (IH _ Gt (@InvIndexSeq_filterGt' ee ol (vec.nth v pi) (vec.remove v pi) b H1))...
  Qed.

  Lemma case_E: (j < vec.nth v pi)%nat ->
    INR (U.ijcount i j (map (fun i0: Index ee ol => U.unordered_nat_pair i0 (vec.nth v pi)) (vec.remove v pi))) +
    monoid_expec (U.ijcount i j)
      (foo <- @U.qs ee ol (flt pi Lt);
      bar <- @U.qs ee ol (flt pi Gt);
      ret (foo ++ (vec.nth v pi :: flt pi Eq) ++ bar))
    <= 2 * / INR (S (j - i)).
  Proof with auto with real.
    intros.
    rewrite partition_0...
      Focus 2.
      intro.
      cset (natBelow_unique _ _ H0).
      subst i.
      apply (lt_asym _ _ H iltj).
    rewrite Rplus_0_l.
    rewrite monoid_expec_plus...
      rewrite monoid_expec_plus...
      rewrite monoid_expec_ret...
      rewrite Rplus_0_r.
      rewrite (@sound_cmp_expec_0 ee ol i j (flt pi Gt))...
        Focus 2.
        right.
        apply not_In_flt.
        intro.
        apply (lt_asym _ _ H).
        cset (Ecmp_sym ee (subscript (vec.nth v pi)) (subscript j)).
        simpl in H0.
        simpl in H1.
        rewrite <- H0 in H1.
        simpl in H1.
        apply (IndicesCorrect _ _ H1).
      rewrite Rplus_0_r.
      case_eq (Ecmp ee (subscript j) (subscript (vec.nth v pi))); intro.
          (* j in the Eq part *)
          unfold Rdiv.
          rewrite sound_cmp_expec_0...
          right.
          apply not_In_flt...
          simpl.
          simpl in H0. simpl.
          rewrite H0. intro. discriminate.
        Focus 2.
        (* in the Gt part, impossible *)
        elimtype False.
        cset (Ecmp_sym ee (subscript (vec.nth v pi)) (subscript j)).
        rewrite H0 in H1.
        simpl in H1.
        apply (lt_asym _ _ H).
        apply (IndicesCorrect _ _ H1)...
      (* in the Lt part *)
      apply IH with b...
      unfold flt.
      assert (length (vec.nth v pi :: vec.remove v pi) = S n).
        simpl @length. rewrite vec.length...
      assert (IndexSeq b (vec.nth v pi :: vec.remove v pi)).
        apply IndexSeq_perm with v...
        apply (vec.List_Permutation (vec.remove_perm pi v)).
      cset (@IndexSeq_filterLt ee ol (vec.nth v pi) (S n) b (vec.nth v pi :: vec.remove v pi) H1 H2).
      simpl filter in H3.
      rewrite Ecmp_refl in H3...
    intros.
    repeat rewrite monoid_expec_plus...
  Qed.

  Lemma case_C: (i < vec.nth v pi)%nat -> (vec.nth v pi < j)%nat ->
    INR (U.ijcount i j (map (fun i0: Index ee ol => U.unordered_nat_pair i0 (vec.nth v pi)) (vec.remove v pi))) +
    monoid_expec (U.ijcount i j)
      (foo <- @U.qs ee ol (flt pi Lt);
      bar <- @U.qs ee ol (flt pi Gt);
      ret (foo ++ (vec.nth v pi :: flt pi Eq) ++ bar))
    = 0.
  Proof with auto with real.
  intros.
    rewrite partition_0...
    rewrite Rplus_0_l.
    unfold U.M.
    rewrite monoid_expec_bind_0_r...
      apply sound_cmp_expec_0...
      right.
      apply not_In_flt.
      intro.
      apply (lt_asym _ _ H0).
      symmetry in H1.
      apply (IndicesCorrect _ _ H1).
    intros.
    rewrite monoid_expec_plus...
    rewrite (monoid_expec_ret (U.hom_ijcount i j)).
    rewrite Rplus_0_r.
    apply sound_cmp_expec_0...
    left.
    apply not_In_flt.
    intro.
    cset (Ecmp_sym ee (subscript (vec.nth v pi)) (subscript i)).
    simpl in H1. simpl in H2.
    rewrite <- H1 in H2.
    simpl in H2.
    apply (lt_asym _ _ H).
    apply (IndicesCorrect _ _ H2).
  Qed.

  Lemma case_BD: (i = vec.nth v pi \/ j = vec.nth v pi) ->
    INR (U.ijcount i j (map (fun i0: Index ee ol => U.unordered_nat_pair i0 (vec.nth v pi)) (vec.remove v pi))) +
    monoid_expec (U.ijcount i j)
      (foo <- @U.qs ee ol (flt pi Lt);
      bar <- @U.qs ee ol (flt pi Gt);
      ret (foo ++ (vec.nth v pi :: flt pi Eq) ++ bar))
    <= 1.
  Proof with auto with real.
    intros.
    rewrite (monoid_expec_bind_0_r (U.hom_ijcount i j)).
      rewrite sound_cmp_expec_0...
        rewrite Rplus_0_r.
        rewrite U.ijcount_eq_count.
        replace 1 with (INR 1)...
        apply le_INR.
        apply eq_count_NoDup.
        apply NoDup_comparisons.
        rewrite (vec.List_Permutation (vec.remove_perm pi v)).
        apply IndexSeq_NoDup with b...
      destruct H; subst; [left | right]; apply pivot_not_In_flt.
    intros.
    unfold U.M.
    rewrite monoid_expec_plus...
    rewrite (monoid_expec_ret (U.hom_ijcount i j)).
    rewrite sound_cmp_expec_0...
    destruct H; subst; [left | right]; apply pivot_not_In_flt.
  Qed.

End contents.


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 P Q A B C Dprime Pprime Cprime Dprimeprime Pprimeprime Z Zprime T : Universe, ((wd_ P Q /\ (wd_ T Z /\ (wd_ T Zprime /\ (wd_ T Pprimeprime /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ Zprime Z /\ (wd_ B T /\ (wd_ Cprime Pprimeprime /\ (wd_ B Pprime /\ (wd_ B Cprime /\ (wd_ Dprimeprime Cprime /\ (wd_ Dprime B /\ (wd_ Zprime B /\ (wd_ Z B /\ (wd_ B Pprimeprime /\ (wd_ B Dprimeprime /\ (wd_ Cprime C /\ (wd_ A Dprime /\ (wd_ Pprime Cprime /\ (col_ A B Zprime /\ (col_ Z B T /\ (col_ B Pprimeprime T /\ (col_ Zprime T Z /\ (col_ B C Z /\ (col_ Cprime Dprimeprime Pprimeprime /\ (col_ B Cprime A /\ col_ B Dprime Pprime)))))))))))))))))))))))))))) -> col_ A B C)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* Cyclone Semantics using TLC/LN in Coq Version 4 *)
(* "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".   Daniel Grossman, August 2003 *)
(* Brian Milnes 2016 *)
(* Lemmas for get. *)

Set Implicit Arguments.
Require Import TLC.LibEnv LibVarPathEnv Cyclone_LN_Tactics Cyclone_Fset_Lemmas.
Require Import Cyclone_Admit_Environment.
Close Scope list_scope.
Import LibEnvNotations.
Import LVPE.LibVarPathEnvNotations.

Ltac get_empty:=
  match goal with
  | H: get _ empty = Some _ |- _ =>
    rewrite get_empty in H; inversion H
  end.

Ltac lvpe_get_empty:=
  match goal with
  | H: LVPE.V.get _ empty = Some _ |- _ =>
    rewrite LVPE.get_empty in H; inversion H
end.

Ltac simpl_get ::=
  (* idtac "simpl_get";*)
  trace_goal;
  timeout 2
  repeat
    match goal with
  | |- context [get ?a empty]           => trace_goal; rewrite~ get_empty
  | |- context [get ?a empty]           => trace_goal; rewrite~ get_empty
  | |- context [get ?a empty]           => trace_goal; rewrite~ get_empty
  | |- context [get ?a (_ & (_ ~ _)) ]      => trace_goal;
    rewrite~ get_push; try repeat case_var~

  | |- context [get ?a ((?b ~ _) & _)] => trace_goal;
    rewrite~ get_concat; try repeat case_var~

  | |- context [get ?a _ = None] => trace_goal;
   apply* get_none

  | H: context[get _ empty = Some _] |- _ =>
    rewrite get_empty in H; inversion H
end.

Lemma get_fv_delta:
  forall v d k,
    get v d = Some k ->
    \{v} \c fv_delta d.
Proof.
  intros.
  unfold fv_delta.
  induction d using env_ind.
  rewrite get_empty in H.
  inversion H.
  rewrite get_push in H.
  case_var.
  inversion H.
  subst.
  rewrite dom_push.
  fset.
  apply IHd in H.
  rewrite dom_push.
  apply* subset_weakening.
Qed.
Ltac get_fv_delta :=
  match goal with
  | H: get ?v ?d = Some ?k' |- \{?v} \c fv_delta ?d =>
    apply get_fv_delta with (k:= k'); assumption; auto with fset
end.
Hint Extern 1 (\{_} \c fv_delta _) => get_fv_delta.
Hint Extern 1 (T.fv _ \c fv_delta _) => simpl; get_fv_delta.

Lemma get_dom:
  forall A alpha (d : env A)  k,
    get alpha d = Some k ->
    \{alpha} \c dom d.
Proof.
  intros.
  induction d using env_ind.
  rewrite get_empty in H.
  inversion H.
  destruct (classicT(alpha = x)).
  subst.
  rewrite dom_push.
  fset.
  rewrite get_push in H.
  rewrite* If_r in H.
  apply IHd in H.
  rewrite dom_push.
  apply* subset_weakening.
Qed.
Ltac get_dom :=
  match goal with
  | H: get ?a ?d = Some ?k'
  |- \{?a} \c dom ?d =>
    apply get_dom with (k:= k')
  end.
Hint Extern 1 (\{_} \c dom _) => get_dom.

(* Arthur's binds theorems redone in get. *)

Section GetProperties.
Variable A B' : Type.
Implicit Types E F : env A.
Implicit Types x : var.
Implicit Types v : A.

(** Constructor forms *)

Lemma get_empty_inv : forall x v,
  get x empty = Some v -> False.
Proof using.
  introv H. rewrite get_empty in H. false.
Qed.

Lemma get_single_eq : forall x v,
  get x (x ~ v) = Some v.
Proof using.
  intros.  rewrite get_single. case_if~.
Qed.

Lemma get_single_inv : forall x1 x2 v1 v2,
  get x1 (x2 ~ v2) = Some v1 ->
  x1 = x2 /\ v1 = v2.
Proof using.
   introv H. rewrite get_single in H.
  case_if; inversions~ H.
Qed.

Lemma get_push_inv : forall x1 v1 x2 v2 E,
  get x1 (E & x2 ~ v2) = Some v1 ->
     (x1 = x2 /\ v1 = v2)
  \/ (x1 <> x2 /\ get x1 E = Some v1).
Proof using.
  introv H.  rewrite get_push in H. case_if.
  inverts~ H. auto.
Qed.

Lemma get_push_eq : forall x v E,
  get x (E & x ~ v) = Some v.
Proof using. intros.  rewrite get_push. case_if~. Qed.

Lemma get_push_eq_inv : forall x v1 v2 E,
  get x (E & x ~ v2) = Some v1 -> v1 = v2.
Proof using.
  introv H. forwards [|]: get_push_inv H. autos*. intros [? _]. false.
Qed.

Lemma get_push_neq_inv : forall x1 x2 v1 v2 E,
  get x1 (E & x2 ~ v2) = Some v1 -> x1 <> x2 -> get x1 E = Some v1.
Proof using.
  introv H. forwards [|]: get_push_inv H.
  intros [? ?] ?. false. autos*.
Qed.

Lemma get_tail : forall x v E,
  get x (E & x ~ v) = Some v.
Proof using. intros. rewrite get_push. cases_if~. Qed.

Lemma get_push_neq : forall x1 x2 v1 v2 E,
  get x1 E = Some v1 -> x1 <> x2 -> get x1 (E & x2 ~ v2) = Some v1.
Proof using.
  introv H N.  rewrite get_push. case_if~.
Qed.

Lemma get_concat_inv : forall x v E1 E2,
  get x (E1 & E2) = Some v ->
     (get x E2 = Some v)
  \/ (x # E2 /\ get x E1 = Some v).
Proof using.
  introv H. induction E2 using env_ind.
  rewrite~ concat_empty_r in H.
  rewrite concat_assoc in H.
   forwards [[? ?]|[? M]]: get_push_inv H.
     subst. left. apply get_tail.
     forwards [?|[? ?]]: IHE2 M.
       left. applys~ get_push_neq.
       right.
       auto.
Qed.

(* Typing env vs list issues.
Lemma get_map : forall x v (f : A -> B) E,
  get x E = Some v -> get x (map f E) = Some (f v).
Proof using.
  introv H.  rew_env_defs.
  induction E as [|[x' v'] E']; simpls.
  false.
  cases_if~. inverts~ H.
Qed.
*)

Lemma get_func : forall x v1 v2 E,
  get x E = Some v1 -> get x E = Some v2 -> v1 = v2.
Proof using.
  introv H1 H2.
  induction E as [|E' x' v'] using env_ind.
  rewrite get_empty in H1. false.
  rewrite get_push in H1,H2. case_if~.
   inverts H1. inverts~ H2.
Qed.

Lemma get_fresh_inv : forall x v E,
  get x E = Some v -> x # E -> False.
Proof using.
  introv H F.
  induction E as [|E' x' v'] using env_ind.
  rewrite get_empty in H. false.
  rewrite get_push in H. case_if~. subst.
   simpl_dom; notin_false.
Qed.

(** Derived forms *)

Lemma get_single_eq_inv : forall x v1 v2,
  get x (x ~ v2) = Some v1 ->
  v1 = v2.
Proof using.
  introv H. rewrite get_single in H.
  case_if. inverts~ H.
Qed.

Lemma get_concat_left : forall x v E1 E2,
  get x E1 = Some v ->
  x # E2 ->
  get x (E1 & E2) = Some v.
Proof using.
  introv H F. induction E2 using env_ind.
  rewrite~ concat_empty_r.
  rewrite concat_assoc.
  applys~ get_push_neq.
  subst.
  simpl_dom.
  apply notin_union in F.
  inversion F.
  apply notin_singleton_r in H0; auto.
Qed.

Lemma get_concat_left_ok : forall x v E1 E2,
  ok (E1 & E2) ->
  get x E1 = Some v ->
  get x (E1 & E2) = Some v.
Proof using.
  introv O H. induction E2 using env_ind.
  rewrite~ concat_empty_r.
  rewrite concat_assoc in O|-*. lets [_ ?]: ok_push_inv O.
  applys~ get_push_neq. subst.
  intro_subst.
  applys~ get_fresh_inv H.
Qed.

Lemma get_concat_left_inv : forall x v E1 E2,
  get x (E1 & E2) = Some v ->
  x # E2 ->
  get x E1 = Some v.
Proof using.
  introv H F. lets~ [M|[? ?]]: get_concat_inv H.
    false. applys~ get_fresh_inv M.
Qed.

Lemma get_concat_right : forall x v E1 E2,
  get x E2 = Some v ->
  get x (E1 & E2) = Some v.
Proof using.
  introv H. induction E2 using env_ind.
  false. apply get_empty_inv with (x:=x) (v:=v); auto.
  rewrite concat_assoc. lets [[? ?]|[? ?]]: get_push_inv H.
    subst. applys get_tail.
    applys* get_push_neq.
Qed.

Lemma get_concat_right_inv : forall x v E1 E2,
  get x (E1 & E2) = Some v ->
  x # E1 ->
  get x E2 = Some v.
Proof using.
  introv H F. lets~ [?|[? M]]: get_concat_inv H.
    false. applys~ get_fresh_inv M.
Qed.

Lemma get_middle_eq : forall x E1 E2 v,
  x # E2 ->
  get x (E1 & x ~ v & E2) = Some v.
Proof using.
  introv F. applys~ get_concat_left.
Qed.

(** Metatheory proof forms *)

(** Interaction between binds and the insertion of bindings.
  In theory we don't need this lemma since it would suffice
  to use the get_cases tactics, but since weakening is a
  very common operation we provide a lemma for it. *)

Lemma get_weaken : forall x a E F G,
  get x (E & G) = Some a -> ok (E & F & G) ->
  get x (E & F & G) = Some a.
Proof using.
  introv H O. lets [?|[? ?]]: get_concat_inv H.
    applys~ get_concat_right.
    applys~ get_concat_left. applys~ get_concat_left_ok.
Qed.

Lemma get_remove : forall E2 E1 E3 x v,
  get x (E1 & E2 & E3) = Some v ->
  x # E2 ->
  get x (E1 & E3) = Some v.
Proof using.
  introv H F. lets [?|[? M]]: get_concat_inv H.
    applys~ get_concat_right.
    forwards: get_concat_left_inv M; auto.
    applys~ get_concat_left.
Qed.

Lemma get_subst : forall x2 v2 x1 v1 E1 E2,
  get x1 (E1 & x2 ~ v2 & E2) = Some v1 ->
  x1 <> x2 ->
  get x1 (E1 & E2) = Some v1.
Proof using.
  introv H N.
  applys~ get_remove H.
Qed.

Lemma get_middle_eq_inv : forall x E1 E2 v1 v2,
  get x (E1 & x ~ v2 & E2) = Some v1 ->
  ok (E1 & x ~ v2 & E2) ->
  v1 = v2.
Proof using.
  introv H O. lets [? ?]: ok_middle_inv O.
  forwards~ M: get_concat_left_inv H.
  applys~ get_push_eq_inv M.
Qed.

Lemma get_middle_inv : forall x1 v1 x2 v2 E1 E2,
  get x1 (E1 & x2 ~ v2 & E2) = Some v1 ->
     (get x1 E2 = Some v1)
  \/ (x1 # E2 /\ x1 = x2 /\ v1 = v2)
  \/ (x1 # E2 /\ x1 <> x2 /\ get x1 E1 = Some v1).
Proof using.
  introv H. lets [?|[? M]]: (get_concat_inv H).
    left~.
    right. lets [N|[? N]]: (get_concat_inv M).
      lets [? ?]: (get_single_inv N). subst~.
      right. simpl_dom. split~.
Qed.

Lemma get_not_middle_inv : forall x v E1 E2 E3,
  get x (E1 & E2 & E3) = Some v ->
  x # E2 ->
     (get x E3 = Some v)
  \/ (x # E3 /\ get x E1 = Some v).
Proof using.
  introv H F. lets [?|[? M]]: (get_concat_inv H).
    left~.
    right. forwards~ N: (get_concat_left_inv M).
Qed.

Lemma fv_in_values_get : forall y fv x v E,
  get x E = Some v -> y \notin fv_in_values fv E -> y \notin fv v.
Proof using.
  unfold fv_in_values. introv H.
  induction E using env_ind; introv M.
  false. apply get_empty_inv with (x:= x) (v:= v); auto.
  rewrite values_def in M,IHE.
  rewrite concat_def, single_def in M. rew_list in M. simpl in M.
  lets [[? ?]|[? ?]]: (get_push_inv H); subst~.
Qed.

End GetProperties.

Lemma ok_contradict:
  forall A (d : env A) alpha0 k' k,
  ok (d & alpha0 ~ k') ->
  get alpha0 d  = Some k ->
  False.
Proof.
  introv okd getd.
  induction d using env_ind.
  rewrite get_empty in getd.
  inversion getd.
  destruct(classicT(x = alpha0)); subst.
  apply ok_push_inv  in okd.
  inversion okd.
  unfolds in H0.
  unfolds in H0.
  rewrite dom_push in H0.
  contradict H0.
  rewrite in_union.
  left.
  apply in_singleton_self.
  applys IHd; auto.
  rewrite get_push in getd.
  auto.
Qed.

Lemma get_strength:
  forall A alpha (d : env A) k,
    get alpha d = Some k ->
    forall alpha0 k',
      ok (d & alpha0 ~ k') ->
      get alpha (d & alpha0 ~ k') = Some k.
Proof.
  intros.
  inversion H0.
  apply empty_push_inv in H2.
  inversion H2.
  rewrite get_push.
  case_var*.
  apply eq_inversion_env in H1.
  inversions H1.
  inversions H5.
  apply ok_contradict with (k:= k) in H0; auto.
  inversion H0.
  apply eq_inversion_env in H1.
  inversions* H1.
Qed.
Ltac get_strength:=
  match goal with
  | H: get ?alpha ?d = Some ?k |-
    get ?alpha (?d & _ ~ _) = Some ?k
    => apply* get_strength
end.
Hint Extern 2 (get _ (_ & _ ~ _) = Some _) => try get_strength.

Lemma get_middle_strength:
  forall A alpha0 (d : env A) alpha k d' k',
    alpha0 <> alpha ->
    get alpha0 (d & alpha ~ k & d') = Some k' ->
    get alpha0 (d & d') = Some k'.
Admitted.

Lemma get_middle_k:
  forall A (d : env A) alpha k d',
    ok (d & alpha ~ k & d') ->
    forall k',
      get alpha (d & alpha ~ k & d') = Some k' ->
      k = k'.
Admitted.


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
Require Export memory_separation expression_eval.

Lemma expr_eval_subseteq `{EnvSpec K} Γ Δ ρ m1 m2 e ν τlr :
  ✓ Γ → ✓{Γ,Δ} m1 → ✓{Δ}* ρ → (Γ,Δ,ρ.*2) ⊢ e : τlr →
  ⟦ e ⟧ Γ ρ m1 = Some ν → m1 ⊆ m2 → ⟦ e ⟧ Γ ρ m2 = Some ν.
Proof.
  intros. eapply expr_eval_weaken; eauto using cmap_subseteq_index_alive,
    mem_lookup_subseteq, mem_forced_subseteq.
Qed.


From Coq Require Import Strings.String Logic.FunctionalExtensionality.
From Rupicola.Lib Require Import Core.

Set Implicit Arguments.

Class Monad (M: Type -> Type) :=
  { mret {A} : A -> M A;
    mbind {A B} : M A -> (A -> M B) -> M B;
    mbindn {A B} (vars: list string) (ma: M A) (kA: A -> M B) : M B :=
      mbind ma kA;

    mbind_mret {A} (ma: M A) : mbind ma mret = ma;
    mret_mbind {A B} a (k: A -> M B) : mbind (mret a) k = k a;
    mbind_mbind {A B C} ma (ka: A -> M B) (kb: B -> M C) :
      mbind (mbind ma ka) kb = mbind ma (fun a => mbind (ka a) kb);

    mbindn_mret {A} vars (ma: M A) : mbindn vars ma mret = ma :=
      mbind_mret _;
    mret_mbindn {A B} vars a (k: A -> M B) : mbindn vars (mret a) k = nlet vars a k :=
      mret_mbind _ _;
    mbindn_mbindn {A B C} varsa varsb ma (ka: A -> M B) (kb: B -> M C) :
      mbindn varsb (mbindn varsa ma ka) kb = mbindn varsa ma (fun a => mbindn varsb (ka a) kb) :=
      mbind_mbind _ _ _;
  }.

Arguments mret : simpl never.
Arguments mbind : simpl never.
Arguments mbindn : simpl never.

Module Free.
  Section Free.
    Context {F: Type -> Type}.

    Inductive M (A: Type) : Type :=
    | Pure (a: A) : M A
    | Impure X (f: F X) (k: X -> M A) : M A.

    Definition Call {A} (f: F A) := Impure f (@Pure _).

    Definition ret {A} (a: A) : M A := Pure a.

    Fixpoint bind {A B} (f: M A) (kA: A -> M B) : M B :=
      match f with
      | Pure a => kA a
      | Impure f kX => Impure f (fun x => bind (kX x) kA)
      end.

    Ltac s :=
      simpl; eauto using f_equal, FunctionalExtensionality.functional_extensionality.

    Global Program Instance MonadM : Monad M :=
      {| mret := @ret;
         mbind := @bind |}.
    Obligation 1. Proof. induction ma; s. Qed.
    Obligation 3. Proof. induction ma; s. Qed.

    Context {M': Type -> Type} {MM': Monad M'}.
    Context (interpF: forall {A}, F A -> M' A).

    Fixpoint interp {A: Type} (f: M A) : M' A :=
      match f with
      | Pure a => mret a
      | Impure f k => mbind (@interpF _ f) (fun x => interp (k x))
      end.

    Lemma interp_mbind {A B} (ma: M A) (k: A -> M B) :
      mbind (M := M') (interp ma) (fun a => interp (k a)) =
      interp (mbind (M := M) ma k).
    Proof.
      induction ma; simpl; intros.
      all: repeat rewrite ?mret_mbind, ?mbind_mret, ?mbind_mbind; s.
    Qed.

    Lemma interp_mbindn {A B} vars (ma: M A) (k: A -> M B) :
      mbindn vars (M := M') (interp ma) (fun a => interp (k a)) =
      interp (mbindn vars (M := M) ma k).
    Proof. apply interp_mbind. Qed.
  End Free.
End Free.

#[export] Hint Extern 2 (IsRupicolaBinding (mbindn (A := ?A) ?vars _ _)) => exact (RupicolaBinding A vars) : typeclass_instances.

#[global]
Hint Rewrite @mbindn_mbindn @mret_mbindn : compiler_cleanup.


Require Import VST.floyd.proofauto.
Require Import VST.progs.nest2.

#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope logic.

Definition t_struct_b := Tstruct _b noattr.

Definition get_spec :=
 DECLARE _get
  WITH v : reptype' t_struct_b, gv: globals
  PRE  []
        PROP ()
        PARAMS() GLOBALS (gv)
        SEP(data_at Ews t_struct_b (repinj _ v) (gv _p))
  POST [ tint ]
         PROP()
         RETURN (Vint (snd (snd v)))
         SEP (data_at Ews t_struct_b (repinj _ v) (gv _p)).

Definition get_spec' :=
 DECLARE _get
  WITH v : (int * (float * int))%type, gv: globals
  PRE  []
        PROP ()
        PARAMS() GLOBALS (gv)
        SEP(data_at Ews t_struct_b (repinj t_struct_b v) (gv _p))
  POST [ tint ]
         PROP()
         RETURN (Vint (snd (snd v)))
         SEP (data_at Ews t_struct_b (repinj t_struct_b v) (gv _p)).

Definition update22 (i: int) (v: reptype' t_struct_b) : reptype' t_struct_b :=
   (fst v, (fst (snd v), i)).

Definition set_spec :=
 DECLARE _set
  WITH i : int, v : reptype' t_struct_b, gv: globals
  PRE  [ tint ]
         PROP  ()
         PARAMS (Vint i) GLOBALS (gv)
         SEP   (data_at Ews t_struct_b (repinj _ v) (gv _p))
  POST [ tvoid ]
         PROP() RETURN()
        SEP(data_at Ews t_struct_b (repinj _ (update22 i v)) (gv _p)).

Definition Gprog : funspecs :=   ltac:(with_library prog [get_spec; set_spec]).

Lemma body_get:  semax_body Vprog Gprog f_get get_spec.
Proof.
start_function.
simpl in v.
unfold_repinj.
Time forward. (* 5.989 sec  -> 2.6 -> 1.5 *)
Time forward. (* 11.1118 sec -> 7.5 *)
Time Qed.

Lemma body_get':  semax_body Vprog Gprog f_get get_spec'.
Proof.
start_function.
simpl in v.
unfold_repinj.
Time forward. (* 5.989 sec  -> 2.6*)
Time forward. (* 11.1118 sec -> 7.5 *)
Qed.

Lemma body_set:  semax_body Vprog Gprog f_set set_spec.
Proof.
 start_function.
simpl in v.
(*destruct v as [a [b c]]; simpl in *. *)
unfold_repinj.
Time forward. (* 1.23 sec *)
entailer!!.
Time Qed.  (*  28 sec -> 3.45 sec *)