Require Import VST.floyd.proofauto.
Import ListNotations.
Local Open Scope logic.

Require Import sha.general_lemmas.
Require Import sha.spec_sha.
Require Import sha.hmac_common_lemmas.
Require Import sha.spec_hmac.

Require Import sha.hkdf.
Require Import sha.spec_hkdf.
Require Import sha.hkdf_functional_prog.

Definition Done (i:Z): int := Int.repr (digest_len*i).
Definition OUTpred PrkCont InfoCont sh z r cont p: mpred:=
  data_at sh (tarray tuchar z) (sublist 0 z (map Vint (map Int.repr (HKDF_expand PrkCont InfoCont cont)))) p *
  memory_block sh r (offset_val z p).

Definition PREVcont PRK INFO (i: Z): reptype (Tarray tuchar 32 noattr) :=
     if zeq i 0 then list_repeat 32 Vundef
     else (map Vint (map Int.repr (Ti (CONT PRK) (CONT INFO) (Z.to_nat i)))).

Lemma PREV_len PRK INFO i: 0 <= i -> Zlength (PREVcont PRK INFO i) = 32.
Proof. intros. unfold PREVcont.
destruct (zeq i 0). rewrite Zlength_list_repeat'; reflexivity.
assert (exists n, Z.to_nat i = S n).
{ specialize (Z2Nat_inj_0 i). intros.
  destruct (Z.to_nat i). omega. eexists; reflexivity. }
destruct H0; rewrite H0.
unfold Ti; simpl. repeat rewrite Zlength_map. apply HMAC_Zlength.
Qed.

Lemma PREV_isbyteZ PRK INFO i: 0 < i -> exists l, PREVcont PRK INFO i = map Vint (map Int.repr l) /\
                                                  Forall general_lemmas.isbyteZ l.
Proof. intros. unfold PREVcont.
destruct (zeq i 0). omega. eexists; split. reflexivity.
assert (exists n, Z.to_nat i = S n).
{ specialize (Z2Nat_inj_0 i). intros.
  destruct (Z.to_nat i). omega. eexists; reflexivity. }
destruct H0; rewrite H0.
unfold Ti; simpl. apply isbyte_hmac.
Qed.

Lemma PREVcont_Sn PRK INFO i p: 0 <= i -> PREVcont PRK INFO i = map Vint (map Int.repr p) ->
      Forall general_lemmas.isbyteZ p ->
      PREVcont PRK INFO (i+1) = if zeq i 0 then map Vint (map Int.repr (HMAC256_functional_prog.HMAC256 (CONT INFO ++ [1]) (CONT PRK)))
                                else map Vint (map Int.repr (HMAC256_functional_prog.HMAC256 (p ++ CONT INFO ++ [i + 1]) (CONT PRK))).
Proof. intros. unfold PREVcont.
destruct (zeq (i+1) 0). omega.
change (i+1) with (Zsucc i). rewrite Z2Nat.inj_succ; try omega. simpl.
unfold PREVcont in H0.
destruct (zeq i 0).
+ subst i. simpl; trivial.
+ apply map_Vint_injective in H0. apply map_IntReprOfBytes_injective in H0; trivial.
  rewrite H0, Zpos_P_of_succ_nat, Z2Nat.id; trivial.
  apply isbyteZ_Ti.
Qed.

Lemma PREV_listZ PRK INFO i: 0 < i -> exists l, PREVcont PRK INFO i = map Vint (map Int.repr l).
Proof. intros. unfold PREVcont.
destruct (zeq i 0). omega. eexists; reflexivity.
Qed.

Lemma sublist_HKDF_expand4 PRK INFO i rest l (REST : 0 <= rest < 32)
      (g : 255 >= i + 1) (OLEN : 32 * i + rest + 32 <= Int.max_unsigned)
      (Hl : if zeq i 0 then l = [] else PREVcont PRK INFO i = map Vint (map Int.repr l) /\ Forall general_lemmas.isbyteZ l)
      (Hi: 0 <= i):
sublist 0 rest
  (HMAC256_functional_prog.HMAC256 ((l ++ CONT INFO) ++ [Int.unsigned (Int.zero_ext 8 (Int.repr (i + 1)))]) (CONT PRK)) =
sublist (32 * i) (32 * i + rest) (HKDF_expand (CONT PRK) (CONT INFO) (32 * (i + 1))).
Proof.
  unfold PREVcont in Hl. destruct (zeq i 0).
  + subst i l; simpl. rewrite Z.add_0_l. unfold HKDF_expand; simpl.
    rewrite sublist_sublist; try omega. rewrite 2 Z.add_0_r.
    rewrite zero_ext_inrange; try rewrite Int.unsigned_repr;
        try rewrite int_max_unsigned_eq; try omega; trivial.
  + destruct Hl as [Hl isBl].
    apply map_Vint_injective in Hl.
    apply map_IntReprOfBytes_injective in Hl; trivial.
    2: apply isbyteZ_Ti.
    unfold HKDF_expand; simpl.
    destruct (zle (32 * (i + 1)) 0); try omega.
    rewrite sublist_sublist; try omega. rewrite 2 Z.add_0_r.
    rewrite (Zmod_unique _ _ (i+1) 0); try omega. simpl.
    rewrite (Zdiv_unique _ _ (i+1) 0); try omega.
    replace (Z.to_nat (i+1)) with (S (Z.to_nat i)).
    2: rewrite Z.add_comm, Z2Nat.inj_add; try reflexivity; try omega.
    simpl. rewrite sublist_app2; rewrite Zlength_T, Nat2Z.inj_mul, Z2Nat.id; simpl; try omega.
    rewrite Zminus_diag, Hl, <- app_assoc, Zpos_P_of_succ_nat, Z2Nat.id; try omega.
    replace ((32 * i + rest - 32 * i)%Z) with rest%Z by omega.
    replace (i + 1) with (Z.succ i) in * by trivial.
    rewrite zero_ext_inrange; try rewrite Int.unsigned_repr; trivial; try omega.
    change (two_p 8 - 1) with 255; omega.
Qed.

Lemma sublist_HKDF_expand5 PRK INFO l i
         (Hl : if zeq i 0 then l = []
               else PREVcont PRK INFO i = map Vint (map Int.repr l) /\ Forall general_lemmas.isbyteZ l)
         (Hi : 0 <= i):
      sublist 0 32 (HMAC256_functional_prog.HMAC256 ((l ++ CONT INFO) ++ [i + 1]) (CONT PRK)) =
      sublist (32 * i) (32 * i + 32) (HKDF_expand (CONT PRK) (CONT INFO) (32 * (i + 1))).
Proof.
  unfold HKDF_expand. destruct (zle (32*(i + 1)) 0); try omega. simpl.
  rewrite (Zmod_unique _ _ (i+1) 0) by omega. simpl.
  rewrite (Zdiv_unique _ _(i+1) 0) by omega.
  rewrite sublist_sublist; try omega. rewrite ! Z.add_0_r.
  replace (Z.to_nat (i + 1)) with (S (Z.to_nat i)).
  2: rewrite Z.add_comm, Z2Nat.inj_add; try reflexivity; try omega.
  simpl.
  rewrite Zpos_P_of_succ_nat, Z2Nat.id; try omega.
  rewrite sublist_app2; rewrite Zlength_T, Nat2Z.inj_mul, Z2Nat.id; simpl; try omega.
  rewrite Zminus_diag. replace ((32 * i + 32 - 32 * i)%Z) with 32%Z by omega.
  unfold PREVcont in Hl.
  destruct (zeq i 0). { simpl in *; subst i l; simpl; trivial. }
  destruct Hl as [Hl isBTl]. apply map_Vint_injective in Hl.
  apply map_IntReprOfBytes_injective in Hl; trivial. 2: apply isbyteZ_Ti.
  rewrite Hl, <- app_assoc.
  change (i+1)%Z with (Z.succ i); trivial.
Qed.

Lemma body_hkdf_expand: semax_body Hkdf_VarSpecs Hkdf_FunSpecs
       f_HKDF_expand HKDF_expand_spec.
Proof.
start_function.
rename H into LenPRK. rename H0 into LEN_INFO1.
destruct H1 as [LEN_INFO2 LEN_INFO3]. rename H2 into OLEN.

freeze [0;1;2;3;4;5;6] FR1.
forward. forward. forward. forward.
unfold Int.divu, Int.add, Int.sub.
assert (OLEN2: 0 <= (olen + 32 - 1) / 32 <= Int.max_unsigned).
{ split. apply Z_div_pos; omega.
  apply Zdiv_le_upper_bound; omega. }
rewrite (Int.unsigned_repr 32); [| rewrite int_max_unsigned_eq; omega].
rewrite (Int.unsigned_repr olen); [| omega].
rewrite (Int.unsigned_repr 1); [| rewrite int_max_unsigned_eq; omega].
rewrite (Int.unsigned_repr (Int.unsigned (Int.repr (olen + 32)) - 1));
  [| rewrite Int.unsigned_repr; omega].
rewrite Int.unsigned_repr; [| omega].
forward_if
  (EX v:_,
   PROP (if zlt (olen + 32) olen then v = Vint (Int.repr 1)
         else v = Val.of_bool (Int.ltu (Int.repr 255) (Int.repr ((olen + 32 - 1) / 32))) )
   LOCAL (temp _t'1 v;
   temp _n (Vint (Int.repr ((olen + 32 - 1) / 32)));
   temp _ret (Vint (Int.repr 0)); temp _done (Vint (Int.repr 0));
   temp _digest_len (Vint (Int.repr 32)); lvar _ctr tuchar v_ctr;
   lvar _hmac (Tstruct _hmac_ctx_st noattr) v_hmac;
   lvar _previous (tarray tuchar 64) v_previous; temp _out_key out;
   temp _out_len (Vint (Int.repr olen)); temp _prk prk;
   temp _prk_len (Vint (Int.repr (spec_hmac.LEN PRK)));
   temp _info info; temp _info_len (Vint (Int.repr (spec_hmac.LEN INFO)));
   gvar sha._K256 kv)  SEP (FRZL FR1)).
{ forward. Exists (Vint (Int.repr 1)). erewrite zlt_true; try eapply H.
  entailer!. }
{ forward.
  Exists (Val.of_bool (Int.ltu (Int.repr 255) (Int.repr ((olen + 32 - 1) / 32)))).
  rewrite if_false; trivial.
  entailer!. unfold sem_cast, sem_cast_i2bool, Val.of_bool; simpl.
  destruct (Int.ltu (Int.repr 255) (Int.repr ((olen + 32 - 1) / 32))); simpl; reflexivity. }
apply extract_exists_pre. intros v. Intros. rename H into HV.
unfold Int.ltu in HV.
rewrite Int.unsigned_repr in HV; [| rewrite int_max_unsigned_eq; omega].
rewrite Int.unsigned_repr in HV; [| omega].
unfold Val.of_bool in HV.
forward_if
  (PROP (v=Vint (Int.repr 0))
   LOCAL (temp _t'1 v; temp _n (Vint (Int.repr ((olen + 32 - 1) / 32)));
   temp _ret (Vint (Int.repr 0)); temp _done (Vint (Int.repr 0));
   temp _digest_len (Vint (Int.repr 32)); lvar _ctr tuchar v_ctr;
   lvar _hmac (Tstruct _hmac_ctx_st noattr) v_hmac;
   lvar _previous (tarray tuchar 64) v_previous; temp _out_key out;
   temp _out_len (Vint (Int.repr olen)); temp _prk prk;
   temp _prk_len (Vint (Int.repr (spec_hmac.LEN PRK)));
   temp _info info; temp _info_len (Vint (Int.repr (spec_hmac.LEN INFO)));
   gvar sha._K256 kv)  SEP (FRZL FR1)).
{ unfold typed_true in H.
  rewrite if_false in HV; try omega.
  subst v.
  destruct (zlt 255 ((olen + 32 - 1) / 32)); [clear H | inv H].
  forward. normalize.
  Exists (expand_out_post shmd (CONT PRK) (CONT INFO) olen out).
  entailer!.
  + unfold expand_out_post, digest_len; simpl.
    rewrite if_false; try omega.
    rewrite if_true; trivial.
  + thaw FR1.
    unfold expand_out_post, digest_len; simpl.
    rewrite if_false; try omega.
    rewrite if_true; trivial. simpl. cancel. }
{ forward. entailer!. unfold typed_false in H; simpl in H; inv H.
  destruct (zlt (olen + 32) olen). inv HV; simpl in *; try discriminate.
  destruct (zlt 255 ((olen + 32 - 1) / 32)); inv HV; simpl in *; try discriminate; trivial. }
