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.