Intros. subst v. rewrite if_false in HV; try omega.
destruct (zlt 255 ((olen + 32 - 1) / 32)); [inv HV | clear HV].
drop_LOCAL 0%nat.
thaw FR1.
Time assert_PROP (isptr prk) as isPtrPrk by entailer!. (*destruct prk; try contradiction. (Vptr b i)*)

freeze [0;2;3;6] FR1.
assert_PROP (field_compatible t_struct_hmac_ctx_st [] v_hmac) as FC_hmac by entailer!.
replace_SEP 1 (HMAC_SPEC.EMPTY v_hmac).
{ entailer!. eapply HMAC_SPEC.mkEmpty; trivial. }
idtac "Timing the call to _HMAC_Init".
Time forward_call (@inr (val * Z * list Z * val) _ (v_hmac, spec_hmac.LEN PRK, CONT PRK, kv, prk)).
(*Finished transaction in 1.717 secs (1.371u,0.017s) (successful)*)

remember ((olen + 32 - 1) / 32) as bnd.
thaw FR1.
assert_PROP (isptr v_previous /\ field_compatible (tarray tuchar 64) [] v_previous) as prevPtr by entailer!.
destruct prevPtr as [prevPtr prevFC].
(*destruct previous; try contradiction. clear prevPtr.*)

unfold data_at_ at 2. unfold field_at_.
rewrite field_at_data_at. simpl. unfold tarray.
assert (VV: exists vv :reptype (Tarray tuchar 64 noattr), vv= list_repeat 64 Vundef).
{ eexists; reflexivity. }
destruct VV as [vv VV].
assert (JMeq_1: JMeq (default_val (Tarray tuchar 64 noattr)) (sublist 0 64 vv)).
{ subst vv. rewrite sublist_list_repeat with (k:=64); try omega. simpl. apply JMeq_refl. }
erewrite  split2_data_at_Tarray with (n1:=32).
2: omega.
3: apply JMeq_refl.
3: apply JMeq_refl.
2: eassumption.
normalize. simpl.
rewrite field_address_offset by auto with field_compatible. simpl.
rewrite isptr_offset_val_zero; trivial. (* rewrite Int.add_zero.*)
rewrite field_address0_offset by auto with field_compatible. simpl.
rewrite memory_block_field_compatible_tarraytuchar by rep_omega.
Intros. rename H into FCout.

freeze [1;3] FR0.
assert_PROP (isptr out) as isPTRout by entailer!.
assert (Arith: 32 > 0) by omega.
specialize (Z_div_mod_eq olen 32 Arith); intros OLEN1.
assert (REST:= Z_mod_lt olen 32 Arith). remember (olen / 32) as rounds. remember (olen mod 32) as rest.
assert (BND: bnd = if zeq rest 0 then rounds else rounds + 1).
{ subst bnd olen. clear Heqrounds Heqrest.
  destruct (zeq rest 0).
  + subst rest. assert (X: 32 * rounds + 0 + 32 - 1 = 32 * rounds + 31) by omega. rewrite X; clear X.
    symmetry. eapply Zdiv.Zdiv_unique. 2: reflexivity. omega.
  + assert (X: 32 * rounds + rest + 32 - 1 = rounds * 32 + (rest + 31)) by omega. rewrite X; clear X.
    rewrite Z.div_add_l. f_equal. apply Zdiv_unique with (b:=rest -1); omega. omega. }
clear Heqbnd Heqrounds Heqrest.

forward_for_simple_bound bnd
       (EX ii:Z, PROP (0 <= olen - Int.unsigned(if zlt ii bnd then Done ii else Int.repr olen))
             LOCAL (temp _n (Vint (Int.repr bnd));
                    temp _ret (Vint (Int.repr 0));
                    temp _done (Vint (if zlt ii bnd then Done ii else Int.repr olen));
                    temp _digest_len (Vint (Int.repr 32)); lvar _ctr tuchar v_ctr;
                    lvar _hmac (Tstruct _hmac_ctx_st noattr) v_hmac; lvar _previous (tarray tuchar 64) v_previous;
                    temp _out_key out; temp _out_len (Vint (Int.repr olen)); temp _prk prk;
                    temp _prk_len (Vint (Int.repr (spec_hmac.LEN PRK))); temp _info info;
                    temp _info_len (Vint (Int.repr (spec_hmac.LEN INFO))); gvar sha._K256 kv)
             SEP (FRZL FR0; K_vector kv; data_at_ Tsh tuchar v_ctr;
            data_at Tsh (Tarray tuchar 32 noattr) (PREVcont PRK INFO ii) v_previous;
            data_block Tsh (CONT INFO) info;
            if zeq ii 0 then HMAC_SPEC.REP (HMAC_SPEC.hABS (CONT PRK) []) v_hmac
            else HMAC_SPEC.FULL (CONT PRK) v_hmac;
            OUTpred (CONT PRK) (CONT INFO) shmd (Z.min (digest_len * ii) olen)
                    (olen - Z.min (digest_len * ii) olen) (ii*32) out)).
{ destruct (zeq 0 0); try solve [omega]. clear e; entailer!.
  + unfold Done; simpl.
    destruct (zeq rest 0); simpl.
    - subst rest.
      destruct (zlt 0 rounds); simpl.
      * split; trivial. rewrite Int.unsigned_repr; omega.
      * assert(R0: rounds = 0) by omega. rewrite R0 in *; clear R0. simpl. split; trivial; omega.
    - rewrite if_true. 2: omega. split; trivial. rewrite Int.unsigned_repr; omega.
  + unfold OUTpred. destruct (zeq rest 0).
    - subst rest; simpl.
      destruct (zlt 0 rounds); simpl.
      * rewrite Zplus_0_r, Z.min_l, Zminus_0_r, data_at_tuchar_zero_array_eq, isptr_offset_val_zero(*, data_at__memory_block*); trivial; try omega.
        cancel.
      * assert(R0: rounds = 0) by omega. rewrite R0 in *; clear R0. simpl. unfold tarray. (*cancel.*)
        rewrite isptr_offset_val_zero, data_at_tuchar_zero_array_eq; trivial. cancel.
    - rewrite Zmin_l by omega. rewrite Zminus_0_r, data_at_tuchar_zero_array_eq; trivial.
      rewrite isptr_offset_val_zero; trivial. cancel.
}

{ (*loop body*)
  rename H into Hi1. Intros. rename i into i1. rename H into olenBounded. unfold Done, digest_len in olenBounded.
   rewrite if_true in olenBounded; try omega.
   rewrite Int.unsigned_repr in olenBounded. 2: rewrite int_max_unsigned_eq; omega.

  forward. rewrite Zmin_l. 2: unfold digest_len; omega.

  forward_if (EX l:_,
  PROP ( if zeq i1 0 then l=@nil Z else PREVcont PRK INFO i1 = map Vint (map Int.repr l) /\ Forall general_lemmas.isbyteZ l)
   LOCAL (temp _i (Vint (Int.repr i1)); temp _n (Vint (Int.repr bnd));
   temp _ret (Vint (Int.repr 0)); temp _done (Vint (if zlt i1 bnd then Done i1 else Int.repr olen));
   temp _digest_len (Vint (Int.repr 32)); lvar _ctr tuchar v_ctr;
   lvar _hmac (Tstruct _hmac_ctx_st noattr) v_hmac;
   lvar _previous (tarray tuchar 64) v_previous; temp _out_key out;
   temp _out_len (Vint (Int.repr olen)); temp _prk prk;
   temp _prk_len (Vint (Int.repr (LEN PRK))); temp _info info;
   temp _info_len (Vint (Int.repr (LEN INFO))); gvar sha._K256 kv)
   SEP (FRZL FR0; K_vector kv;
   field_at Tsh tuchar []
     (Vint (cast_int_int I8 Unsigned (Int.add (Int.repr i1) (Int.repr 1)))) v_ctr;
   data_at Tsh (Tarray tuchar 32 noattr) (PREVcont PRK INFO i1) v_previous;
   data_block Tsh (CONT INFO) info;
   OUTpred (CONT PRK) (CONT INFO) shmd (digest_len * i1) (olen - digest_len * i1) (i1*32) out;
   HMAC_SPEC.REP (HMAC_SPEC.hABS (CONT PRK) l) v_hmac)).

   { destruct (zlt i1 bnd); try omega. rewrite if_false; trivial.
     freeze [0;2;4;6] FR1.
     idtac "Timing the call to _HMAC_Init".
     Time forward_call (@inl _ (val * Z * list Z * val * val) (v_hmac,0,CONT PRK,kv)).
     (* Finished transaction in 1.73 secs (1.472u,0.011s) (successful)*)
     destruct (PREV_isbyteZ PRK INFO i1) as [prev [Hprev BTprev]]. omega. rewrite Hprev.
     assert (Zlength_prev: Zlength prev = 32).
     { specialize (PREV_len PRK INFO i1). rewrite Hprev.
       do 2 rewrite Zlength_map. intros X; rewrite X; trivial. omega. }

     idtac "Timing the first call to _HMAC_Update".
     Time forward_call (CONT PRK, v_hmac, v_previous, @nil Z, prev, kv).
     (*Finished transaction in 2.55 secs (2.048u,0.005s) (successful)*)
     * rewrite Zlength_prev, sem_cast_neutral_ptr; trivial.
       apply prop_right; split; trivial.
     * assert (Frame = [FRZL FR1]). subst Frame; reflexivity. simpl; cancel.
       unfold data_block. normalize. rewrite Zlength_prev; trivial.
     * rewrite Zlength_prev, Zlength_nil.
       split. rewrite int_max_unsigned_eq; omega.
       cbv; trivial.
     * Exists prev. rewrite if_false; trivial. entailer!. thaw FR1. cancel.
       unfold data_block. normalize. rewrite Hprev, Zlength_prev. cancel. }
   { subst i1. forward. Exists (@nil Z). rewrite ! if_true; try omega.
     entailer!. }

   apply extract_exists_pre. intros l. Intros. rename H into Hl. rewrite if_true. 2: omega.

   idtac "Timing the second call to _HMAC_Update".
   Time forward_call (CONT PRK, v_hmac, info, l, CONT INFO, kv).
   (* Finished transaction in 2.659 secs (2.094u,0.014s) (successful)*)
   { rewrite LEN_INFO1, sem_cast_neutral_ptr; trivial.
     apply prop_right. split; reflexivity. }
   { split. omega.
     destruct (zeq i1 0).
     + subst i1 l. rewrite Zlength_nil, Zplus_0_r. omega.
     + assert (Arith1: 0<= i1) by omega. specialize (PREV_len PRK INFO i1 Arith1); intros HZ.
       destruct Hl.
       assert (HH: Zlength (@map int val Vint (@map Z int Int.repr l)) = @Zlength val (PREVcont PRK INFO i1))
         by (f_equal; auto).
       repeat rewrite Zlength_map in HH. rewrite HH, HZ, <- Zplus_assoc; simpl. omega. }

   simpl. freeze [1;3;5;6] FR3.
   assert_PROP (field_compatible (tarray tuchar 1) [] v_ctr /\ isptr v_ctr) as HH by entailer!.
   destruct HH as [FC_cptr isptrCtr].

   replace_SEP 3 (data_at Tsh (tarray tuchar 1) [Vint (Int.zero_ext 8 (Int.add (Int.repr i1) (Int.repr 1)))] v_ctr).
   { entailer!. apply data_at_tuchar_singleton_array. }

   assert (Forall general_lemmas.isbyteZ [Int.unsigned (Int.zero_ext 8 (Int.repr (i1+1)))]) as isBT.
      { constructor. red. rewrite zero_ext_inrange; rewrite Int.unsigned_repr. omega.
         rewrite int_max_unsigned_eq; omega.
         assert (Arith1: two_p 8 - 1 = 255) by reflexivity. rewrite Arith1; omega.
         rewrite int_max_unsigned_eq; omega. constructor. }
   assert (LEN: Zlength [Int.unsigned (Int.zero_ext 8 (Int.add (Int.repr i1) (Int.repr 1)))] = 1) by reflexivity.

   idtac "Timing the third call to _HMAC_Update".
   Time forward_call (CONT PRK, v_hmac, v_ctr, l++CONT INFO,
        [Int.unsigned (Int.zero_ext 8 (Int.add (Int.repr i1) (Int.repr 1)))], kv).
   (* Finished transaction in 2.64 secs (2.057u,0.004s) (successful)*)
   { assert (Frame = [FRZL FR3]). subst Frame; reflexivity. subst Frame. simpl. cancel.
     unfold data_block. simpl. rewrite Int.repr_unsigned, LEN. entailer!. }
   { rewrite LEN. rewrite int_max_unsigned_eq, Zlength_app. split. omega.
     destruct (zeq i1 0).
     + subst l; rewrite Zlength_nil. rewrite Z.add_0_l. omega.
     + specialize (PREV_len PRK INFO i1). destruct Hl as [Hl isbyte_l]. rewrite Hl. do 2 rewrite Zlength_map.
       intros HH; rewrite HH; omega. }

   normalize. thaw FR3. freeze [1;3;4;6] FR4.
   replace_SEP 3 (memory_block Tsh 32 v_previous).
   { entailer!. eapply derives_trans. apply data_at_memory_block. trivial. }
   idtac "Timing the call to _HMAC_Final".
   Time forward_call (((l ++ CONT INFO) ++ [Int.unsigned (Int.zero_ext 8 (Int.repr (i1 + 1)))]),
                 CONT PRK, v_hmac, v_previous, Tsh, kv).
   (* Finished transaction in 2.64 secs (2.057u,0.004s) (successful)*)
   unfold data_block. normalize. focus_SEP 2. erewrite (extract_prop_in_SEP 0); simpl. 2: reflexivity.
   Intros. rename H into isBT_app. (*VST TODO: why does normalize/Intros need the explicit extract_prop_in_SEP???*)
   rewrite HMAC_Zlength.
   remember (HMAC256_functional_prog.HMAC256
                   ((l ++ CONT INFO) ++
                    [Int.unsigned (Int.zero_ext 8 (Int.repr (i1 + 1)))])
                   (CONT PRK)) as CONTRIB.
   forward.
   forward_if
  (PROP ( )
   LOCAL (temp _todo (if zlt olen
                             (Int.unsigned (Int.add (Done i1) (Int.repr 32)))
                      then Vint (Int.sub (Int.repr olen) (Done i1))
                      else Vint (Int.repr 32));
   temp _i (Vint (Int.repr i1));
   temp _n (Vint (Int.repr bnd)); temp _ret (Vint (Int.repr 0));
   temp _done (Vint (Done i1)); temp _digest_len (Vint (Int.repr 32));
   lvar _ctr tuchar v_ctr; lvar _hmac (Tstruct _hmac_ctx_st noattr) v_hmac;
   lvar _previous (tarray tuchar 64) v_previous;
   temp _out_key out; temp _out_len (Vint (Int.repr olen));
   temp _prk prk; temp _prk_len (Vint (Int.repr (spec_hmac.LEN PRK)));
   temp _info info; temp _info_len (Vint (Int.repr (spec_hmac.LEN INFO)));
   gvar sha._K256 kv)
   SEP (data_at Tsh (tarray tuchar 32) (map Vint (map Int.repr CONTRIB)) v_previous;
   K_vector kv; HMAC_SPEC.FULL (CONT PRK) v_hmac; FRZL FR4)).
   { forward. entailer!. rewrite if_true; trivial; omega. }
   { forward. entailer!. rewrite if_false; trivial; omega. }

   thaw FR4.
   (*destruct out; try contradiction. (*out = Vptr b1 i2*) *)
   unfold OUTpred, Done, digest_len. normalize.
   freeze [0;3;4;5;6;7] FR5.

   idtac "Timing the call to _memcpy".
   Time forward_call (hkdf_compspecs.CompSpecs, (Tsh, shmd),
                 offset_val (32*i1) out, v_previous,
                 olen - (32* i1), 32,
             if zlt olen (32 * i1 + 32)
             then olen - 32 * i1
             else 32, map Int.repr CONTRIB).
   (* Finished transaction in 4.255 secs (3.485u,0.006s) (successful)*)
   { destruct (zlt olen (32 * i1 + 32)); simpl; entailer!. }
   { simpl; cancel. }
   { simpl. split. apply readable_share_top. split; trivial.
     destruct (zlt olen (32 * i1 + 32)); omega. }
   forward.

   (* establish loop invariant*)
   destruct (zeq (i1 + 1) 0); try omega.
   destruct (zlt olen (32 * i1 + 32)).
   + entailer!.
     * clear - OLEN2 olenBounded OLEN Hi1 REST l0. unfold Done, digest_len in *. simpl.
(*       rewrite add_repr.*)
       destruct (zeq rest 0).
       - subst rest; simpl in *.
         destruct (zlt (i1 + 1) rounds); rewrite Int.unsigned_repr; omega.
       - destruct (zlt (i1 + 1) (rounds+1)). rewrite Int.unsigned_repr; omega.
         rewrite Int.unsigned_repr; try omega. split. omega. f_equal. f_equal. omega.
     * thaw FR5. destruct out; try contradiction. simpl. rewrite Zminus_diag, memory_block_zero_Vptr. cancel.
       clear H1 H2 H (*AC SC*) H4 H5.
       unfold data_block. normalize. rewrite LEN, data_at_tuchar_singleton_array_eq. cancel.
       rewrite sepcon_assoc. apply sepcon_derives.
       - apply data_at_ext_derives; trivial.
         rewrite zero_ext_inrange; try rewrite Int.unsigned_repr; try omega. 2: change (two_p 8 - 1) with 255; omega.

         destruct (zeq i1 0).
         ++ subst l. rewrite e in *; simpl. unfold PREVcont; simpl; trivial.
         ++ clear - Hl n0 Hi1. destruct Hl. erewrite PREVcont_Sn; try eassumption.
            rewrite if_false, app_assoc; trivial. omega.
       - unfold OUTpred, digest_len. simpl.
         destruct (zeq rest 0).
         ++ subst rest; simpl. rewrite Zplus_0_r in *. omega.
         ++ destruct (zlt (i1 + 1) (rounds + 1)); try solve [omega].
            assert (i1 = rounds) by omega. subst i1.
            replace (32 * rounds + rest - 32 * rounds) with rest by omega.
            rewrite Zmin_r; [| omega].
            rewrite Zminus_diag, memory_block_zero_Vptr; try solve [omega].
            replace (((rounds + 1)*32)%Z) with ((32 * (rounds + 1) + 0)%Z) by omega.
            rewrite (split2_data_at_Tarray_tuchar shmd (32 * rounds + rest) (32 * rounds)); simpl; trivial; try omega.

            Focus 2. rewrite Zlength_sublist; try omega.
                     rewrite 2 Zlength_map.
                     rewrite Zlength_HKDF_expand; simpl; omega.
            unfold tarray; cancel.
               rewrite field_address0_offset; simpl.
               2: eapply field_compatible0_cons_Tarray; [ reflexivity | trivial | omega].
            entailer!. rewrite sublist_sublist; try omega.
            rewrite sublist_sublist; try omega. rewrite ! Z.add_0_r.
            replace (32 * rounds + rest - 32 * rounds) with rest by omega.
            rewrite ! sublist_map.

            replace (rounds * 32)%Z with (32*rounds)%Z by omega.
            rewrite sublist_HKDF_expand4, <- sublist_HKDF_expand2; trivial; try omega.
            cancel.

   + entailer!.
     * clear H H0 H1 H2 H3 H4 H5 (*AC SC*) JMeq_1 LEN. unfold Done, digest_len in *. simpl.
       (*rewrite add_repr.*)
       destruct (zeq rest 0).
       - subst rest; simpl in *.
         destruct (zlt (i1 + 1) rounds).
         ++ split. rewrite Int.unsigned_repr; try omega.
            f_equal. f_equal. omega.
         ++ split. rewrite Int.unsigned_repr; try omega.
            f_equal. f_equal. omega.
       - destruct (zlt (i1 + 1) (rounds+1)).
         ++ split. rewrite Int.unsigned_repr; try omega.
            f_equal. f_equal. omega.
         ++ split. rewrite Int.unsigned_repr; try omega.
            f_equal. f_equal. omega.
     * thaw FR5. cancel.
       unfold data_block, digest_len. normalize. rewrite LEN, data_at_tuchar_singleton_array_eq. cancel.
       rewrite Z.min_l by omega.
       repeat rewrite sepcon_assoc. apply sepcon_derives.
       - apply data_at_ext_derives; trivial.
         rewrite zero_ext_inrange; try rewrite Int.unsigned_repr; try omega. 2: change (two_p 8 - 1) with 255; omega.

         destruct (zeq i1 0).
         ++ subst l. rewrite e in *; simpl. unfold PREVcont. simpl; trivial.
         ++ clear - Hl n0 Hi1. destruct Hl. erewrite PREVcont_Sn; try eassumption.
            rewrite if_false, app_assoc; trivial. omega.
       - unfold OUTpred, digest_len. simpl. rewrite Z.mul_add_distr_l, Z.mul_1_r.
         rewrite zero_ext_inrange; rewrite Int.unsigned_repr; try omega.
         2: change (two_p 8 - 1) with 255; omega.
         destruct (zeq rest 0).
         ++ subst rest; simpl in *. rewrite Zplus_0_r in *.
            destruct (zlt (i1+1) rounds).
            ** replace (32 * rounds - (32 * i1 + 32)) with (32 * rounds - 32 * i1 - 32) by omega. cancel.
               rewrite (split2_data_at_Tarray_tuchar shmd (32 * i1+32) (32 * i1)); simpl; trivial; try omega.
               -- unfold tarray.
                  replace (32 * i1 + 32 - 32 * i1) with 32 by omega.
                  rewrite field_address0_offset; simpl.
                  Focus 2. eapply field_compatible0_cons_Tarray. reflexivity.
                           eapply field_compatible_array_smaller0. apply FCout. omega. omega.
                  rewrite sublist_sublist; try omega.
                  rewrite sublist_sublist; try omega.
                  rewrite ! sublist_map, !  Z.mul_1_l, ! Z.add_0_r, ! Z.add_0_l.
                  clear - Hl Hi1.
                  replace ((i1 + 1) * 32)%Z with (32*(i1 + 1))%Z by omega.
                  replace (i1 * 32)%Z with (32*i1)%Z by omega.
                  rewrite <- sublist_HKDF_expand2; try omega.
                  erewrite <- sublist_HKDF_expand5; try omega; try eassumption. cancel.
              -- rewrite Zlength_sublist; try omega. rewrite ! Zlength_map.
                 replace ((i1 + 1) * 32)%Z with ((32 * (i1 + 1))+0) by omega.
                 rewrite Zlength_HKDF_expand; omega.
            ** assert (rounds = i1+1) by omega. subst rounds; simpl in *.
               replace (32 * (i1 + 1))%Z with ((32 * i1 + 32)%Z) by omega.
               replace (32 * i1 + 32 - 32 * i1 - 32)%Z with 0%Z by omega.
               rewrite Zminus_diag, memory_block_zero. cancel.
               rewrite (split2_data_at_Tarray_tuchar shmd (32 * i1 + 32) (32 * i1)); simpl; trivial; try omega.
               -- replace ((32 * i1 + 32 - 32 * i1)%Z) with 32%Z by omega.
                  rewrite field_address0_offset by auto with field_compatible. simpl.
                  repeat rewrite sublist_sublist; try omega. rewrite ! Z.add_0_r, ! Z.add_0_l, ! Z.mul_1_l.
                  unfold tarray; rewrite sepcon_comm.
                  replace ((i1 + 1) * 32)%Z with (32*(i1+1))%Z by omega.
                  replace (i1 * 32)%Z with (32*i1)%Z by omega.
                  rewrite ! sublist_map, <- (sublist_HKDF_expand5 PRK INFO l i1 Hl),
                    <- sublist_HKDF_expand2; try omega; cancel.
               -- rewrite Zlength_sublist; try omega. rewrite 2 Zlength_map.
                  replace (((i1 + 1)*32)%Z) with ((32 * (i1 + 1) + 0)%Z) by omega.
                  rewrite Zlength_HKDF_expand; omega.
          ++ replace (32 * rounds + rest - 32 * i1 - 32)%Z with (32 * rounds + rest - (32 * i1 + 32))%Z by omega.
             cancel.

             rewrite (split2_data_at_Tarray_tuchar shmd (32*i1 + 32) (32*i1)); simpl; trivial; try omega.
                ** rewrite field_address0_offset; simpl. rewrite Z.mul_1_l, Z.add_0_l.
                   rewrite ! sublist_map, ! sublist_sublist, ! Z.add_0_r; try omega.
                   replace (32 * i1 + 32 - 32 * i1) with 32 by omega.
                   replace ((i1 + 1)*32)%Z with (32*(i1+1))%Z by omega.
                   replace (i1*32)%Z with (32*i1)%Z by omega.
                   rewrite <- (sublist_HKDF_expand5 PRK INFO l i1 Hl), <- sublist_HKDF_expand2; try omega. cancel.
                   eapply field_compatible0_cons_Tarray; [ reflexivity | | omega].
                   eapply field_compatible_array_smaller0; [ apply FCout | omega].
                ** rewrite ! sublist_map, ! Zlength_map, Zlength_sublist; try omega.
                   replace ((i1 + 1) * 32)%Z with (32 * (i1+1) + 0)%Z by omega.
                   rewrite Zlength_HKDF_expand; omega. }
(*Continuation after loop*)
  normalize. rewrite if_false in H. 2: omega. clear H. (*eliminate this PROP in loop invariant entirely?*)

  forward.
    freeze [0;1;2;3;4;6] FR6.

  idtac "Timing the call to _HMAC_cleanup".
  Time forward_call (CONT PRK, v_hmac).
  (* Finished transaction in 1.589 secs (1.371u,0.004s) (successful)*)
    { assert (Frame = [FRZL FR6]). subst Frame; reflexivity.
      subst Frame; simpl. cancel.
      destruct (zeq bnd 0); trivial. apply HMAC_SPEC.REP_FULL. }
  forward. forward. (*
    forward_if (
  (PROP ( )
   LOCAL (temp _ret (Vint (Int.repr 1)); temp _i (Vint (Int.repr bnd));
   temp _n (Vint (Int.repr bnd));
   temp _done (Vint (if zlt bnd bnd then Done bnd else Int.repr olen));
   temp _digest_len (Vint (Int.repr 32)); lvar _ctr tuchar v_ctr;
   lvar _hmac (Tstruct _hmac_ctx_st noattr) v_hmac;
   lvar _previous (tarray tuchar 64) v_previous; temp _out_key out;
   temp _out_len (Vint (Int.repr olen)); temp _prk prk;
   temp _prk_len (Vint (Int.repr (LEN PRK))); temp _info info;
   temp _info_len (Vint (Int.repr (LEN INFO))); gvar sha._K256 kv)
   SEP (HMAC_SPEC.EMPTY v_hmac; FRZL FR6))).
     { forward. entailer!. }
     { forward. entailer!. }

  forward. *)
     Exists (expand_out_post shmd (CONT PRK) (CONT INFO) (32 * rounds + rest) out).
     Time entailer!.
     + unfold expand_out_post, digest_len.
       rewrite if_false. 2: omega.
       rewrite if_false. simpl; trivial.
       destruct (zeq rest 0); simpl in *.
       - subst rest. assert (X: 32 * rounds + 0 + 32 - 1 = 32 * rounds + 31) by omega.
         rewrite X; clear X. erewrite <- Zdiv.Zdiv_unique. 3: reflexivity. omega. omega.
       - assert (X: 32 * rounds + rest + 32 - 1 = rounds * 32 + (rest + 31)) by omega.
         rewrite X; clear X.
         rewrite Z.div_add_l; try omega.
         erewrite Zdiv_unique with (b:=rest -1)(a:=1); omega.
     + thaw FR6. thaw FR0. cancel. unfold expand_out_post, digest_len.
        rewrite 2 sepcon_assoc. rewrite sepcon_comm. apply sepcon_derives; [| apply HMAC_SPEC.EmptyDissolve].
        rewrite <- sepcon_assoc. rewrite sepcon_comm. apply sepcon_derives.
        - destruct (zlt (32 * rounds + rest + 32) (32 * rounds + rest)); try omega.
          destruct (zlt (if zeq rest 0 then rounds else rounds + 1) (if zeq rest 0 then rounds else rounds + 1)); try omega.
          unfold OUTpred, data_block.
          rewrite Z.min_r by (destruct (zeq rest 0); omega).
          rewrite Zminus_diag, memory_block_zero, Zlength_HKDF_expand; try omega. normalize.
          destruct (zlt 255 ((32 * rounds + rest + 32 - 1) / 32)).
          { exfalso. destruct (zeq rest 0).
            + subst rest; simpl in *. replace (32 * rounds + 0 + 32 - 1)%Z with (rounds * 32 + 31) in l by omega.
              rewrite Z_div_plus_full_l, Zdiv_small in l; omega.
            + replace (32 * rounds + rest + 32 - 1)%Z with (rounds * 32 + (rest + 31))%Z in l by omega.
              rewrite Z_div_plus_full_l in l; try omega. erewrite (Zdiv_unique _ _ 1 ((rest + 31)-32)) in l; omega. }
          simpl.
          apply andp_right. apply prop_right; apply isbyteZ_HKDF_expand.
          apply data_at_ext_derives; trivial.
          destruct (zeq rest 0).
          * subst rest; simpl. rewrite Z.add_0_r, sublist_same, Z.mul_comm; trivial.
            rewrite ! Zlength_map. replace ((rounds*32)%Z) with ((32 * rounds + 0)%Z) by omega.
            rewrite Zlength_HKDF_expand; omega.
          * replace ((rounds + 1)*32)%Z with (32 * rounds + 32)%Z by omega.
            rewrite 2 sublist_map. f_equal. f_equal.
            apply sublist_HKDF_expand3; omega.
        - rewrite (split2_data_at__Tarray_tuchar Tsh 64 32); simpl; trivial; try omega.
          rewrite field_address0_offset. cancel.
          eapply field_compatible0_cons_Tarray; [reflexivity | trivial | omega].
Time Qed.
  (*Finished transaction in 11.161 secs (11.057u,0.056s) *)
 (*Coq8.6:37secs*)
 (*Finished transaction in 195.171 secs (171.828u,0.031s) (successful)*)
 (* Last week: Finished transaction in 54.281 secs (49.656u,0.015s) (successful)*)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**********************************************************************)
(*               Typed LambdaFactor Calculus                          *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation               *)
(* of Lambda Calculus  from Project Coq                               *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                     LamSF_Normal.v                                 *)
(*                                                                    *)
(*                      Barry Jay                                     *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import General.
Require Import Max.
Require Import Test.
Require Import LamSF_Terms.
Require Import LamSF_Tactics.
Require Import LamSF_Substitution_term.
Require Import Components.
Require Import Compounds.
Require Import LamSF_reduction.

(* normal terms *)

Inductive normal : lamSF -> Prop :=
| nf_ref : forall n, normal (Ref n)
| nf_op : forall o, normal (Op o)
| nf_abs : forall M, normal M -> normal (Abs M)
| nf_app : forall M1 M2, normal M1 -> normal M2 -> status (App M1 M2) <> Reducible ->
                         normal (App M1 M2)
.

Hint Constructors normal.

Lemma lift_rec_preserves_normal :
forall M, normal M  -> forall n k, normal(lift_rec M n k).
Proof.
intros M nor; induction nor; split_all.
eapply2 nf_app.
assert(status (lift_rec (App M1 M2) n k) = relocate_status(status (App M1 M2)) n k).
eapply2 lift_rec_preserves_status.
unfold lift_rec in H0; fold lift_rec in H0.
rewrite H0.
unfold relocate_status.
intro.
gen2_case H H1 (status (App M1 M2)).
Qed.

Lemma normal_I : normal i_op.
Proof.
split_all; unfold_op; repeat eapply2 nf_app; intro; split_all; simpl in *; discriminate. Qed.

Hint Resolve normal_I.

Lemma normal_status :
forall M, normal M -> status M <> Reducible.
Proof.
intros M nor; induction nor; split_all; eauto.
case o; intro; split_all.
intro. gen2_case IHnor H (status M); gen2_case IHnor H n.
Qed.

Lemma normal_star :  forall M, normal M -> normal (star M).
Proof.
intros M nor; induction nor; split_all; unfold_op; split_all.
(* 4 *)
case n; split_all.  eapply2 nf_app; split_all.
(* 3 *)
eapply2 nf_app. split_all.
(* 2 *)
eapply2 nf_app. split_all.
(* 1 *)
repeat eapply2 nf_app; unfold compound; split_all.
Qed.

Lemma normal_component_l : forall M, normal M -> normal (left_component M).
Proof.
intros M nor; induction nor; split_all; unfold_op; split_all;
repeat eapply2 nf_app; unfold compound; split_all.
Qed.

Lemma normal_component_r : forall M, normal M -> normal (right_component M).
Proof.  intros M nor; induction nor; split_all; unfold_op; split_all.
eapply2 normal_star.
Qed.

Definition irreducible M (red:termred) := forall N, red M N -> False.

Lemma ref_irreducible : forall n, irreducible (Ref n) lamSF_red1.
Proof. intro n. red. split_all. inversion H; auto. Qed.

(* restore?
Lemma app3_not_compound:
forall M N1 N2 N3, status (App (App (App M N1) N2) N3) = Compound -> False.
Proof.
rank_tac; split_all.
gen_case H0 (status M).
gen_case H0 M.
gen_case H0 l.
gen_case H0 o.
gen_case H0 (status l0).
gen_case H0 (status l0); gen_case H0 (status N1).
gen_case H0 (status l0); gen_case H0 (status N2).
gen_case H0 l1.
gen_case H0 o.
gen_case H0 (status l2).
gen_case H0 (status l2); gen_case H0 (status N1).
gen_case H0 M.
gen_case H0 o.
gen_case H0 (status N1).
gen_case H0 (status N1); gen_case H0 (status N2).
gen_case H0 (status N1); gen_case H0 (status N3).
gen_case H0 l.
gen_case H0 o.
gen_case H0 (status l0).
gen_case H0 (status l0); gen_case H0 (status N2).
Qed.

*)

Lemma Reducible_implies_reducible :
forall M, status M = Reducible -> exists N, lamSF_red1 M N.
Proof.
rank_tac.
induction M; intros; try (simpl in *; discriminate).
(* 3 *)
gen_case H0 o.
(* 2 *)
simpl in *. gen2_case IHM H0 (status M).
(* 4 *)
assert(exists N, lamSF_red1 M N).  eapply2 IHM. omega. split_all. exist (Abs x).
(* 3 *)
gen2_case IHM H0 n.
(* 2 *)
gen2_case IHM H0 n.
(* 1 *)
assert(status M1 = Reducible \/ status M2 = Reducible \/
       (exists i, status M1 = Lam i) \/
       status M1 = Lazy1 \/
       status M1 = Unary_op \/
       (status M1 = Binary_op2 /\ compound M2) \/
       (status M1 = Eager /\ factorable M2)).
unfold factorable, compound.
simpl in *; gen2_case H0 IHM1 (status M1); eauto;
gen2_case IHM2 H0 (status M2); auto 30.
(* 1 *)
inversion H1. simpl in *; elim(IHM1); split_all; try omega.  exist (App x M2).
inversion H2. simpl in *; elim(IHM2); split_all; try omega.  exist (App M1 x).
inversion H3. split_all. assert(exists M0, M1 = Abs M0) by eapply2 lam_is_abs.
    split_all; subst. eauto.
inversion H4.
(* 2 *)
gen2_case H H5 M1. gen_case H5 o. eauto. gen2_case H H5 l. gen_case H5 o; eauto;
try (gen_case H5 (status l0); fail).
(* 3 *)
eauto.
(* 2 *)
gen2_case H H5 l1; eauto.  gen_case H5 o; eauto.
(* 5 *)
gen2_case H H5 (status l2); gen2_case H H5 (status l0).
(* 4 *)
gen2_case H H5 (status l2); gen2_case H H5 (status l0).
(* 3 *)
gen2_case H H5 (status l0).
(* 2 *)
gen_case H5 (status l3); try (gen_case H5 (status l2); fail).
gen_case H5 (status l4);
gen_case H5 (status l2).
gen_case H5 (status l0).
gen_case H5 (status l4);
gen_case H5 (status l2).
(* 1 *)
inversion H5. split_all.
gen3_case H H0 H6 M1; eauto. gen3_case H H0 H6 o; eauto.
gen_case H6 (status l); gen_case H6 (status l0).
inversion H6; split_all.
gen3_case H H0 H8 M1; eauto. gen3_case H H0 H8 o; eauto.
gen_case H8 (status l); gen_case H8 (status l0).
(* 1 *)
gen_case H8 M1; eauto.
gen_case H8 o; eauto.
gen_case H8 l; eauto.
gen_case H8 o; eauto; try (gen_case H8 (status l0); fail).
assert(exists o, l0 = Op o).
gen_case H8 l0; eauto.
gen_case H8 (status l1); eauto;
gen_case H8 n; eauto.
gen_case H8 (status l1); eauto;
gen_case H8 (status l2); eauto.
split_all. subst.
assert(M2 = Op x \/ M2 <> Op x) by (repeat decide equality). inversion H7; subst; eauto.
elim(factorable_implies_compound_or_operator M2); split_all; subst; eauto.
(* 1 *)
assert(status l1 = Ternary_op1).
gen_case H8 (status l1); try (gen_case H8 (status l2); fail).
(* 4 *)
gen_case H8 (status l2); gen_case H8 (status l0).
(* 3 *)
gen_case H8 (status l0).
gen_case H8 (status l0).
elim(factorable_implies_compound_or_operator M2); split_all; subst; eauto.
gen_case H7 l1; eauto. gen_case H7 o; eauto.
assert(M2 = Op Sop \/ M2 <> Op Sop) by (repeat decide equality). inversion H11; subst; eauto.
assert(M2 = Op Aop \/ M2 <> Op Aop) by (repeat decide equality). inversion H11; subst; eauto.
assert(M2 = Op Kop \/ M2 <> Op Kop) by (repeat decide equality). inversion H11; subst; eauto.
assert(M2 = Op Eop \/ M2 <> Op Eop) by (repeat decide equality). inversion H11; subst; eauto.
assert(M2 = Op Gop \/ M2 <> Op Gop) by (repeat decide equality). inversion H11; subst; eauto.
assert(M2 = Op Qop \/ M2 <> Op Qop) by (repeat decide equality). inversion H11; subst; eauto.
assert(M2 = Op Uop \/ M2 <> Op Uop) by (repeat decide equality). inversion H11; subst; eauto.
assert(M2 = Op Yop \/ M2 <> Op Yop) by (repeat decide equality). inversion H11; subst; eauto.
gen_case H7 (status l3);
gen_case H7 (status l4).
gen_case H7 l1. gen_case H7 o; eauto.
assert(x = Sop \/ x <> Sop) by (repeat decide equality). inversion H10; subst; eauto.
 assert(Op x <> Op Sop) by (intro; eapply2 H11; inversion H12; auto). eauto.
assert(x = Aop \/ x <> Aop) by (repeat decide equality). inversion H10; subst; eauto.
 assert(Op x <> Op Aop) by (intro; eapply2 H11; inversion H12; auto). eauto.
assert(x = Kop \/ x <> Kop) by (repeat decide equality). inversion H10; subst; eauto.
 assert(Op x <> Op Kop) by (intro; eapply2 H11; inversion H12; auto). eauto.
assert(x = Eop \/ x <> Eop) by (repeat decide equality). inversion H10; subst; eauto.
 assert(Op x <> Op Eop) by (intro; eapply2 H11; inversion H12; auto). eauto.
assert(x = Gop \/ x <> Gop) by (repeat decide equality). inversion H10; subst; eauto.
 assert(Op x <> Op Gop) by (intro; eapply2 H11; inversion H12; auto). eauto.
assert(x = Qop \/ x <> Qop) by (repeat decide equality). inversion H10; subst; eauto.
 assert(Op x <> Op Qop) by (intro; eapply2 H11; inversion H12; auto). eauto.
assert(x = Uop \/ x <> Uop) by (repeat decide equality). inversion H10; subst; eauto.
 assert(Op x <> Op Uop) by (intro; eapply2 H11; inversion H12; auto). eauto.
assert(x = Yop \/ x <> Yop) by (repeat decide equality). inversion H10; subst; eauto.
 assert(Op x <> Op Yop) by (intro; eapply2 H11; inversion H12; auto). eauto.
(* 2 *)
eauto.
(* 1 *)
gen_case H7 (status l3); gen_case H7 (status l4).
Qed.

Lemma active_irreducible : forall M, forall i, status M = Active i ->  irreducible (left_component M) lamSF_red1 ->  irreducible (right_component M) lamSF_red1 -> irreducible M lamSF_red1.
Proof.
rank_tac.
induction M; intros rk i s l r;  red; split_all.
(* 4 *)
inversion H.
(* 3 *)
inversion H.
(* 2 *)
simpl in s. gen_case s (status M); gen_case s n.
(* 1 *)
inversion H; subst;
try (simpl in s; try discriminate; gen_case s (status M); gen_case s n; fail).
(* 18 *)
eapply2 l.
(* 17 *)
eapply2 r.
(* 16 *)
simpl in s.  gen_case s o.
(* 15 *)
simpl in s.  gen_case s o;  unfold factorable in H2; gen2_case H2 s (status M2); or_tac.
(* 14 *)
simpl in s. unfold compound in H3; gen2_case H3 s (status M2); or_tac.
(* 13 *)
simpl in s. unfold factorable in H3; gen2_case H3 s (status M2); or_tac.
(* 12 *)
simpl in s.  gen_case s o.
(* 11 *)
simpl in s.  unfold compound in H3; gen2_case H3 s (status M2); or_tac.
(* 10 *)
simpl in s.  gen_case s o.
(* 9 *)
simpl in s. unfold compound in H3; gen2_case H3 s (status M2); or_tac.
simpl in s. unfold factorable in H2; gen2_case H2 s (status M2); or_tac.
simpl in s. unfold factorable in H2; gen2_case H2 s (status M2); or_tac.
simpl in s. unfold factorable in H2; gen2_case H2 s (status M2); or_tac.
simpl in s. unfold factorable in H2; gen2_case H2 s (status M2); or_tac.
simpl in s. unfold factorable in H2; gen2_case H2 s (status M2); or_tac.
simpl in s. unfold factorable in H2; gen2_case H2 s (status M2); or_tac.
simpl in s. unfold factorable in H2; gen2_case H2 s (status M2); or_tac.
simpl in s. unfold factorable in H2; gen2_case H2 s (status M2); or_tac.
Qed.

Lemma abs_irreducible :
forall M, irreducible M lamSF_red1 ->  irreducible (Abs M) lamSF_red1.
Proof. red; split_all. inversion H0. eapply2 H. Qed.

Lemma normal_is_irreducible:
forall M, normal M -> irreducible M lamSF_red1.
Proof.
intros M nor; induction nor; intros.
(* 4 *)
eapply2 ref_irreducible.
red; split_all. inversion H.
eapply2 abs_irreducible.
(* 1 *)
 assert((exists i, status (App M1 M2) = Active i \/ status (App M1 M2) = Lam i) \/
status (App M1 M2) = Ternary_op \/
status (App M1 M2) =  Binary_op0 \/
status (App M1 M2) = Binary_op2 \/
status (App M1 M2) =  Binary_op1 \/
status (App M1 M2) =  Ternary_op1 \/
status (App M1 M2) =  Unary_op \/
status (App M1 M2) = Lazy2 \/
status (App M1 M2) = Lazy1 \/
status (App M1 M2) = Eager2 \/
status (App M1 M2) = Eager).
gen_case H (status (App M1 M2)); eauto; auto 20.
(* 1 *)
inversion H0; split_all. inversion H2.
eapply2 active_irreducible.
simpl in H1. gen_case H1 (status M1); gen_case H1 (status M2).
(* 1 *)
inversion H1; split_all. inversion H2.
gen_case H4 (status M1); gen_case H4 (status M2).
(* 1 *)
inversion H2; split_all. inversion H3.
gen_case H5 (status M1); gen_case H5 (status M2).
(* 1 *)
inversion H3; split_all. inversion H4.
gen_case H6 (status M1); gen_case H6 (status M2).
(* 1 *)
inversion H4; split_all. inversion H5.
gen_case H7 (status M1); gen_case H7 (status M2).
(* 1 *)
inversion H5; split_all. inversion H6.
gen_case H8 M1. gen_case H8 o; intro; split_all; gen_case H8 (status M2).
gen_case H8 (status l); gen_case H8 n.
gen_case H8 (status l); gen_case H8 (status l0); gen_case H8 (status M2).
(* 1 *)
clear - IHnor1 IHnor2 H6.
inversion H6; split_all. inversion H.
gen3_case IHnor1 H H1 M1. gen3_case IHnor1 H H1 o;
try (intro; split_all;  inversion H0; inversion H5; eapply2 IHnor2; fail).
gen_case H (status M2).
gen2_case H H1 (status l); gen2_case H H1 n.
(* 2 *)
gen3_case IHnor1 H H1 l.  gen3_case IHnor1 H H1 o;
try (gen3_case IHnor1 H H1 (status l0); gen3_case IHnor1 H H1 (status M2); fail).
gen3_case IHnor1 H H1 (status l1); gen3_case IHnor1 H H1 n.
gen3_case IHnor1 H H1 (status l1).
(* 6 *)
 gen3_case IHnor1 H H1 (status l2);
 gen3_case IHnor1 H H1 (status l0).
 gen3_case IHnor1 H H1 (status l0).
 gen3_case IHnor1 H H1 (status M2).
gen3_case IHnor1 H H1 (status l0).
gen3_case IHnor1 H H1 (status l2).
(* 1 *)
inversion H.
inversion H0; split_all.
gen3_case IHnor1 H H2 M1. gen3_case IHnor1 H H2 o;
try(intro; split_all;  inversion H1; inversion H7; eapply2 IHnor2; fail).
gen2_case H H2 (status M2).
gen2_case H H2 (status l); gen2_case H H2 n.
(* 2 *)
gen3_case IHnor1 H H2 l.  gen3_case IHnor1 H H2 o;
try (gen3_case IHnor1 H H2 (status l0); fail);
try (intro; split_all;  inversion H1;
[ inversion H7; [  inversion H11 | eapply2 IHnor1] | eapply2 IHnor2]; fail).
(* 6 *)
gen3_case IHnor1 H H2 (status l0);  gen3_case IHnor1 H H2 (status M2).
(* 5 *)
gen3_case IHnor1 H H2 (status M2);  gen3_case IHnor1 H H2 n.
(* 4 *)
gen3_case IHnor1 H H2 (status M2).
(* 3 *)
gen3_case IHnor1 H H2 (status l1); gen3_case IHnor1 H H2 n.
(* 2 *)
gen3_case IHnor1 H H2 (status l1).
gen3_case IHnor1 H H2 (status l2);
gen3_case IHnor1 H H2 (status l0).
gen3_case IHnor1 H H2 (status l0).
gen3_case IHnor1 H H2 (status M2).
gen3_case IHnor1 H H2 (status l0).
gen3_case IHnor1 H H2 (status l2);
gen3_case IHnor1 H H2 (status l0).
(* 1 *)
inversion H0.
inversion H1; split_all.
gen3_case IHnor1 H1 H3 M1. gen3_case IHnor1 H1 H3 o;
try(intro; split_all;  inversion H2; inversion H8; eapply2 IHnor2; fail).
gen2_case H1 H3 (status M2).
gen2_case H1 H3 (status l); gen2_case H1 H3 n.
(* 2 *)
gen3_case IHnor1 H1 H3 l.  gen3_case IHnor1 H1 H3 o;
try (intro; intro; inv lamSF_red1; [eapply2 IHnor1 | eapply2 IHnor2]).
(* 6 *)
gen3_case IHnor1 H1 H3 (status l0);  gen3_case IHnor1 H1 H3 (status M2).
(* 5 *)
gen3_case IHnor1 H1 H3 (status M2);  gen3_case IHnor1 H1 H3 n.
(* 4 *)
gen3_case IHnor1 H1 H3 (status M2).
(* 3 *)
gen3_case IHnor1 H1 H3 (status l1); gen3_case IHnor1 H1 H3 n.
(* 2 *)
gen3_case IHnor1 H1 H3 (status l1).
gen3_case IHnor1 H1 H3 (status l2);
gen3_case IHnor1 H1 H3 (status l0).
gen3_case IHnor1 H1 H3 (status l0).
gen3_case IHnor1 H1 H3 (status M2).
gen3_case IHnor1 H1 H3 (status l0).
gen3_case IHnor1 H1 H3 (status l2);
gen3_case IHnor1 H1 H3 (status l0).
(* 1 *)
inversion H1; split_all.
(* 2 *)
gen3_case IHnor1 H1 H2 M1. gen3_case IHnor1 H1 H2 o;
try (intro; intro; inv lamSF_red1; eapply2 IHnor2).
(* 4 *)
gen3_case IHnor1 H1 H2 (status M2).
(* 3 *)
gen3_case IHnor1 H1 H2 (status l); gen3_case IHnor1 H1 H2 n.
(* 2 *)
gen3_case IHnor1 H1 H2 l.  gen3_case IHnor1 H1 H2 o.
(* 6 *)
gen2_case H1 H2 (status l0); gen2_case H1 H2 (status M2).
(* 5 *)
gen2_case H1 H2 (status M2).
gen2_case H1 H2 (status M2).
gen2_case H1 H2 (status l1); gen2_case H1 H2 n.
gen2_case H1 H2 (status l1).
gen3_case IHnor1 H1 H2 (status l2);
gen3_case IHnor1 H1 H2 (status l0).
gen3_case IHnor1 H1 H2 (status l0).
gen3_case IHnor1 H1 H2 (status M2).
gen3_case IHnor1 H1 H2 (status l0).
gen3_case IHnor1 H1 H2 (status l2);
gen3_case IHnor1 H1 H2 (status l0).
(* 1 *)
gen3_case IHnor1 H1 H2 M1. gen3_case IHnor1 H1 H2 o.
(* 5 *)
assert(exists o, M2 = Op o).
gen3_case IHnor1 H1 H2 M2; eauto.
gen3_case IHnor1 H1 H2 (status l); gen2_case H1 H2 n.
gen3_case IHnor1 H1 H2 (status l); gen3_case IHnor1 H1 H2 (status l0).
split_all. intro; intro; inv lamSF_red1.  inversion H9.
unfold compound in H7; gen_case H7 x; or_tac.
intro; intro; inv lamSF_red1.  eapply2 IHnor2.
intro; intro; inv lamSF_red1.  eapply2 IHnor2.
gen3_case IHnor1 H1 H2 (status l); gen2_case H1 H2 n.
(* 1 *)
gen2_case H1 H2 l.  gen3_case IHnor1 H1 H2 o;
try (intro; intro; inv lamSF_red1; try (eapply2 IHnor1; fail); try (eapply2 IHnor2; fail); fail).
(* 5 *)
gen3_case IHnor1 H1 H2 (status l0);
gen3_case IHnor1 H1 H2 (status M2) .
gen3_case IHnor1 H1 H2 (status M2).
gen3_case IHnor1 H1 H2 (status M2).
gen3_case IHnor1 H1 H2 (status l1); gen2_case H1 H2 n.
gen3_case IHnor1 H1 H2 (status l1).
gen3_case IHnor1 H1 H2 (status l2);
gen3_case IHnor1 H1 H2 (status l0).
gen3_case IHnor1 H1 H2 (status l0).
gen3_case IHnor1 H1 H2 (status M2).
gen3_case IHnor1 H1 H2 (status l0).
gen3_case IHnor1 H1 H2 (status l2);
gen3_case IHnor1 H1 H2 (status l0).
Grab Existential Variables.
apply s_op.
Qed.

Lemma normal_not_Reducible: forall M, normal M -> status M <> Reducible.
Proof.
intros; intro. elim(Reducible_implies_reducible M); split_all. eapply2 normal_is_irreducible.
Qed.

(*
The basic progress result, that all irreducible terms are normal.
 *)

Theorem progress :
forall (M : lamSF), normal M \/ (exists N, lamSF_red1 M N) .
Proof.
rank_tac.
induction M; try (inversion IHM); subst; split_all; eauto.
(* 2 *)
elim IHM; split_all; try omega.
right; exist (Abs x).
(* 1 *)
elim IHM1; elim IHM2; split_all; eauto; try omega.
clear IHp IHM1 IHM2 H.
inversion H1; subst; eauto.
(* 3 *)
left; eapply2 nf_app. split_all.
(* 2 *)
case o; try (left; eapply2 nf_app; simpl; split_all; unfold compound; or_tac; fail).
gen_case H0 M2; try (left; eapply2 nf_app; simpl; split_all; unfold compound; or_tac; fail).
left; eapply2 nf_app; simpl; split_all. case o0; split_all.
assert(status (Abs l) <> Reducible) by eapply2 normal_not_Reducible.
 assert((exists i, status (Abs l) = Active i \/ status (Abs l) = Lam i) \/ factorable (Abs l)).
unfold factorable. gen_case H (status (Abs l)); eauto; auto 20.
inversion H2; split_all.
inversion H4; left; eapply2 nf_app; simpl in *; rewrite H3; intro; discriminate.
elim(factorable_implies_compound_or_operator (Abs l)); split_all; subst; eauto.
(* 3 *)
inversion H0.
 assert((exists i, status (App l l0) = Active i \/ status (App l l0) = Lam i) \/
factorable(App l l0)). unfold factorable.
gen_case H5 (status (App l l0)); eauto; auto 20.
inversion H6; split_all.
inversion H8; left; eapply2 nf_app; split_all; intro; simpl in *; rewrite H7 in H9; discriminate.
(* 3 *)
elim(factorable_implies_compound_or_operator (App l l0)); split_all; subst; eauto.
(* 2 *)
eauto.
(* 1 *)
assert(status M2 <> Reducible) by eapply2 normal_not_Reducible.
assert(status M0 <> Reducible) by eapply2 normal_not_Reducible.
assert(status M3 <> Reducible) by eapply2 normal_not_Reducible.
assert((exists i, status M2 = Active i \/ status M2 = Lam i) \/ factorable M2).
unfold factorable. gen_case H4 (status M2); eauto; auto 20.
assert((exists i, status M0 = Active i \/ status M0 = Lam i) \/ factorable M0).
unfold factorable. gen_case H5 (status M0); eauto; auto 20.
assert((exists i, status M3 = Active i \/ status M3 = Lam i) \/ factorable M3).
unfold factorable. gen_case H6 (status M3); eauto; auto 20.
 assert((exists i, status (App M0 M3) = Active i \/ status (App M0 M3) = Lam i) \/
factorable (App M0 M3)). unfold factorable.
gen_case H3 (status (App M0 M3)); eauto; auto 20.
(* 1 *)
inversion H10; split_all.
inversion H12.
 left; eapply2 nf_app; simpl in *; intro;  rewrite H11 in *; discriminate.
assert(exists N, App M0 M3 = Abs N) by eapply2 lam_is_abs. split_all.
(* 1 *)
unfold factorable in H11. inversion H11; split_all. inversion H12.
gen_case H14 (status M0); gen_case H14 (status M3).
(* 1 *)
inversion H12; split_all. inversion H13.
gen_case H15 (status M0); gen_case H15 (status M3).
(* 1 *)
inversion H13; split_all. inversion H14.
gen_case H16 (status M0); gen_case H16 (status M3).
(* 1 *)
inversion H14; split_all. inversion H15.
gen_case H17 (status M0); gen_case H17 (status M3).
(* 1 *)
inversion H15; split_all. inversion H16.
gen_case H18 (status M0); gen_case H18 (status M3).
(* 1 *)
inversion H16; split_all. simpl in *.
gen_case H17 (status M0); gen_case H17 (status M3).
(* 1 *)
inversion H17; split_all. inversion H18.
gen_case H20 M0.  gen_case H20 o.
left; repeat eapply2 nf_app; simpl; split_all.
left; repeat eapply2 nf_app; simpl; split_all.
gen_case H20 (status M3).
right; eauto.
(* 2 *)
gen_case H20 l. gen_case H20 o; try (gen_case H20 (status l0); fail).
gen_case H20 (status l0); try (gen_case H20 (status M3); fail).
gen_case H20 (status M3).
gen_case H20 (status M3).
right; eauto.
gen_case H20 (status l1).
gen_case H20 (status l2); gen_case H20 (status l0).
gen_case H20 (status l0).
gen_case H20 (status M3).
gen_case H20 (status l0).
gen_case H20 (status l2).
(* 1 *)
inversion H18; split_all. inversion H19.
gen_case H21 M0.  gen_case H21 o.
right; eauto.
gen_case H21 (status M3).
right; eauto.
right; eauto.
gen_case H21 l.  gen_case H21 o; eauto.
gen_case H21 (status l0);  gen_case H21 (status M3).
gen_case H21 (status M3).
gen_case H21 (status M3).
eauto.
gen_case H21 (status l1).
gen_case H21 (status l2);  gen_case H21 (status l0).
gen_case H21 (status l0).
gen_case H21 (status M3).
gen_case H21 (status l0).
gen_case H21 (status l2).
(* 1 *)
inversion H19; split_all. inversion H20.
gen_case H22 M0.  gen_case H22 o; try (left; repeat eapply2 nf_app; simpl; split_all; fail).
gen_case H22 (status M3).
right; eauto.
gen_case H22 l.  gen_case H22 o; try (right; eauto; fail).
gen_case H22 (status l0);  gen_case H22 (status M3).
gen_case H22 (status M3).
gen_case H22 (status M3).
right; eauto.
gen_case H22 (status l1).
gen_case H22 (status l2);  gen_case H22 (status l0).
gen_case H22 (status l0).
gen_case H22 (status M3).
gen_case H22 (status l0).
gen_case H22 (status l2).
(* 1 *)
gen2_case H H20 M0.
(* 3 *)
gen_case H20 o; try (left; repeat eapply2 nf_app; simpl; split_all; fail).
(* 5 *)
assert(exists o, M3 = Op o).
gen_case H20 M3. eauto. gen_case H20 (status l); gen_case H20 n.
gen_case H20 (status l);  gen_case H20 (status l0).
(* 5 *)
split_all. subst.
inversion H7; split_all.
inversion H22;
left; repeat eapply2 nf_app; simpl; case x; auto; try (intro; discriminate); rewrite H21; auto;
 try (intro; discriminate).
assert(M2 = Op x \/ M2 <> Op x) by repeat decide equality.
inversion H22; right; subst;  eauto.
(* 4 *)
inversion H7; split_all.
inversion H22;
left; repeat eapply2 nf_app; simpl; case x; auto; try (intro; discriminate); rewrite H21; auto;
 try (intro; discriminate).
eauto.
(* 3 *)
inversion H7; split_all.
inversion H22;
left; repeat eapply2 nf_app; simpl; case x; auto; try (intro; discriminate); rewrite H21; auto;
 try (intro; discriminate).
elim(factorable_implies_compound_or_operator M2); split_all; subst; eauto.
(* 2 *)
right; eauto.
(* 1 *)
gen_case H20 l.  2: right; eauto.
gen_case H20 o; try (gen_case H20 (status M3); fail).

(* 11 *)
assert(exists o, l0 = Op o).
gen_case H20 l0. eauto. gen_case H20 (status l1); gen_case H20 n.
gen_case H20 (status l2);  gen_case H20 (status l1).
split_all. subst.
inversion H9; split_all.
inversion H22; left; repeat eapply2 nf_app; simpl; case x; auto; try (intro; discriminate);  rewrite H21; auto;
 try (intro; discriminate).
assert(M3 = Op x \/ M3 <> Op x) by repeat decide equality.
inversion H22; right; subst;  eauto.
(* 10 *)
inversion H7; split_all.
inversion H.
inversion H22; left; repeat eapply2 nf_app; simpl;  case x; auto; try (intro; discriminate); rewrite H27; auto;
 try (intro; discriminate).
elim(factorable_implies_compound_or_operator M2); split_all; subst; eauto.
(* 9 *)
inversion H7; split_all.  inversion H.
inversion H22; left; repeat eapply2 nf_app; simpl;  case x; auto; try (intro; discriminate);
 rewrite H27; auto;
 try (intro; discriminate).
assert(M2 = Op Sop \/ M2 <> Op Sop) by repeat decide equality.
inversion H22; right; subst;  eauto.
(* 8 *)
inversion H7; split_all.  inversion H.
inversion H22; left; repeat eapply2 nf_app; simpl;  case x; auto; try (intro; discriminate);
 rewrite H27; auto;
 try (intro; discriminate).
assert(M2 = Op Aop \/ M2 <> Op Aop) by repeat decide equality.
inversion H22; right; subst;  eauto.
(* 7 *)
inversion H7; split_all.  inversion H.
inversion H22; left; repeat eapply2 nf_app; simpl;  case x; auto; try (intro; discriminate);
 rewrite H27; auto;
 try (intro; discriminate).
assert(M2 = Op Kop \/ M2 <> Op Kop) by repeat decide equality.
inversion H22; right; subst;  eauto.
(* 6 *)
inversion H7; split_all.  inversion H.
inversion H22; left; repeat eapply2 nf_app; simpl;  case x; auto; try (intro; discriminate);
 rewrite H27; auto;
 try (intro; discriminate).
assert(M2 = Op Eop \/ M2 <> Op Eop) by repeat decide equality.
inversion H22; right; subst;  eauto.
(* 5 *)
inversion H7; split_all.  inversion H.
inversion H22; left; repeat eapply2 nf_app; simpl;  case x; auto; try (intro; discriminate);
 rewrite H27; auto;
 try (intro; discriminate).
assert(M2 = Op Gop \/ M2 <> Op Gop) by repeat decide equality.
inversion H22; right; subst;  eauto.
(* 4 *)
inversion H7; split_all.  inversion H.
inversion H22; left; repeat eapply2 nf_app; simpl;  case x; auto; try (intro; discriminate);
 rewrite H27; auto;
 try (intro; discriminate).
assert(M2 = Op Qop \/ M2 <> Op Qop) by repeat decide equality.
inversion H22; right; subst;  eauto.
(* 3 *)
inversion H7; split_all.  inversion H.
inversion H22; left; repeat eapply2 nf_app; simpl;  case x; auto; try (intro; discriminate);
 rewrite H27; auto;
 try (intro; discriminate).
assert(M2 = Op Uop \/ M2 <> Op Uop) by repeat decide equality.
inversion H22; right; subst;  eauto.
(* 2 *)
inversion H7; split_all.  inversion H.
inversion H22; left; repeat eapply2 nf_app; simpl;  case x; auto; try (intro; discriminate);
 rewrite H27; auto;
 try (intro; discriminate).
assert(M2 = Op Yop \/ M2 <> Op Yop) by repeat decide equality.
inversion H22; right; subst;  eauto.
(* 1 *)
gen_case H20 (status l1).
gen_case H20 (status l2); gen_case H20 (status l0).
 gen_case H20 (status l0).
 gen_case H20 (status M3).
 gen_case H20 (status l0).
gen_case H20 (status l2); gen_case H20 (status l0).
Qed.

Lemma irreducible_is_normal:
forall M, irreducible M lamSF_red1 -> normal M.
Proof. split_all. elim(progress M); split_all. assert False by eapply2 H; noway. Qed.

Theorem irreducible_iff_normal: forall M, irreducible M lamSF_red1 <-> normal M.
Proof. split_all. eapply2 irreducible_is_normal. eapply2 normal_is_irreducible. Qed.

Lemma normal_is_stable: forall M, normal M -> forall N, lamSF_red M N -> N = M.
Proof.
split_all.
inversion H0; inv1 lamSF_red.
assert False by eapply2 normal_is_irreducible. noway.
Qed.


Require Import Coq.PArith.BinPos Coq.PArith.Pnat.
Require Import Coq.Arith.Arith.
Require Import Coq.FSets.FMapInterface.
Require Import Coq.FSets.FMapPositive.
Require Import Fiat.Parsers.ContextFreeGrammar.Carriers.
Require Import Fiat.Common.List.ListFacts.
Require Import Fiat.Common.List.ListMorphisms.
Require Import Fiat.Common.Prod.

Set Implicit Arguments.

Definition nonterminal_to_positive (nt : default_nonterminal_carrierT) : positive
  := Pos.of_nat (S nt).
Definition positive_to_nonterminal (nt : positive) : default_nonterminal_carrierT
  := pred (Pos.to_nat nt).
Lemma positive_to_nonterminal_to_positive nt : nonterminal_to_positive (positive_to_nonterminal nt) = nt.
Proof.
  unfold nonterminal_to_positive, positive_to_nonterminal.
  erewrite <- S_pred by apply Pos2Nat.is_pos.
  rewrite Pos2Nat.id.
  reflexivity.
Qed.
Lemma nonterminal_to_positive_to_nonterminal nt : positive_to_nonterminal (nonterminal_to_positive nt) = nt.
Proof.
  unfold nonterminal_to_positive, positive_to_nonterminal.
  rewrite Nat2Pos.id_max; simpl.
  reflexivity.
Qed.
Lemma nonterminal_to_positive_eq x y
  : nonterminal_to_positive x = nonterminal_to_positive y <-> x = y.
Proof.
  split; try congruence.
  rewrite <- (nonterminal_to_positive_to_nonterminal x), <- (nonterminal_to_positive_to_nonterminal y) at 2.
  congruence.
Qed.
Lemma positive_to_nonterminal_eq x y
  : positive_to_nonterminal x = positive_to_nonterminal y <-> x = y.
Proof.
  split; try congruence.
  rewrite <- (positive_to_nonterminal_to_positive x), <- (positive_to_nonterminal_to_positive y) at 2.
  congruence.
Qed.
Lemma positive_to_nonterminal_eq_iff_l x y
  : positive_to_nonterminal x = y <-> x = nonterminal_to_positive y.
Proof.
  rewrite <- positive_to_nonterminal_eq, nonterminal_to_positive_to_nonterminal; reflexivity.
Qed.
Lemma positive_to_nonterminal_eq_iff_r x y
  : x = positive_to_nonterminal y <-> nonterminal_to_positive x = y.
Proof.
  rewrite <- positive_to_nonterminal_eq, nonterminal_to_positive_to_nonterminal; reflexivity.
Qed.

Local Ltac nonterminal_iff_t :=
  repeat match goal with
         | _ => intro
         | [ |- iff _ _ ] => split
         | [ |- prod _ _ ] => split
         | [ H : ex _ |- _ ] => destruct H
         | [ H : forall k : default_nonterminal_carrierT, _, k' : positive |- _ ]
           => specialize (H (positive_to_nonterminal k'))
         | [ H : forall k : positive, _, k' : default_nonterminal_carrierT |- _ ]
           => specialize (H (nonterminal_to_positive k'))
         | [ k' : positive |- exists k : default_nonterminal_carrierT, _ ]
           => exists (positive_to_nonterminal k')
         | [ k' : default_nonterminal_carrierT |- exists k : positive, _ ]
           => exists (nonterminal_to_positive k')
         | _ => assumption
         | _ => rewrite nonterminal_to_positive_to_nonterminal in *
         end.

Lemma forall_nonterminal_iffP (P : default_nonterminal_carrierT -> Prop)
  : (forall k, P k) <-> (forall k, P (positive_to_nonterminal k)).
Proof. nonterminal_iff_t. Qed.
Local Notation iffT A B := ((A -> B) * (B -> A))%type (only parsing).
Lemma forall_nonterminal_iffT (P : default_nonterminal_carrierT -> Type)
  : iffT (forall k, P k) (forall k, P (positive_to_nonterminal k)).
Proof. nonterminal_iff_t. Qed.
Lemma exists_nonterminal_iff (P : default_nonterminal_carrierT -> Prop)
  : (exists k, P k) <-> (exists k, P (positive_to_nonterminal k)).
Proof. nonterminal_iff_t. Qed.

Module NonTerminalMap <: WS.
  Module E <: DecidableType.
    Definition t := default_nonterminal_carrierT.
    Definition eq : t -> t -> Prop := eq.
    Definition eq_refl : forall x, eq x x := @eq_refl _.
    Definition eq_sym : forall x y, eq x y -> eq y x := @eq_sym _.
    Definition eq_trans : forall x y z, eq x y -> eq y z -> eq x z := @eq_trans _.
    Definition eq_dec : forall x y, {eq x y} + {~eq x y} := Nat.eq_dec.
  End E.
  Definition key := default_nonterminal_carrierT.
  Definition t := PositiveMap.t.
  Definition empty := PositiveMap.empty.
  Definition is_empty := PositiveMap.is_empty.
  Definition add elt (k : key) := @PositiveMap.add elt (nonterminal_to_positive k).
  Definition find elt (k : key) := @PositiveMap.find elt (nonterminal_to_positive k).
  Definition remove elt (k : key) := @PositiveMap.remove elt (nonterminal_to_positive k).
  Definition mem elt (k : key) := @PositiveMap.mem elt (nonterminal_to_positive k).
  Definition map := PositiveMap.map.
  Definition mapi elt elt' f := @PositiveMap.mapi elt elt' (fun k => f (positive_to_nonterminal k)).
  Definition map2 := PositiveMap.map2.
  Definition elements elt (m : t elt) : list (key * elt)
    := List.map (fun xy => (positive_to_nonterminal (fst xy), snd xy)) (PositiveMap.elements m).
  Definition cardinal := PositiveMap.cardinal.
  Definition fold elt A (f : key -> elt -> A -> A)
    := @PositiveMap.fold elt A (fun k => f (positive_to_nonterminal k)).
  Definition equal := PositiveMap.equal.
  Definition MapsTo elt (k : key) := @PositiveMap.MapsTo elt (nonterminal_to_positive k).
  Definition In elt (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m.
  Definition Empty elt m := forall (a : key)(e:elt) , ~ MapsTo a e m.
  Definition eq_key elt (p p':key*elt) := E.eq (fst p) (fst p').
  Definition eq_key_elt elt (p p':key*elt) :=
    E.eq (fst p) (fst p') /\ (snd p) = (snd p').

  Definition Equal elt (m m' : t elt) := forall y, find y m = find y m'.
  Definition Equiv elt (eq_elt:elt->elt->Prop) m m' :=
    (forall k, In k m <-> In k m') /\
    (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
  Definition Equivb elt (cmp: elt->elt->bool) := Equiv (Cmp cmp).

  Definition MapsTo_iff1 elt k v (m : t elt) : MapsTo k v m <-> PositiveMap.MapsTo (nonterminal_to_positive k) v m
    := reflexivity _.
  Lemma MapsTo_iff2 elt k v (m : t elt) : MapsTo (positive_to_nonterminal k) v m <-> PositiveMap.MapsTo k v m.
  Proof.
    unfold MapsTo.
    rewrite positive_to_nonterminal_to_positive; reflexivity.
  Qed.

  Lemma Empty_iff elt (m : t elt) : Empty m <-> PositiveMap.Empty m.
  Proof.
    unfold Empty, PositiveMap.Empty, key, MapsTo.
    rewrite forall_nonterminal_iffP.
    setoid_rewrite positive_to_nonterminal_to_positive; reflexivity.
  Qed.

  Local Ltac t_app :=
    first [ reflexivity
          | apply PositiveMap.find_1
          | apply PositiveMap.find_2
          | apply PositiveMap.MapsTo_1
          | apply PositiveMap.empty_1
          | apply PositiveMap.is_empty_1
          | apply PositiveMap.is_empty_2
          | apply PositiveMap.add_1
          | apply PositiveMap.add_2
          | apply PositiveMap.add_3
          | apply PositiveMap.remove_1
          | apply PositiveMap.remove_2
          | apply PositiveMap.remove_3
          | apply PositiveMap.map_1
          | apply PositiveMap.map_2
          | apply PositiveMap.elements_1
          | apply PositiveMap.elements_2
          | apply PositiveMap.elements_3w
          | apply PositiveMap.cardinal_1
          | apply PositiveMap.fold_1
          | apply PositiveMap.equal_1
          | apply PositiveMap.equal_2
          | refine (PositiveMap.mapi_1 _)
          | refine (PositiveMap.mapi_2 _ _)
          | apply PositiveMap.map2_1
          | apply PositiveMap.map2_2
          | intro; t_app ].
  Local Ltac conv :=
    clear;
    repeat match goal with k : key |- _ => revert k end;
    cbv [E.eq MapsTo Empty add remove In find eq_key_elt elements eq_key] in *;
    repeat first [ progress rewrite
                            ?forall_nonterminal_iffP,
                   ?exists_nonterminal_iff,
                   ?positive_to_nonterminal_to_positive,
                   ?nonterminal_to_positive_to_nonterminal,
                   ?positive_to_nonterminal_eq_iff_l,
                   ?positive_to_nonterminal_eq_iff_r,
                   ?NoDupA_map_iff,
                   ?map_length
                 | setoid_rewrite forall_nonterminal_iffP
                 | setoid_rewrite exists_nonterminal_iff
                 | setoid_rewrite positive_to_nonterminal_to_positive
                 | setoid_rewrite nonterminal_to_positive_to_nonterminal
                 | setoid_rewrite positive_to_nonterminal_eq_iff_l
                 | setoid_rewrite positive_to_nonterminal_eq_iff_r
                 | rewrite (@InA_map_iff _ _ _ _ _ _ (_, _)) by reflexivity
                 | rewrite <- fold_map
                 | progress simpl @fst in *
                 | progress simpl @snd in *
                 | lazymatch goal with
                   | [ |- ?A -> ?B ] => fail
                   | [ |- forall x, _ ] => intro
                   end ].
  Local Ltac t := conv; t_app.

  Section Spec.
    Context (elt elt' elt'' : Type)
            (m m' m'' : t elt)
            (x y z : key)
            (e e' : elt).

    Lemma MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m.
    Proof. t. Qed.
    Definition mem_1 : In x m -> mem x m = true := @PositiveMap.mem_1 _ _ _.
    Definition mem_2 : mem x m = true -> In x m := @PositiveMap.mem_2 _ _ _.
    Lemma empty_1 : Empty (empty elt).
    Proof. t. Qed.
    Lemma is_empty_1 : Empty m -> is_empty m = true.
    Proof. t. Qed.
    Lemma is_empty_2 : is_empty m = true -> Empty m.
    Proof. t. Qed.
    Lemma add_1 : E.eq x y -> MapsTo y e (add x e m).
    Proof. t. Qed.
    Lemma add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
    Proof. t. Qed.
    Lemma add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
    Proof. t. Qed.
    Lemma remove_1 : E.eq x y -> ~ In y (remove x m).
    Proof. t. Qed.
    Lemma remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
    Proof. t. Qed.
    Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.
    Proof. t. Qed.
    Lemma find_1 : MapsTo x e m -> find x m = Some e.
    Proof. t. Qed.
    Lemma find_2 : find x m = Some e -> MapsTo x e m.
    Proof. t. Qed.
    Lemma elements_1 :
      MapsTo x e m -> InA (@eq_key_elt _) (x,e) (elements m).
    Proof. t. Qed.
    Lemma elements_2 :
      InA (@eq_key_elt _) (x,e) (elements m) -> MapsTo x e m.
    Proof. t. Qed.
    Lemma elements_3w : NoDupA (@eq_key _) (elements m).
    Proof. t. Qed.
    Local Ltac elements_n_eq lem :=
      let H := fresh in
      intro H; first [ apply lem in H | apply lem ];
      cbv [eq_key_elt E.eq] in *;
      repeat match goal with
             | _ => assumption
             | _
               => first [ setoid_rewrite prod_and_iff
                        | setoid_rewrite <- path_prod_uncurried_iff
                        | rewrite Common.InA_In_eq ]
             | [ H : _ |- _ ]
               => first [ setoid_rewrite prod_and_iff in H
                        | setoid_rewrite <- path_prod_uncurried_iff in H
                        | rewrite Common.InA_In_eq in H ]
             end.

    Lemma elements_1_eq :
      MapsTo x e m -> List.In (x,e) (elements m).
    Proof. elements_n_eq elements_1. Qed.
    Lemma elements_2_eq :
      List.In (x,e) (elements m) -> MapsTo x e m.
    Proof. elements_n_eq elements_2. Qed.
    Lemma find_elements_iff
      : find x m = Some e <-> List.In (x, e) (elements m).
    Proof.
      split; intro H;
        [ apply elements_1_eq, find_2, H
        | apply find_1, elements_2_eq, H ].
    Qed.
    Lemma cardinal_1 : cardinal m = length (elements m).
    Proof. t. Qed.
    Lemma fold_1 :
      forall (A : Type) (i : A) (f : key -> elt -> A -> A),
        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
    Proof. t. Qed.

    Variable cmp : elt -> elt -> bool.

    Lemma Equal_iff (m0 m1 : t elt) : Equal m0 m1 <-> PositiveMap.Equal m0 m1.
    Proof. unfold Equal, PositiveMap.Equal; t. Qed.
    Lemma Equiv_iff eq_elt (m0 m1 : t elt) : Equiv eq_elt m0 m1 <-> PositiveMap.Equiv eq_elt m0 m1.
    Proof. unfold Equiv, PositiveMap.Equiv, In, PositiveMap.In; t. Qed.
    Lemma equal_1 : Equivb cmp m m' -> equal cmp m m' = true.
    Proof. unfold Equivb. rewrite Equiv_iff; t. Qed.
    Lemma equal_2 : equal cmp m m' = true -> Equivb cmp m m'.
    Proof. unfold Equivb; rewrite Equiv_iff; t. Qed.
  End Spec.

  Lemma elements_find_iff elt kv (m : t elt)
    : List.In kv (elements m) <-> find (fst kv) m = Some (snd kv).
  Proof.
    destruct kv; symmetry; apply find_elements_iff.
  Qed.

  Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
      MapsTo x e m -> MapsTo x (f e) (map f m).
  Proof. t. Qed.
  Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
      In x (map f m) -> In x m.
  Proof. t. Qed.
  Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
                        (f:key->elt->elt'), MapsTo x e m ->
                                            exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
  Proof. t. Qed.
  Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
                        (f:key->elt->elt'), In x (mapi f m) -> In x m.
  Proof. t. Qed.
  Lemma mapi_1_eq
        (elt elt':Type)(m: t elt)(x:key)(e:elt)
        (f:key->elt->elt')
    : MapsTo x e m -> MapsTo x (f x e) (mapi f m).
  Proof.
    intro H; eapply mapi_1 in H; unfold E.eq in *.
    destruct H as [? [? ?]]; subst; eassumption.
  Qed.
  Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
	                (x:key)(f:option elt->option elt'->option elt''),
      In x m \/ In x m' ->
      find x (map2 f m m') = f (find x m) (find x m').
  Proof. t. Qed.
  Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
	                (x:key)(f:option elt->option elt'->option elt''),
      In x (map2 f m m') -> In x m \/ In x m'.
  Proof. t. Qed.
End NonTerminalMap.


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 A B C D P Q M N : Universe, ((wd_ P Q /\ (wd_ A D /\ (wd_ M P /\ (wd_ M Q /\ (wd_ A B /\ (wd_ A C /\ (wd_ D B /\ (wd_ D C /\ (wd_ B C /\ (wd_ M A /\ (wd_ M C /\ (wd_ P A /\ (wd_ P B /\ (wd_ N P /\ (wd_ N A /\ (wd_ Q C /\ (wd_ Q D /\ (wd_ N Q /\ (wd_ N D /\ (wd_ M B /\ (wd_ M D /\ (col_ N Q D /\ (col_ N P A /\ (col_ M P Q /\ (col_ M B D /\ (col_ M A C /\ (col_ Q C D /\ col_ P A B))))))))))))))))))))))))))) -> col_ N A B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj16synthconj1 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus lv0 lv1) lv2) (plus (plus lv1 lv2) lv0)).
Admitted.
QuickChick conj16synthconj1.