Set Implicit Arguments.

Require U.
Require Import monoid_expec.
Require Import expec.
Require Import qs_definitions.
Import mon_nondet.
Require Import List.
Require Import util.
Require Import monads.
Require Import list_utils.
Require Import indices.
Require Import monoid_monad_trans.
Require Import sums_and_averages.
Require qs_parts.
Require Import Rdefinitions.
Require Import nat_seqs.
Require Import sort_order.
Require NDP.
Require Import nat_below.
Require Import Bvector.
Require vec.

Arguments length {A}.
Arguments fst {A} {B}.

Section contents.

  Variables (ee: E) (ol: list ee).

  Lemma simpler_same_values l d c:
    proj1_sig (simplerPartition ee (subscript d) (map (subscript (T:=ee) (ol:=ol)) l)) c =
    map (subscript (T:=ee) (ol:=ol)) (proj1_sig (simplerPartition (UE ee ol) d l) c).
  Proof with auto.
    induction l...
    simpl.
    intros.
    simpl.
    rewrite IHl.
    destruct (cmp_cmp (Ecmp ee (subscript a) (subscript d)) c)...
  Qed.

  Theorem qs_CM_U_map_cost_eq (l: list (Index ee ol)):
    ne_tree.map (fst (A:=_:Set)(B:=_:Set)) (NDP.qs ee (map (@subscript ee ol) l))
    = ne_tree.map (@length (_:Set) ∘ (@fst (_:Set) (_:Set))) (U.qs l).
  Proof with auto.
    unfold NDP.qs, U.qs.
    pattern l, (qs (@U.cmp ee ol) U.pick l).
    apply qs_parts.rect...
      apply U.Mext.
    clear l.
    intros.
    rewrite qs_parts.toBody.
      Focus 2.
      apply NDP.Mext.
    rewrite vec.List_map.
    rewrite (vec.vec_round_trip (vec.map (@subscript _ _) v) (qs_parts.body NDP.M NDP.pick (NDP.cmp ee))).
    rewrite qs_parts.toBody_cons.
    unfold qs_parts.selectPivotPart.
    unfold qs_parts.partitionPart.
    unfold qs_parts.lowRecPart.
    simpl.
    repeat rewrite ne_list.map_map.
    f_equal.
    unfold compose.
    apply ne_list.map_ext.
    intro.
    repeat rewrite ne_tree_monad.map_bind.
    repeat rewrite (@mon_assoc ne_tree_monad.M).
    simpl.
    repeat rewrite ne_tree_monad.map_bind.
    repeat rewrite (@mon_assoc ne_tree_monad.M).
    rewrite NDP.partition.
    rewrite U.partition.
    simpl.
    repeat rewrite (@mon_assoc ne_tree_monad.M).
    apply ne_tree_monad.bind_eq with nat (@fst nat (list ee)) (fun x: prod U.monoid (list (Index ee ol)) => length (fst x)).
      simpl.
      intros.
      repeat rewrite (@mon_assoc ne_tree_monad.M).
      simpl.
      apply (ne_tree_monad.bind_eq) with nat (@fst nat (list ee)) (fun x: prod U.monoid (list (Index ee ol)) => length (fst x)).
        intros.
        simpl.
        unfold compose.
        simpl.
        repeat rewrite app_length.
        f_equal.
        rewrite map_length.
        repeat rewrite vec.length.
        rewrite H0, H1...
      unfold compose in H.
      simpl monoid_type in *.
      rewrite <- H.
        f_equal.
        rewrite vec.nth_map.
        rewrite vec.remove_map.
        rewrite <- vec.List_map.
        rewrite simpler_same_values...
      rewrite (@U.simplePartition_component (UE ee ol)).
      rewrite length_filter.
      apply le_lt_trans with (length (vec.remove v x))...
      rewrite vec.length...
    rewrite <- H.
      f_equal.
      rewrite vec.nth_map.
      rewrite vec.remove_map.
      rewrite <- vec.List_map.
      rewrite simpler_same_values...
    rewrite (@U.simplePartition_component (UE ee ol)).
    rewrite length_filter.
    apply le_lt_trans with (length (vec.remove v x))...
    rewrite vec.length...
  Qed.

  Theorem qs_CM_U_expec_cost_eq (tl: list (Index ee ol)):
    expec cost (NDP.qs ee (map (@subscript ee ol) tl))
    = monoid_expec (m:=U.monoid) length (U.qs tl).
  Proof with try reflexivity.
    unfold monoid_expec.
    unfold expec, compose.
    intros.
    f_equal.
    rewrite <- (ne_tree.map_map (@fst NatAddMonoid (list ee)) Raxioms.INR).
    rewrite (qs_CM_U_map_cost_eq tl).
    rewrite ne_tree.map_map...
  Qed.

End contents.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ZArith_ext seq_ext uniq_tac machine_int multi_int.
Import MachineInt.
Require Import mips_seplog mips_frame mips_tactics mips_contrib mapstos.
Require Import multi_zero_s_prg multi_zero_u_triple multi_negate_triple.
Import expr_m.
Import assert_m.

Local Open Scope heap_scope.
Local Open Scope mips_expr_scope.
Local Open Scope mips_assert_scope.
Local Open Scope mips_hoare_scope.
Local Open Scope machine_int_scope.
Local Open Scope zarith_ext_scope.
Local Open Scope uniq_scope.

Lemma multi_zero_s'_triple rx a0 a1 a2 a3 : uniq(rx, a0, a1, a2, a3, r0) ->
  forall nk X vx ptr, size X = nk ->
    u2Z vx + 4 * 2 < Zbeta 1 ->
    u2Z ptr + 4 * Z_of_nat nk < Zbeta 1 ->
  {{ fun s h => [ rx ]_s = vx /\
     (var_e rx |--> Z2u 32 (Z_of_nat nk) :: ptr :: nil ** int_e ptr |--> X) s h }}
  multi_zero_s' rx a0 a1 a2 a3
  {{ fun s h => [ rx ]_s = vx /\
      [ a0 ]_s = Z2u 32 (Z_of_nat nk) /\
     (var_e rx |--> Z2u 32 (Z_of_nat nk) :: ptr :: nil ** int_e ptr |--> nseq nk zero32) s h }}.
Proof.
move=> regs nk X vx ptr len_X vx_fit ptr_fit.
rewrite /multi_zero_s.

(** lw a0 zero16 rx *)

apply mips_contrib.hoare_lw_back_alt'' with (fun s h => [rx ]_ s = vx /\
  (var_e rx |--> Z2u 32 (Z_of_nat nk) :: ptr :: nil ** int_e ptr |--> X) s h /\
  u2Z [ a0 ]_ s = Z_of_nat nk).
move=> s h [Hx mem].
exists (Z2u 32 (Z_of_nat nk)); split.
- rewrite /= assert_m.conAE in mem.
  move: mem; apply assert_m.monotony => // h'.
  apply assert_m.mapsto_ext => //.
  by rewrite sext_Z2u //= addi0.
- rewrite /mips_contrib.update_store_lw.
  repeat Reg_upd.
  repeat (split=> //).
  move: mem; apply assert_m.monotony => // h'.
  apply assert_m.mapstos_ext => //=.
  by Reg_upd.
  apply assert_m.mapstos_ext => //.
  rewrite Z2uK // -Zbeta1E.
  split; first exact: Zle_0_nat.
  move: (min_u2Z ptr) => ?; lia.

(** lw a1 four16 rx *)

apply mips_contrib.hoare_lw_back_alt'' with (fun s h => [rx ]_ s = vx /\
  (var_e rx |--> Z2u 32 (Z_of_nat nk) :: ptr :: List.nil ** int_e ptr |--> X) s h /\
  u2Z [ a0 ]_ s = Z_of_nat nk /\ [ a1 ]_ s = ptr).
move=> s h [Hx [mem Ha0]].
exists ptr; split.
- rewrite /= assert_m.conAE assert_m.conCE assert_m.conAE in mem.
  move: mem; apply assert_m.monotony => // h' mem.
  case: mem => h1 [h2 [Hdisj [Hunion [Hh1 [Hh2 H']]]]].
  rewrite /assert_m.emp in H'; subst h2.
  rewrite heap.unionhe in Hunion; subst h'.
  move: Hh1; apply assert_m.mapsto_ext => //=.
  by rewrite sext_Z2u //.
- rewrite /mips_contrib.update_store_lw.
  repeat Reg_upd.
  repeat (split => //).
  move: mem; apply assert_m.monotony => // h'.
  apply assert_m.mapstos_ext => //=.
  by Reg_upd.
  by apply assert_m.mapstos_ext.

(** multi_zero a0 a1 a2 a3 *)

apply (before_frame
  (fun s h => [rx ]_ s = vx /\ (var_e rx |--> Z2u 32 (Z_of_nat nk) :: ptr :: nil) s h)
  (fun s h => [a1]_s = ptr /\ u2Z [a0]_s = Z_of_nat nk /\ (var_e a1 |--> X) s h)
  (fun s h => [a1]_s = ptr /\ u2Z [a0]_s = Z_of_nat nk /\ (var_e a1 |--> nseq nk zero32) s h)).

- apply mips_frame.frame_rule_R.
  apply multi_zero_u_triple => //; by Uniq_uniq r0.
  by Inde_frame.
  by move=> ?; Inde_mult.
- rewrite /while.entails => s h [Hx [mem [Ha0 Ha1]]].
  case: mem => h1 [h2 [Hdisj [Hunion [Hh1 Hh2]]]].
  Compose_sepcon h2 h1.
  repeat (split=> //).
  move: Hh2; by apply assert_m.mapstos_ext.
  by repeat (split=> //).
- rewrite /while.entails => s h mem.
  case: mem => h1 [h2 [Hdisj [Hunion [[Ha1 [Ha0 Hh1]] [Hrx Hh2]]]]].
  split; first by assumption.
  split.
    apply u2Z_inj.
    rewrite Ha0 Z2uK //.
    split; first by apply Zle_0_nat.
    rewrite -Zbeta1E; move: (min_u2Z ptr) => ?; lia.
  Compose_sepcon h2 h1; first by [].
  move: Hh1; by apply assert_m.mapstos_ext.
Qed.

Lemma multi_zero_s_triple rx : uniq(rx, r0) -> forall X ptr slen,
  {{ var_e rx |--> slen :: ptr :: nil ** int_e ptr |--> X }}
  multi_zero_s rx
  {{ var_e rx |--> zero32 :: ptr :: nil ** int_e ptr |--> X }}.
Proof.
move=> Hnodup X ptr slen.
rewrite /multi_zero_s.
apply hoare_sw_back'.
move=> s h Hmem.
exists (int_e slen).
rewrite /= assert_m.conAE in Hmem.
move: Hmem; apply monotony => h'.
  apply mapsto_ext => //.
  by rewrite /= sext_Z2u // addi0.
apply currying => h'' Hmem.
rewrite assert_m.conCE !assert_m.conAE in Hmem.
move: Hmem => /=.
rewrite !assert_m.conAE.
apply monotony => h3 //.
apply mapsto_ext => /=.
  by rewrite sext_Z2u // addi0.
by rewrite store.get_r0.
Qed.


From Coq Require Import String List Peano Arith Program.Equality Nat
Psatz Arith.PeanoNat Program.Equality.

From DanTrick Require Import StackLogic DanLogHoare DanTrickLanguage EnvToStack StackLanguage DanLogProp LogicProp StackLangTheorems StackLogicBase.
From DanTrick Require Import LogicTranslationBackwards StackLogicBase TranslationPure LogicTranslationAdequate LogicTrans.
From DanTrick Require Export ProofSubstitution ImpVarMapTheorems DanLogSubstAdequate.
From DanTrick Require Import DanImpHigherOrderRel DanImpHigherOrderRelTheorems CompilerCorrect StackFrame1 StackPure.

(*
 *
 *)

Local Open Scope string_scope.
Local Open Scope nat_scope.
Local Open Scope list_scope.
Local Open Scope dantrick_scope.

Lemma same_after_popping_extend :
  forall stk' n stk rho,
  same_after_popping stk stk' n ->
  same_after_popping (stk ++ rho) (stk' ++ rho) n.
Proof.
  induction stk'; intros.
  - invs H. constructor. apply eq_refl.
  - invs H.
    + invs H. constructor. apply eq_refl.
    + specialize (IHstk' n0 stk rho H4).
      assert (((a :: stk') ++ rho) = (a :: stk' ++ rho)) by auto.
      rewrite H0.
      constructor.
      apply IHstk'.
Qed.

Check imp_stack_mutind.

Lemma stk_determ_extend :
  (forall a fenv stk stk',
    imp_stack_sem a fenv stk (stk') ->
      forall rho,
        imp_stack_sem a fenv (stk++rho) ((stk'++rho)))
  /\
  (forall a fenv stk stk',
      aexp_stack_sem a fenv stk stk' ->
      forall rho stk'' n,
        stk' = (stk'', n) ->
        aexp_stack_sem a fenv (stk++rho) ((stk''++rho), n))
  /\
  (forall a fenv stk stk',
      bexp_stack_sem a fenv stk (stk') ->
      forall rho stk'' n,
        stk' = (stk'', n) ->
        bexp_stack_sem a fenv (stk++rho) ((stk''++rho), n))
  /\
  (forall a fenv stk stk',
    args_stack_sem a fenv stk stk' ->
    forall rho stk'' ns,
      stk' = (stk'', ns) ->
      args_stack_sem a fenv (stk++rho) ((stk''++rho, ns)))
.
Proof.
  pose (fun a fenv stk stk'=>
    (fun (i : imp_stack_sem a fenv stk stk') =>
      forall rho,
        imp_stack_sem a fenv (stk++rho) ((stk'++rho))))
    as P.
  pose (fun a fenv stk stk' =>
    (fun (i0 : aexp_stack_sem a fenv stk stk') =>
          forall rho stk'' n,
            stk' = (stk'', n) ->
              aexp_stack_sem a fenv (stk++rho) ((stk''++rho), n)))
      as P0.
  pose (fun a fenv stk stk' =>
    (fun (i1 : bexp_stack_sem a fenv stk stk') =>
          forall rho stk'' n,
            stk' = (stk'', n) ->
              bexp_stack_sem a fenv (stk++rho) ((stk''++rho), n)))
      as P1.
  pose (fun a fenv stk stk' =>
    (fun (i1 : args_stack_sem a fenv stk stk') =>
          forall rho stk'' n,
            stk' = (stk'', n) ->
              args_stack_sem a fenv (stk++rho) ((stk''++rho), n)))
      as P2.
  apply (imp_stack_mutind P P0 P1 P2); unfold P, P0, P1, P2 in *; intros.
  - constructor.
  - econstructor.
    + apply l.
    + invs s.
      --rewrite app_length. simpl. lia.
      --rewrite app_length. simpl. lia.
    + apply (H rho stk' c eq_refl).
    + apply stack_mutated_at_index_preserved_by_superlist.
      apply s.
  - rewrite e. constructor. apply eq_refl.
  - rewrite e. econstructor. exists.
  - econstructor.
    apply H. apply H0.
  - econstructor.
    apply H. exists. apply H0.
  - eapply Stack_if_false.
    apply H. exists. apply H0.
  - eapply Stack_while_done. apply H. apply eq_refl.
  - eapply Stack_while_step.
    + apply H. exists.
    + apply H0.
    + apply H1.
  - invs H. constructor.
  - invs H. constructor; try assumption.
    + rewrite app_length. lia.
    + pose proof (nth_error_app1 stk'' rho).
      specialize (H0 (i - 1)).
      destruct H0. lia. apply e.
  - specialize (H rho stk1 n1 eq_refl).
    specialize (H0 rho stk2 n2 eq_refl).
    pose proof Stack_plus fenv (stk++rho) a1 a2 (stk1++rho) (stk2++rho) n1 n2 H H0.
    invs H1. assumption.
  - specialize (H rho stk1 n1 eq_refl).
    specialize (H0 rho stk2 n2 eq_refl).
    pose proof Stack_minus fenv (stk++rho) a1 a2 (stk1++rho) (stk2++rho) n1 n2 H H0.
    invs H1. assumption.
  - econstructor.
    + apply e.
    + apply e0.
    + apply e1.
    + apply e2.
    + apply e3.
    + apply H. exists.
    + specialize (H0 rho).
      assert (((vals ++ stk1) ++ rho) = (vals ++ stk1 ++ rho)) by (symmetry;apply app_assoc).
      rewrite <- H3. apply H0.
    + invs H2. apply H1.
      exists.
    + apply same_after_popping_extend. invs H2. assumption.
  - invs H. apply Stack_true.
  - invs H. apply Stack_false.
  - econstructor.
    + invs H0. apply H. exists.
    + invs H0. apply eq_refl.
  - econstructor.
    + apply H. exists.
    + invs H1. apply H0. exists.
    + invs H1. apply eq_refl.
  - econstructor.
    + apply H. exists.
    + invs H1. apply H0. exists.
    + invs H1. apply eq_refl.
  - econstructor.
    + apply H. exists.
    + invs H1. apply H0. exists.
    + invs H1. apply eq_refl.
  - econstructor.
    + apply H. exists.
    + invs H1. apply H0. exists.
    + invs H1. apply eq_refl.
  - invs H. constructor.
  - invs H1. econstructor.
    + apply H. exists.
    + apply H0. apply eq_refl.
Qed.

Lemma aexp_stk_determ_extend :
  forall a n stk fenv rho,
    aexp_stack_sem a fenv stk (stk, n) ->
    aexp_stack_sem a fenv (stk++rho) ((stk++rho), n).
Proof.
  intros.
  pose proof stk_determ_extend.
  destruct H0. destruct H1.
  clear H2.
  apply (H1 a fenv stk (stk, n) H rho stk n eq_refl).
Qed.

Lemma bexp_stk_determ_extend :
  forall a n stk fenv rho,
    bexp_stack_sem a fenv stk (stk, n) ->
    bexp_stack_sem a fenv (stk++rho) ((stk++rho), n).
Proof.
  intros.
  pose proof stk_determ_extend.
  destruct H0. destruct H1. destruct H2.
  clear H3.
  apply (H2 a fenv stk (stk, n) H rho stk n eq_refl).
Qed.

Lemma args_stk_determ_extend :
(forall a ns fenv stk stk' rho,
args_stack_sem a fenv stk (stk', ns) ->
args_stack_sem a fenv (stk++rho) ((stk'++rho, ns))).
Proof.
  intros. pose proof stk_determ_extend.
  destruct H0. destruct H1. destruct H2.
  apply (H3 a fenv stk (stk', ns) H rho stk' ns eq_refl).
Qed.

Lemma nat_args_stk_determ_extend :
forall a_list fenv stk rho vals,
  (eval_prop_args_rel
    (fun (natexpr : aexp_stack) (natval : nat) =>
    aexp_stack_sem natexpr fenv stk (stk, natval)) a_list vals) ->
  (eval_prop_args_rel
  (fun (natexpr : aexp_stack) (natval : nat) =>
   aexp_stack_sem natexpr fenv (stk ++ rho) (stk ++ rho, natval)) a_list vals).
Proof.
  induction a_list; intros.
  - invs H. constructor.
  - invs H. specialize (IHa_list fenv stk rho vals0 H5).
    constructor. apply (aexp_stk_determ_extend a val stk fenv rho H3).
    apply IHa_list.
Qed.

Lemma bool_args_stk_determ_extend :
forall a_list fenv stk rho vals,
(eval_prop_args_rel (fun (boolexpr : bexp_stack) (boolval : bool) =>
bexp_stack_sem boolexpr fenv (stk) (stk, boolval))
a_list vals) ->
(eval_prop_args_rel (fun (boolexpr : bexp_stack) (boolval : bool) =>
bexp_stack_sem boolexpr fenv (stk ++ rho) (stk ++ rho, boolval))
a_list vals).
Proof.
  induction a_list; intros.
  - invs H. constructor.
  - invs H. specialize (IHa_list fenv stk rho vals0 H5).
    constructor. apply (bexp_stk_determ_extend a val stk fenv rho H3).
    apply IHa_list.
Qed.


(****************************************************************************)
(*                                                                          *)
(*                                   Menhir                                 *)
(*                                                                          *)
(*           Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud         *)
(*                                                                          *)
(*  Copyright Inria. All rights reserved. This file is distributed under    *)
(*  the terms of the GNU Lesser General Public License as published by the  *)
(*  Free Software Foundation, either version 3 of the License, or (at your  *)
(*  option) any later version, as described in the file LICENSE.            *)
(*                                                                          *)
(****************************************************************************)

Require Grammar Automaton Interpreter_correct Interpreter_complete.
From Coq Require Import Syntax Arith.

Module Make(Export Aut:Automaton.T).
Export Aut.Gram.
Export Aut.GramDefs.

Module Import Inter := Interpreter.Make Aut.
Module Correct := Interpreter_correct.Make Aut Inter.
Module Complete := Interpreter_complete.Make Aut Inter.

Definition complete_validator:unit->bool := Complete.Valid.is_complete.
Definition safe_validator:unit->bool := ValidSafe.is_safe.
Definition parse (safe:safe_validator ()=true) init log_n_steps buffer :
  parse_result (symbol_semantic_type (NT (start_nt init))):=
  parse (ValidSafe.safe_is_validator safe) init buffer log_n_steps.

(** Correction theorem. **)
Theorem parse_correct
  (safe:safe_validator ()= true) init log_n_steps buffer:
  match parse safe init log_n_steps buffer with
    | Parsed_pr sem buffer_new =>
      exists word (pt : parse_tree (NT (start_nt init)) word),
        buffer = (word ++ buffer_new)%buf /\
        pt_sem pt = sem
    | _ => True
  end.
Proof. apply Correct.parse_correct. Qed.

(** Completeness theorem. **)
Theorem parse_complete
  (safe:safe_validator () = true) init log_n_steps word buffer_end:
  complete_validator () = true ->
  forall tree:parse_tree (NT (start_nt init)) word,
  match parse safe init log_n_steps (word ++ buffer_end) with
  | Fail_pr => False
  | Parsed_pr sem_res buffer_end_res =>
    sem_res = pt_sem tree /\ buffer_end_res = buffer_end /\
    pt_size tree <= 2^log_n_steps
  | Timeout_pr => 2^log_n_steps < pt_size tree
  end.
Proof.
  intros. now apply Complete.parse_complete, Complete.Valid.complete_is_validator.
Qed.

(** Unambiguity theorem. **)
Theorem unambiguity:
  safe_validator () = true -> complete_validator () = true -> inhabited token ->
  forall init word,
  forall (tree1 tree2:parse_tree (NT (start_nt init)) word),
    pt_sem tree1 = pt_sem tree2.
Proof.
  intros Hsafe Hcomp [tok] init word tree1 tree2.
  pose (buf_end := cofix buf_end := (tok :: buf_end)%buf).
  assert (Hcomp1 := parse_complete Hsafe init (pt_size tree1) word buf_end
                                   Hcomp tree1).
  assert (Hcomp2 := parse_complete Hsafe init (pt_size tree1) word buf_end
                                   Hcomp tree2).
  destruct parse.
  - destruct Hcomp1.
  - exfalso. eapply PeanoNat.Nat.lt_irrefl. etransitivity; [|apply Hcomp1].
    eapply Nat.pow_gt_lin_r. constructor.
  - destruct Hcomp1 as [-> _], Hcomp2 as [-> _]. reflexivity.
Qed.

End Make.


From Undecidability.TM Require Import TM_facts.
From Undecidability.L.TM Require Import TMEncoding.
From Complexity.L.TM Require Import TMflat TMflatEnc TMflatFun TapeDecode TMunflatten.
From Undecidability.L.Datatypes Require Import LNat LProd Lists.
From Complexity.Complexity Require Import NP LinTimeDecodable ONotation.
From Undecidability.L Require Import Tactics.LTactics.
From Undecidability.L Require Import Functions.Decoding.
From Complexity.L Require Import TMflatFun TMflatComp.
From Undecidability Require Import L.Functions.EqBool.
From Undecidability Require Import L.Datatypes.LNat.

(** Using this problem to establish NP-hardness as by Cook-levin would require us to construct TMs from L-terms. We don't want to do this. Instead, we define another problem (GenNPHalt_fixed_mTM) where the machine itself and some tape content is fixed, but a single tape has arbitrary content on it. *)

(* Factorise proof over GenNP? *)
Definition TMGenNP' sig n : TM sig n * nat * nat -> Prop :=
  fun '(M, k, steps) =>
    exists tp, sizeOfmTapes tp <= k
          /\ exists f, loopM (initc M tp) steps = Some f.

Definition TMGenNP: flatTM*nat*nat -> Prop:=
  fun '(M,maxSize, steps (*in unary*)) =>
    (exists sig n (M':TM sig n), isFlatteningTMOf M M' /\ TMGenNP' (M',maxSize,steps)).

Definition TM1GenNP : {'(M,_,_) | M.(TMflat.tapes) = 1} -> Prop :=
  (fun '(exist (M,maxSize, steps (*in unary*)) _) => exists sig (M':TM sig 1), isFlatteningTMOf M M' /\ TMGenNP' (M', maxSize, steps)).

Lemma inNP_TMgenericNPCompleteProblem: inNP TMGenNP.
Proof.
  pose (R := fun '(M,maxSize, steps (*in unary*)) t =>
               sizeOfmTapesFlat t <= maxSize /\
               exists sig n (M':TM sig n),
                 isFlatteningTMOf M M'
                 /\ exists t', isFlatteningTapesOf t t'
                         /\ (exists f, loopM (initc M' t') steps = Some f)).
  apply inNP_intro with (R:= R).
  now apply linDec_polyTimeComputable.
  -destruct execFlat_poly as (f''&Hf''&polyf''&monof'').
   evar (f':nat -> nat). [f']:intro x.
   exists f'. repeat eapply conj.
   { split. cbn.
     eexists (fun '((M,maxSize,steps),t) =>
                if (sizeOfmTapesFlat t <=? maxSize)
                then match execFlatTM M t steps with
                       Some _ => true
                     | _ => false
                     end
                else false).
     repeat eapply conj.
     2:{intros [[[M maxSize] steps] t]. cbn.
        destruct (Nat.leb_spec0 (sizeOfmTapesFlat t) (maxSize));cbn [negb andb].
        2:{ split. 2:easy. intros (?&?&?&?&?&?&?&?). easy. }
        specialize (execFlatTM_correct M t steps) as H.
        destruct execFlatTM as [c| ] eqn:Hexec. all:split. 1,4:easy.
        -intros. specialize (H c). destruct H as [H _]. specialize H with (1:= Logic.eq_refl) as (?&?&?&?&?&?&Hc&?&?).
         split. easy.
         do 4 esplit. eauto.
            inv Hc. cbn in *.
            do 2 esplit. eauto.
               destruct x2. cbn in *.
               eexists. rewrite <- H1. unfold initc. repeat f_equal. inv H. apply injective_index. congruence.
               -intros (?&?&?&?&?&?&?&?&?). exfalso.
                edestruct H as [_ H']. discriminate H'.
                do 6 eexists. now eauto.
                   split. now eauto using initFlat_correct.
                   split. eauto. instantiate (1 := (_,_)).
                   split;cbn. constructor.
     }
     extract.
     recRel_prettify.
     intros [[[M maxSize] steps] t] [].
     split;[ |now repeat destruct _].
     rewrite sizeOfmTapesFlat_timeBySize.
     unfold leb_time. rewrite Nat.le_min_r.
     unfold sizeOfmTapesFlat_timeSize.
     remember (size (enc (M, maxSize, steps, t))) as x.

     assert (Ht : size (enc t) <= x).
     { subst x. rewrite !size_prod. cbn [fst snd]. lia. }
     rewrite Ht.

     assert (Hms : maxSize <= x).
     { subst x. rewrite !size_prod. cbn [fst snd]. rewrite <- size_nat_enc_r. lia. }
     rewrite Hms at 1.

     destruct (Nat.leb_spec (sizeOfmTapesFlat t) maxSize).
     rewrite Hf''. hnf in monof''. rewrite monof'' with (x':=x).
     2:{rewrite H. subst x. rewrite !size_prod. cbn [fst snd]. rewrite <- !size_nat_enc_r. lia. }
     destruct execFlatTM.
     all:unfold f'.
     reflexivity.
     all:lia.
   }
   all:unfold f'.
   all:smpl_inO.
  -evar (f:nat -> nat). [f]:intro x.
   exists f.
   +intros [[TM maxSize] steps] y.  cbn.
    intros (?&sig&n&M'&HM&t' & Ht' & HHalt) .
    eexists _,_,_. split. easy. eexists. split. now erewrite <- sizeOfmTapesFlat_eq. easy.
   +intros [[TM maxSize] steps]. cbn.
    intros (sig&n&M'&HM&t' & Ht' & HHalt) .
    eexists _. split.
    *split. now erewrite sizeOfmTapesFlat_eq.
     eauto 10 using mkIsFlatteningTapeOf.
    *remember (size (enc (TM, maxSize, steps))) as x eqn:Hn.
     rewrite size_flatTapes. 2:now apply mkIsFlatteningTapeOf.
     rewrite Ht'.
     assert (n <= x /\ maxSize <= x /\ | elem sig | <= x) as (->&->&->).
     {inv HM;destruct TM; cbn in *. rewrite !size_prod,size_TM;cbn [fst snd].
      repeat apply conj.
      all:rewrite size_nat_enc_r at 1; subst;nia.
     }
     unfold f;reflexivity.
   +unfold f;smpl_inO.
   +unfold f;smpl_inO.
Qed.


Require Export Iron.Language.SystemF2Cap.Step.TypeC.
Require Export Iron.Language.SystemF2Cap.Store.LiveS.
Require Export Iron.Language.SystemF2Cap.Store.LiveE.

(* When a well typed expression transitions to the next state
   then its type is preserved. *)
Theorem preservation
 :  forall se sp sp' ss ss' fs fs' x x' t e
 ,  WfFS   se sp ss  fs
 -> LiveS ss fs -> LiveE  fs e
 -> TypeC  nil nil se sp fs  x   t  e
 -> StepF  ss  sp  fs x  ss' sp' fs' x'
 -> (exists se' e'
    ,  WfFS  se' sp' ss' fs'
    /\ LiveS ss' fs'
    /\ LiveE fs' e'
    /\ SubsVisibleT  nil sp' sp  e  e'
    /\ TypeC nil nil se' sp' fs' x' t e').
Proof.
 intros se sp sp' ss ss' fs fs' x x' t e.
 intros HH HLS HLE HC HS.
 gen t e.
 induction HS; intros.

 (*********************************************************)
 (* Pure evaluation. *)
 Case "SfStep".
 { inverts_typec.
   exists se.
   exists e.
   intuition.

   (* Original effect visibly subsumes effect of result. *)
   - apply subsVisibleT_refl.
     eauto.

   (* Resulting configuration is well typed. *)
   - eapply TcExp; eauto.
     eapply stepp_preservation; eauto.
 }

 (*********************************************************)
 (* Push let context. *)
 Case "SfLetPush".
 { exists se.
   exists e.
   intuition.

   (* Frame stack with new FLet frame is well formed. *)
   - inverts HH. split; auto.
     unfold StoreP in *. rip.
     + inverts H3. nope. eauto.
     + inverts H3. nope. eauto.

   (* All store bindings mentioned by frame stack are still live. *)
   - eapply liveS_push_flet; auto.

   (* Original effect visibly subsumes effect of result. *)
   - inverts_typec.
     eapply subsVisibleT_refl; eauto.

   (* Resulting configuation is well typed. *)
   - inverts_typec.
     eapply TcExp
      with (t1 := t) (e1 := e0) (e2 := TSum e3 e2).
      + eapply EqTrans.
        * eapply EqSumAssoc; eauto.
        * auto.
      + auto.
      + eapply TfConsLet; eauto.
 }

 (*********************************************************)
 (* Pop let context and substitute. *)
 Case "SfLetPop".
 { exists se.
   exists e.
   intuition.

   (* Store is still well formed. *)
   - inverts HH. split; auto.
     unfold StoreP in *.
     rip; firstorder.

   (* After popping top FLet frame, effects of result are still
      to live regions. *)
   - eapply liveE_pop_flet; eauto.

   (* Original effect visibly subsumes effect of result. *)
   - inverts_typec.
     eapply subsVisibleT_refl; eauto.

   (* Resulting configuration is well typed. *)
   - inverts_typec.
     eapply TcExp
      with (t1 := t3) (e1 := e0) (e2 := e3).
      + eapply EqTrans.
        * eapply equivT_sum_left; auto.
          have (KindT nil sp e0 KEffect).
          have (KindT nil sp e3 KEffect).
          eapply KiSum; eauto.
        * auto.
      + eapply subst_val_exp; eauto.
      + auto.
 }

 (*********************************************************)
 (* Create a private region. *)
 Case "SfPrivatePush".
 { inverts_typec.
   set (r := TRgn p).
   exists se.
   exists (TSum (substTT 0 r e0) (substTT 0 r e2)).

   have (SumKind KEffect).

   have (KindT (nil :> (OCon, KRegion)) sp e0 KEffect).

   have (KindT nil sp e1 KEffect)
    by  (eapply equivT_kind_left; eauto).
   have (ClosedT e1).

   have (KindT nil sp e2 KEffect)
    by  (eapply equivT_kind_left; eauto).
   have (ClosedT e2).
   intuition.

   (* All store bindings mentioned by resulting frame stack
      are still live. *)
   - inverts HH.
     subst p.
     eapply liveS_push_fpriv_none_allocRegion; eauto.

   (* Resulting effect is to live regions. *)
   - eapply liveE_sum_above.
     + eapply liveE_phase_change.

       have HLL: (liftTT 1 0 e1 = maskOnVarT 0 e0)
        by  (eapply lowerTT_some_liftTT; eauto).
       rrwrite (liftTT 1 0 e1 = e1) in HLL.

       have (SubsT nil sp e e1 KEffect)
        by  (eapply EqSym in H0; eauto).

       have (LiveE fs e1).

       have HLW: (LiveE (fs :> FPriv None p ts) e1).
       rewrite HLL in HLW.

       have HL0: (LiveE (fs :> FPriv None p ts) e0)
        by (eapply liveE_maskOnVarT; eauto).

       trivial.

     + have (SubsT nil sp e e2 KEffect)
        by  (eapply EqSym in H0; eauto).

       have (LiveE fs e2).
       have (LiveE (fs :> FPriv None p ts) e2).
       rrwrite (substTT 0 r e2 = e2); auto.

   (* Effect of result is subsumed by previous. *)
   - rrwrite ( TSum (substTT 0 r e0) (substTT 0 r e2)
             = substTT 0 r (TSum e0 e2)).
     have (ClosedT e).
     rgwrite (e = substTT 0 r e)
      by (symmetry; eauto).

     simpl.
     set (sp' := SRegion p <: sp).
     assert (SubsVisibleT nil sp' sp (substTT 0 r e) (substTT 0 r e0)).
     { have HE: (EquivT       nil sp' e (TSum e1 e2) KEffect)
        by (subst sp'; eauto).

       have HS: (SubsT        nil sp' e e1 KEffect)
        by (subst sp'; eauto).

       apply lowerTT_some_liftTT in H5.
       apply lowerTT_some_liftTT in H6.

       assert   (SubsVisibleT nil sp' sp (liftTT 1 0 e) (liftTT 1 0 e1)) as HV.
        rrwrite (liftTT 1 0 e  = e).
        rrwrite (liftTT 1 0 e1 = e1).
        eapply subsT_subsVisibleT.
        auto.

       rrwrite (substTT 0 r e  = e).
       rrwrite (liftTT  1 0 e  = e) in HV.
       rrwrite (liftTT  1 0 e1 = maskOnVarT 0 e0) in HV.

       eapply subsVisibleT_mask; eauto.
     }

     assert (SubsVisibleT nil sp' sp (substTT 0 r e) (substTT 0 r e2)).
     { rrwrite (substTT 0 r e  = e).
       rrwrite (substTT 0 r e2 = e2).

       have HE: (EquivT nil sp' e (TSum e1 e2) KEffect)
        by (subst sp'; eauto).

       eapply SbEquiv in HE.
       eapply SbSumAboveRight in HE.
       eapply subsT_subsVisibleT. auto. auto.
     }

     unfold SubsVisibleT.
      simpl.
      apply SbSumAbove; auto.

   (* Result expression is well typed. *)
   - rrwrite (substTT 0 r e2 = e2).
     eapply TcExp
       with (sp := SRegion p <: sp)
            (t1 := substTT 0 r t0)
            (e1 := substTT 0 r e0)
            (e2 := substTT 0 r e2); auto.

     (* Type of result is equivlent to before *)
     + rrwrite (substTT 0 r e2 = e2).
       eapply EqRefl.
        eapply KiSum; auto.
         * eapply subst_type_type.
            eauto.
            subst r. eauto.

     (* Type is preserved after substituting region handle. *)
     + rgwrite (nil = substTE 0 r nil).
       rgwrite (se  = substTE 0 r se)
        by (inverts HH; symmetry; auto).

       eapply subst_type_exp with (k2 := KRegion).
       * rrwrite (liftTE 0 nil = nil).
         rrwrite (liftTE 0 se  = se)
          by (inverts HH; auto).

         eapply typex_stprops_snoc.
         rrwrite (nil >< ts = ts) in H14.
         eapply typex_tenv_effect_strengthen.
          eauto. auto.

       * subst r.
         eapply KiRgn.
         rgwrite (SRegion p <: sp = sp ++ (nil :> SRegion p)).
         eapply in_app_right; auto.

     (* New frame stack is well typed. *)
     + eapply TfConsPriv; eauto 2.

       (* Effect of frame stack is still to live regions *)
       * rrwrite (substTT 0 r e2 = e2).
         have    (SubsT nil sp e e2 KEffect)
          by     (eapply EqSym in H0; eauto).
         eapply  liveE_subsT; eauto.

       (* Frame stack is well typed after substituting region handle.
          The initial type and effect are closed, so substituting
          the region handle into them doesn't do anything. *)
       * assert (ClosedT t0).
         { have HK: (KindT  (nil :> (OCon, KRegion)) sp t0 KData).
           eapply kind_wfT in HK.
           simpl in HK.

           have (~FreeT 0 t0)
            by (eapply lowerTT_freeT; eauto).
           eapply freeT_wfT_drop; eauto.
         }

         rrwrite (substTT 0 r t0 = t0).
         rrwrite (substTT 0 r e2 = e2).
         rrwrite (t1 = t0)
          by (eapply lowerTT_closedT; eauto).
         eauto.
 }

 (*********************************************************)
 (* Pop a private region from the frame stack. *)
 Case "SfPrivatePop".
 { inverts_typec.

   (* We can only pop if there is at least on region in the store. *)
   destruct sp.

   (* No regions in store. *)
   - inverts HH. rip.
     unfold StoreP in *. rip.
     have (In (FPriv None p ts) (fs :> FPriv None p ts)).
     have (In (SRegion p) nil) by firstorder.
     nope.

   (* At least one region in store. *)
   - destruct s.
     exists se.
     exists e2.
     intuition.

     (* Frame stack is still well formed after popping the top FUse frame *)
     + eapply wfFS_region_deallocate; eauto.

     (* After popping top FUse,
        all store bindings mentioned by frame stack are still live. *)
     + eapply liveS_deallocRegion; eauto.

     (* New effect subsumes old one. *)
     + eapply subsT_subsVisibleT.
       have (EquivT nil (sp :> SRegion n) e2 e KEffect).
       eauto.

     (* Resulting configuation is well typed. *)
     + eapply TcExp
         with (sp := sp :> SRegion n)
              (e1 := TBot KEffect)
              (e2 := e2); eauto.

       eapply EqSym; eauto.
 }

 (*********************************************************)
 (* Push an extend frame on the stack. *)
 Case "SfExtendPush".
 { inverts_typec.
   set (r1 := TRgn p1).
   set (r2 := TRgn p2).
   exists se.
   exists (TSum (substTT 0 r2 e0) (TSum e2 (TAlloc r1))).
   intuition.

   (* Updated store is well formed. *)
   - inverts_kind.
     eapply wfFS_push_priv_ext; auto.

   (* Updated store is live relative to frame stack. *)
   - inverts HH.
     subst p2.
     eapply liveS_push_fpriv_some_allocRegion; eauto.

     assert (SubsT nil sp e (TAlloc (TRgn p1)) KEffect).
     { have (SubsT nil sp e (TSum (TSum eL (TAlloc (TRgn p1))) e2) KEffect).
       eapply SbSumAboveLeft; eauto.
     }

     have (LiveE fs (TAlloc (TRgn p1))).
     eapply liveSP_from_effect; eauto.
      snorm.

   (* Frame stack is live relative to effect. *)
   - apply liveE_sum_above.
     + assert (ClosedT eL).
       { have (KindT nil sp (TSum (TSum eL (TAlloc (TRgn p1))) e2) KEffect).
         inverts_kind. eauto.
       }

       have HLL: (liftTT 1 0 eL = maskOnVarT 0 e0)
        by  (eapply lowerTT_some_liftTT; eauto).
       rrwrite (liftTT 1 0 eL = eL) in HLL.

       have (LiveE fs (TSum (TSum eL (TAlloc (TRgn p1))) e2))
        by (eapply liveE_equivT_left; eauto).
       have (LiveE fs eL).

       apply liveE_phase_change.

       have HLW: (LiveE (fs :> FPriv (Some p1) p2 nil) eL).
       rewrite HLL in HLW.

       eapply liveE_maskOnVarT; eauto.

    + have (SubsT nil sp e (TSum (TSum eL (TAlloc (TRgn p1))) e2) KEffect).
      apply liveE_sum_above.
      * have (SubsT nil sp e e2 KEffect).
        eapply liveE_subsT; eauto.
      * have (SubsT nil sp e (TAlloc (TRgn p1)) KEffect).
        eapply liveE_subsT; eauto.

   (* Effect of result is subsumed by previous. *)
   - set (sp' := SRegion p2 <: sp).
     have (KindT nil sp    (TSum (TSum eL (TAlloc (TRgn p1))) e2) KEffect).
     have (SubsT nil sp' e (TSum (TSum eL (TAlloc (TRgn p1))) e2) KEffect)
      by (subst sp'; eapply subsT_stprops_snoc; eauto).

     inverts_kind.

     assert (SubsVisibleT nil sp' sp e (substTT 0 r2 e0)) as HE1.
     { eapply subsVisibleT_mask
        with (p := p2); auto.

       have HL: (liftTT 1 0 eL = maskOnVarT 0 e0)
        by (apply lowerTT_some_liftTT; auto).

       rewrite <- HL.
       rgwrite (liftTT 1 0 eL = eL).
       eapply subsT_subsVisibleT.
       eapply SbSumAboveLeft; eauto.
      }

     assert (SubsVisibleT nil sp' sp e e2)          as HE2.
     { eapply subsT_subsVisibleT.
       eapply SbSumAboveRight; eauto.
     }

     assert (SubsVisibleT nil sp' sp e (TAlloc r1)) as HE3.
     { subst r1.
       eapply subsT_subsVisibleT.
       eapply SbSumAboveLeft; eauto.
     }
     eauto.

   (* Resulting state is well typed. *)
   - eapply TcExp
       with (e1 := substTT 0 r2 e0)
            (e2 := TSum e2 (TAlloc r1))
            (t1 := substTT 0 r2 t0).
     (* Equivalence of result effect *)
     + eapply EqRefl.
       eapply KiSum; auto.
       * subst r2.
         have (KindT (nil :> (OCon, KRegion)) sp                 e0 KEffect).
         have (KindT (nil :> (OCon, KRegion)) (SRegion p2 <: sp) e0 KEffect).
         have (KindT nil (SRegion p2 <: sp) (TRgn p2) KRegion).
         eapply subst_type_type. eauto. eauto.
       * apply equivT_kind_left in H0.
         inverts_kind. subst r1.
         eapply KiSum; auto.
         eapply KiCon1. snorm. eauto.

     (* Expression with new region subst is well typed. *)
     + rgwrite (nil = substTE 0 r2 nil).
       rgwrite (se  = substTE 0 r2 se)
        by (inverts HH; symmetry; auto).

       eapply subst_type_exp.
       * eapply typex_stprops_snoc.
         rgwrite (nil = liftTE 0 nil).
         rgwrite (se  = liftTE 0 se)
          by (inverts HH; symmetry; auto).
         eauto.
       * subst r2. eauto.

     (* Extended frame stack is well typed. *)
     + have (KindT (nil :> (OCon, KRegion)) sp t0 KData).
       have (not (In (SRegion p2) sp))
        by (subst p2; auto).
       eapply TfConsExt; eauto.
       * inverts_kind. eauto.
       * eapply typeF_freshSuppFs; eauto.
       * have (LiveE fs (TSum (TSum eL (TAlloc (TRgn p1))) e2))
          by (eapply liveE_equivT_left; eauto).
         eapply liveE_sum_above.
          eapply liveE_sum_above_right; eauto.
          eapply liveE_sum_above_left  in H4.
          eapply liveE_sum_above_right in H4.
          trivial.
       * erewrite mergeT_substTT.
         eapply typeF_stprops_snoc. auto.
         eauto. eauto.
  }

 (*********************************************************)
 (* Pop and extend frame from the stack,
    and merge the new region with the old one. *)
 Case "SfExtendPop".
 { inverts_typec.
   set (r1 := TRgn p1).
   set (r2 := TRgn p2).
   exists (mergeTE p1 p2 se).
   exists e0.
   intuition.

   (* Updated store is well formed. *)
   - rrwrite (map (mergeB p1 p2) ss = mergeBs p1 p2 ss).
     eapply wfFS_pop_priv_ext; eauto.

   (* Updated store is live relative to frame stack. *)
   - SCase "LiveS".
     eapply liveS_mergeB.
     + have (LiveSF ss (FPriv (Some p1) p2 ts)).
       unfold LiveSF in H0.
       unfold LiveSP. intros.
       eapply H0 in H1. inverts H1. auto.
     + have (LiveS ss fs).
       auto.

   (* Frame stack is live relative to effect. *)
   - SCase "LiveE".
     eapply liveE_sum_above_left; eauto.

   (* Effect of result is subsumed by previous. *)
   - SCase "SubsVisibleT".
     eapply subsT_subsVisibleT.
     set (e' := (TSum (TBot KEffect) (TSum e0 (TAlloc (TRgn p1))))).
     have (KindT  nil sp e'   KEffect).
     have (EquivT nil sp e e' KEffect).
     eapply SbSumAboveRight; eauto.

   (* Resulting state is well typed. *)
   - SCase "TypeC".
     eapply TcExp
       with (t1 := mergeT p1 p2 t1)
            (e1 := TBot KEffect)
            (e2 := e0).

     (* Equivalence of result effect. *)
     + have (KindT nil sp (TSum (TBot KEffect)
                          (TSum e0 (TAlloc (TRgn p1)))) KEffect).
       inverts_kind.
       eapply EqSym; eauto.

     (* Result value is well typed. *)
     + rgwrite (nil                    = mergeTE p1 p2 nil).
       rgwrite (XVal (mergeV p1 p2 v1) = mergeX  p1 p2 (XVal v1)).
       rgwrite (TBot KEffect           = mergeT  p1 p2 (TBot KEffect)).
       eapply mergeX_typeX. auto. eauto.

     (* Popped frame stack is well typed. *)
     + rgwrite (nil = mergeTE p1 p2 nil).
       eapply typeF_mergeTE; eauto.
 }

 (*********************************************************)
 (* Run a suspension. *)
 Case "SfRun".
 { inverts HC.
   inverts H0. inverts H7.
   exists se. exists (TSum e1 e2).

   have (KindT nil sp e KEffect)            as KS2.
   have (KindT nil sp (TSum e1 e2) KEffect) as KS1.
   inverts_kind.

   rip; try (inverts HH; auto).

   (* Frame stack is live *)
   - eapply liveE_equivT_left.
      eapply H.
      auto.

   (* Effect of result is subsumed by previous. *)
   - apply subsT_subsVisibleT.
     apply SbEquiv.
     apply EqSym; auto.

   (* Resulting state is well typed. *)
   - apply TcExp
      with (t1 := t1)
           (e1 := e1)
           (e2 := e2); auto.
 }

 (*********************************************************)
 (* Allocate a reference. *)
 Case "SfStoreAlloc".
 { inverts HC.
   inverts H0.
   exists (TRef   (TRgn p1) t2 <: se).
   exists e2.
   intuition.

   (* Store is well formed after adding a binding. *)
   - remember (TRgn p1) as r.

     have (SubsT nil sp e (TAlloc r) KEffect)
      by  (eapply EqSym in H; eauto).

     have (LiveE fs (TAlloc r)).
     subst r.

     eapply wfFS_stbind_snoc; auto.
     inverts_kind. auto.

   (* Resulting effects are to live regions. *)
   - have  (SubsT nil sp e e2 KEffect)
      by   (eapply EqSym in H; eauto).
     eapply liveE_subsT; eauto.

   (* Original effect visibly subsumes resulting one. *)
   - eapply EqSym in H.
      eapply subsT_subsVisibleT; eauto.
      eauto. eauto.

   (* Resulting configuation is well typed. *)
   - eapply TcExp
      with (t1 := TRef (TRgn p1) t2)
           (e1 := TBot KEffect)
           (e2 := e2).
     + eapply EqSym.
        * eauto.
        * eapply KiSum; eauto.
        * eapply equivT_sum_left; eauto.
     + eapply TxVal.
       eapply TvLoc.
        have    (length se = length ss).
        rrwrite (length ss = length se).
        eauto. eauto.
     + eapply typeF_stenv_snoc; eauto.
 }

 (*********************************************************)
 (* Read from a reference. *)
 Case "SfStoreRead".
 { inverts HC.
   exists se.
   exists e2.
   intuition.

   (* Resulting effects are to live regions. *)
   - have  (SubsT nil sp e e2 KEffect)
      by   (eapply EqSym in H0; eauto).
     eapply liveE_subsT; eauto.

   (* Original effect visibly subsumes resulting one. *)
   - eapply EqSym in H0.
      eapply subsT_subsVisibleT; eauto.
      eauto. eauto.

   (* Resulting configutation is well typed. *)
   - eapply TcExp
      with (t1 := t1)
           (e1 := TBot KEffect)
           (e2 := e2).
     + eapply EqSym; eauto.
     + inverts H1.
       inverts H12.
       eapply TxVal.
        inverts HH. rip.
        eapply storet_get_typev; eauto.
     + eauto.
 }

 (*********************************************************)
 (* Write to a reference. *)
 Case "SfStoreWrite".
 { inverts HC.
   exists se.
   exists e2.
   intuition.

   (* Resulting store is well formed. *)
   - inverts_type.
     eapply wfFS_stbind_update; eauto.
     inverts_kind; auto.

   (* All store bindings mentioned by frame stack are still live. *)
   - inverts_type.

     have (SubsT nil sp e (TWrite (TRgn p)) KEffect)
      by  (eapply EqSym in H0; eauto).

     have (LiveE fs (TWrite (TRgn p)))
      by  (eapply liveE_subsT; eauto).

     have (rgnOfEffect (TWrite (TRgn p)) = Some p).
     lets D: liveE_fpriv_in fs H4; auto.
     destruct D as [m].
     destruct H5 as [ts].

     eapply liveS_stvalue_update.
     exists m. eauto.
     auto.

   (* Resulting effects are to live regions. *)
   - have  (SubsT nil sp e e2 KEffect)
      by   (eapply EqSym in H0; eauto).
     eapply liveE_subsT; eauto.

   (* Original effect visibly subsumes resulting one. *)
    - eapply EqSym in H0.
      eapply subsT_subsVisibleT; eauto.
       eauto. eauto.

   (* Resulting configuration is well typed. *)
   - eapply TcExp
      with (t1 := t1)
           (e1 := TBot KEffect)
           (e2 := e2).
     + eapply EqSym; eauto.
     + inverts_type.
       eapply TxVal.
        inverts HH. rip.
     + eauto.
 }
Qed.


Require Export read.
Require Export write.

Section TransitionFunction.

(*********************************************************************)
(*                   The Transition Relation                         *)
(*********************************************************************)

Inductive TransFunc : ENTITY -> SFSstate -> Operation -> SFSstate -> Prop :=
  | DoRead :
      forall (eSub : ENTITY) (eObj : ENTITY) (n : nat) (out : Exc ENTCONT)
        (s : SFSstate), read s eSub eObj n s out -> TransFunc eSub s Read s
  | DoWrite :
      forall (eSub : ENTITY) (eObj : ENTITY) (n : nat) (buf : ENTCONT)
        (s t : SFSstate), write s eSub eObj n buf t -> TransFunc eSub s Write t.

End TransitionFunction.


Require Import Core.Core Core.VstTactics Core.StructNormalizer VstLib
        ErrorWithWriter.
Require Import VST.floyd.proofauto.
Require Import Clight.ber_tlv_length.
Require Import Core.Notations Core.SepLemmas Core.Tactics
Exec.Ber_tlv_length_serialize.

Instance CompSpecs : compspecs. Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs. Proof. mk_varspecs prog. Defined.

Open Scope Z.

Definition der_tlv_length_serialize_spec : ident * funspec :=
  DECLARE _der_tlv_length_serialize
  WITH l : int, buf_b : block, buf_ofs : ptrofs, buf_size : Z
  PRE[tint, tptr tvoid, tuint]
    PROP(0 <= buf_size <= 32;
         Ptrofs.unsigned buf_ofs + buf_size < Ptrofs.modulus)
    PARAMS(Vint l; (Vptr buf_b buf_ofs); Vint (Int.repr buf_size))
    GLOBALS()
    SEP(data_at Tsh (tarray tuchar buf_size)
                    (default_val (tarray tuchar buf_size))
                    (Vptr buf_b buf_ofs))
  POST[tuint]

    PROP()
    LOCAL(temp ret_temp
               (Vint (Int.repr (snd (length_serialize l (Int.repr buf_size))))))
    SEP(let (ls, z) := length_serialize l (Int.repr buf_size) in
        data_at Tsh (tarray tuchar buf_size)
                (map Vint ls ++ sublist (len ls) buf_size
                     (default_val (tarray tuchar buf_size)))
                (Vptr buf_b buf_ofs)).

Definition Gprog := ltac:(with_library prog [der_tlv_length_serialize_spec]).

Theorem ber_tlv_length_serialize_correct :
  semax_body Vprog Gprog (normalize_function f_der_tlv_length_serialize composites)
             der_tlv_length_serialize_spec.
Admitted.
(*
 Proof.
  start_function.
  remember (default_val (tarray tuchar buf_size)) as default_list.
  assert (len default_list = buf_size) as LB.
  {  subst; unfold default_val;
        simpl;
        try erewrite Zlength_list_repeat;
        try nia; auto. }
  pose proof (req_size_32 l) as R.
  repeat forward.
  forward_if.
  - forward_if (
       PROP()
       LOCAL()
       SEP(if eq_dec (Int.repr buf_size) 0%int
           then data_at_ Tsh (tarray tuchar buf_size) (Vptr buf_b buf_ofs)
           else
             (data_at Tsh tuchar (Vint (Int.zero_ext 8 (Int.zero_ext 8 l)))
                      (Vptr buf_b buf_ofs) *
              data_at Tsh (tarray tuchar (buf_size - 1))
                      (sublist 1 buf_size default_list)
                      (Vptr buf_b (buf_ofs + Ptrofs.repr 1)%ptrofs)))).
    + rewrite <- LB.
      erewrite split_data_at_sublist_tuchar with (j := 1).
      erewrite sublist_one.
      erewrite data_at_tuchar_singleton_array_eq.
      Intros.
      repeat forward.
      rewrite_if_b.
      entailer!.
      all: subst; try nia;
        unfold default_val;
        simpl;
        try erewrite Zlength_list_repeat;
        try nia; auto.
    + forward.
      rewrite_if_b.
      entailer!.
    +
      unfold POSTCONDITION.
      unfold abbreviate.
      break_let.
      forward.
       assert ((127 >=? Int.signed l) = true) as C.
       { rewrite Z.geb_le. nia. }
      break_if; unfold length_serialize in *; rewrite C in *;
        rewrite_if_b;
        inversion Heqp. all: rewrite_if_b; entailer!.
        assert (buf_size = 0%Z).
        eapply repr_inj_unsigned; strip_repr.
       autorewrite with sublist.
       entailer!.
        assert (buf_size <> 0%Z).
        eapply repr_neq_e in n;
        lia.
       erewrite <- split_non_empty_list.
       entailer!.
       erewrite Int.zero_ext_idem.
       reflexivity.
       all: autorewrite with sublist;
         simpl; auto;
       try rewrite LB in *;
       try setoid_rewrite H7;
       try nia.
  -  assert (127 >=? Int.signed l = false) as C.
     { erewrite Z.geb_leb. Zbool_to_Prop. nia. }
     repeat forward.
     forward_loop
      (EX i: Z,
          PROP (i = 1 \/ i = 2 \/ i = 3 \/ i = 4;
                forall j, 0 <= j < i ->
                     (l >> (Int.repr j * Int.repr 8) == 0)%int = false)
          LOCAL (temp _len (Vint l);
                 temp _i (Vint (Int.repr (i * 8)));
                 temp _required_size (Vint (Int.repr i));
                 temp _size (Vint (Int.repr buf_size));
                 temp _buf (Vptr buf_b buf_ofs))
           SEP (data_at Tsh (tarray tuchar buf_size)
                         (default_val (tarray tuchar buf_size))
                         (Vptr buf_b buf_ofs)))
      break: (let r := required_size l in
              PROP ()
              LOCAL (temp _required_size (Vint (Int.repr r));
                     temp _len (Vint l);
                     temp _i (Vint ((Int.repr (r * 8))));
                     temp _size (Vint (Int.repr buf_size));
                     temp _buf (Vptr buf_b buf_ofs))
              SEP (data_at Tsh (tarray tuchar buf_size)
                           (default_val (tarray tuchar buf_size))
                           (Vptr buf_b buf_ofs))).
     + (* Pre implies Inv *)
       Exists 1%Z.
       entailer!.
       intros. replace x with 0 by nia.
       erewrite Int.shr_zero.
       erewrite Int.signed_eq.
       destruct zeq;
       try rewrite e in *; auto.
     + (* Inv exec fn Break *)
       Intros i.
       forward_if; repeat forward.
       forward_if;
         repeat forward.
       Exists (i + 1).
       entailer!.
       split.
       intros.
       destruct (zeq j i).
       subst.
       eapply Int.eq_false.
       autorewrite with norm.
       eassumption.
       eapply H3.
       nia.
       do 2 f_equal.
       nia.
       entailer!.
       assert (required_size l = i) as RS.
       eapply required_size_spec; auto.
       autorewrite with norm.
       eassumption.
       subst.
       intuition.
       entailer!.
       replace i with 4 in * by nia.
       assert (required_size l = 4) as RS.
       eapply required_size_spec; auto.
       autorewrite with norm.
       cbn.
       erewrite shr_lt_zero_32.
       break_if; auto.
       unfold Int.lt in Heqb.
       break_if; autorewrite with norm in *.
       replace (Int.signed 0%int) with 0 in * by auto with ints.
       nia.
       congruence.
       rewrite RS.
       intuition.
     + Intros.
       pose proof (req_size_32 l).
       unfold POSTCONDITION.
       unfold abbreviate.
       break_let.
       forward_if.
       forward.
       unfold length_serialize in *; rewrite C in *.
       inversion Heqp.
         rewrite_if_b.
       entailer!.
       repeat break_if; try congruence; try
       inversion Heqp; try eassumption; auto.
       break_if.
       Zbool_to_Prop.
       generalize Heqb.
       strip_repr.
       intro. lia.
       inversion Heqp.
       autorewrite with sublist.
       erewrite sublist_same_gen; auto.
       setoid_rewrite LB. lia.
       erewrite <- Heqdefault_list.
       rewrite  <- LB.
       erewrite split_data_at_sublist_tuchar with (j := 1%Z).
       erewrite sublist_one.
       erewrite data_at_tuchar_singleton_array_eq.
       all: try nia.
       Intros.
        assert (buf_size <> 0) as BUF by lia.
       repeat forward.
       normalize.
       erewrite Int.zero_ext_idem.
       remember (required_size l) as r.
       remember (Int.zero_ext 8 (Int.repr (128 or r)))%int as e0.
       remember (Int.repr (r * 8 - 8))%int as i.
     forward_loop
    (EX v : Z, EX ls : list int,
    (PROP ((Int.unsigned Int.zero <= v)%Z;
           (v <= required_size l)%Z;
           ls =
           serialize_length_loop_app (r - v)%Z (Z.to_nat v) l)
     LOCAL (temp _buf (Vptr buf_b (buf_ofs + Ptrofs.repr 1 + Ptrofs.repr v)%ptrofs);
            temp _i (Vint (Int.repr ((r * 8) - (v + 1) * 8)%Z));
            temp _end (Vptr buf_b (buf_ofs
                      + Ptrofs.repr (1 + Int.unsigned (Int.repr r))))%ptrofs;
            temp _t'1 (Vptr buf_b buf_ofs);
            temp _required_size (Vint (Int.repr r));
            temp _len (Vint l); temp _size (Vint (Int.repr buf_size)))
     SEP (data_at Tsh tuchar (Vint e0) (Vptr buf_b buf_ofs);
          data_at Tsh (tarray tuchar v)
                  (map Vint ls)
                        (offset_val 1 (Vptr buf_b buf_ofs));
          data_at Tsh (tarray tuchar (buf_size - v - 1))
                  (sublist (v + 1) buf_size default_list)
                  (Vptr buf_b (buf_ofs + Ptrofs.repr 1 + Ptrofs.repr v)%ptrofs))))
     break:
    (EX ls : list int, EX j : int,
    (PROP (let r := required_size l in
           let n :=  (Z.to_nat r) in
         ls = serialize_length_loop_app 0 n l)
     LOCAL (temp _buf (Vptr buf_b (buf_ofs + Ptrofs.repr 1
                                   + Ptrofs.repr (len ls))%ptrofs);
            temp _i (Vint j);
            temp _end (Vptr buf_b (buf_ofs + Ptrofs.repr (1 + r))%ptrofs);
            temp _t'1 (Vptr buf_b buf_ofs);
            temp _required_size (Vint (Int.repr r));
            temp _len (Vint l); temp _size (Vint (Int.repr buf_size)))
     SEP (data_at Tsh tuchar (Vint e0) (Vptr buf_b buf_ofs);
          data_at Tsh (tarray tuchar (len ls)) (map Vint ls)
                        (offset_val 1 (Vptr buf_b buf_ofs));
          data_at Tsh (tarray tuchar (buf_size - (len ls) - 1))
                  (sublist (len ls + 1) buf_size default_list)
                  (Vptr buf_b (buf_ofs + Ptrofs.repr 1
                               + Ptrofs.repr (len ls))%ptrofs)))).
      * Exists 0%Z.
        Exists (@nil int).
        erewrite data_at_tuchar_zero_array_eq.
        entailer!.
        replace (len (default_val (tarray tuchar buf_size)))
           with buf_size by (setoid_rewrite LB; lia).
        auto.
        replace (len (default_val (tarray tuchar buf_size)))
           with buf_size by (setoid_rewrite LB; lia).
        entailer!.
        cbn; auto.
      * Intros v ls.
        forward_if; try nia.
        entailer!.

         assert (0 < (buf_size - v - 1)) as LD by admit.
        assert (sizeof (tarray tuchar (len (default_val (tarray tuchar buf_size)) - v - 1)) > 0).
        { simpl.
          erewrite Zmax0r.
          setoid_rewrite LB.
          nia.
          setoid_rewrite LB.
          nia. }
        unfold test_order_ptrs.
        unfold sameblock.
        subst.
        destruct peq; [  |contradiction].
        apply andp_right.
        apply derives_trans
          with (Q := valid_pointer
                       (Vptr buf_b (buf_ofs + Ptrofs.repr (1 + v))%ptrofs)).
        entailer!.
        apply valid_pointer_weak.
        apply derives_trans
          with (Q := valid_pointer
                       (Vptr buf_b (buf_ofs
                                    + Ptrofs.repr (1 + required_size l))%ptrofs)).
        eapply sepcon_valid_pointer2.
        remember (default_val (tarray tuchar buf_size)) as default_list.
        remember (required_size l) as r.
        erewrite data_at_app_gen
          with (j1 := 1 + r - (v + 1))
               (j2 := buf_size - (1 + r))
               (ls1 := sublist (v + 1) (1 + r) default_list)
               (ls2 := sublist (1 + r) buf_size default_list).
        assert ((buf_ofs + Ptrofs.repr (1 + v) + Ptrofs.repr (1 + r - (v + 1)))%ptrofs =
        (buf_ofs + Ptrofs.repr (1 + r))%ptrofs) as PTR.
        {  ptrofs_compute_add_mul; try rep_omega.
           f_equal.
           rep_omega. }
        rewrite PTR.
        assert (0 < ((buf_size - r - 1))) as LDD by admit.
        assert (sizeof (tarray tuchar (buf_size - r - 1)) > 0).
        { simpl.
          erewrite Zmax0r; nia. }
        entailer!.
        1-5: replace (Int.unsigned 0%int) with 0%Z in * by auto with ints;
          subst; try setoid_rewrite LB; autorewrite with sublist; try list_solve.
        auto.
        ptrofs_compute_add_mul; try rep_omega.
        apply valid_pointer_weak.
        ++
        erewrite split_non_empty_list with
            (j2 := (len default_list - (v + 1) - 1)%Z)
            (ls' := (sublist (v + 1 + 1) buf_size default_list)).
        eapply typed_true_ptr_lt in H7.
        assert (v < required_size l)%Z.
        { replace (Int.unsigned 0%int) with 0 in * by auto with ints.
          generalize H7. ptrofs_compute_add_mul. subst. nia.
          all: subst; rep_omega_setup; auto with ints;
            autorewrite with norm; try rep_omega; try nia. }
        Intros.
        assert (len default_list - (v + 1) - 1 =
                len (sublist (v + 1 + 1) buf_size default_list)) as LEN.
        { erewrite Zlength_sublist_correct.
          nia.
          replace (Int.unsigned 0%int) with 0%Z in * by auto with ints.
          all: lia. }
        forward.
        entailer!.
        unfold Int.iwordsize.
        ints_compute_add_mul.
        cbn - [required_size].
        all: try rep_omega.
        auto with ints.
        repeat forward.
        remember (Int.zero_ext 8
                               (l >> (Int.repr ((required_size l - (v + 1)) * 8))))%int
          as e_v.
        normalize.
        Exists (v + 1) (ls ++ [e_v]).
        assert  (v = len ls) as VLS.
        { subst.
          erewrite loop_len_req_size.
          replace (Int.unsigned 0%int) with 0%Z in * by (autorewrite with norm; auto).
          erewrite Z2Nat_id'.
          erewrite Zmax0r.
          nia.
          nia. }
        entailer!.
        split.
        erewrite Z.add_1_r at 3.
        erewrite Z2Nat.inj_succ.
        simpl. f_equal. rewrite H6 at 1.
        replace (required_size l - len ls)  with (required_size l - (len ls + 1) + 1) by nia.
        reflexivity.
        replace (Int.unsigned 0%int) with 0%Z in * by (autorewrite with norm; auto).
        nia. auto with ints.
        split.
        do 3 f_equal. nia.
        do 2 f_equal. nia.
        repeat erewrite Int.zero_ext_idem.

        replace ((required_size l - ((len ls) + 1)) * 8)%Z with
               (required_size l * 8 - ((len ls) + 1) * 8)%Z by nia.
        remember
          (Int.zero_ext 8
                        (l >> Int.repr (required_size l * 8 - ((len ls) + 1) * 8)))%int
                 as e_v.
        unfold offset_val.
        simpl.
        replace (1 + (len ls)) with ((len ls) + 1) by nia.
        erewrite <- data_at_tuchar_singleton_array_eq.
        remember (default_val (tarray tuchar buf_size)) as default_list.

        replace (buf_ofs + Ptrofs.repr (1 + ((len ls) + 1)))%ptrofs with
            (buf_ofs + 1 + Ptrofs.repr ((len ls) + 1))%ptrofs.

        replace (buf_ofs + Ptrofs.repr ((len ls) + 1) + 1)%ptrofs with
            (buf_ofs + 1 + Ptrofs.repr ((len ls) + 1))%ptrofs.

        replace (buf_ofs + Ptrofs.repr ((len ls) + 1))%ptrofs with (buf_ofs + 1 + Ptrofs.repr (len ls))%ptrofs.

        erewrite <- data_at_app.
        erewrite <- data_at_app.
        erewrite <- data_at_app.
        erewrite map_app.
        replace buf_size with  (len default_list).

        entailer!.
        autorewrite with list sublist.
        nia.
        setoid_rewrite <- LEN.
        lia.

        all: try setoid_rewrite <- LEN.
        all: replace (Int.unsigned 0%int) with 0%Z in * by (autorewrite with norm; auto);
          autorewrite with  sublist;
          try rep_omega.
        all: try setoid_rewrite LB.
         all: ptrofs_compute_add_mul;
          replace (Ptrofs.unsigned 1%ptrofs) with 1 by auto with ptrofs;
          autorewrite with norm;
          try nia; try rep_omega; f_equal; try nia.
         instantiate (1 := Znth (v + 1) default_list).
         erewrite sublist_split with (mid := v + 1 + 1).
         erewrite sublist_len_1.
         reflexivity.
         all: try setoid_rewrite LB; try lia.
          eapply typed_true_ptr_lt in H7.
        assert (v < required_size l)%Z.
        { replace (Int.unsigned 0%int) with 0 in * by auto with ints.
          generalize H7. ptrofs_compute_add_mul. subst. nia.
          all: subst; rep_omega_setup; auto with ints;
            autorewrite with norm; try rep_omega; try nia. }
        lia.

         eapply typed_true_ptr_lt in H7.
        assert (v < required_size l)%Z.
        { replace (Int.unsigned 0%int) with 0 in * by auto with ints.
          generalize H7. ptrofs_compute_add_mul. subst. nia.
          all: subst; rep_omega_setup; auto with ints;
            autorewrite with norm; try rep_omega; try nia. }
        lia.
         eapply typed_true_ptr_lt in H7.
        assert (v < required_size l)%Z.
        { replace (Int.unsigned 0%int) with 0 in * by auto with ints.
          generalize H7. ptrofs_compute_add_mul. subst. nia.
          all: subst; rep_omega_setup; auto with ints;
            autorewrite with norm; try rep_omega; try nia. }
         erewrite Zlength_sublist_correct. lia.
        all: try lia.
        setoid_rewrite LB. lia.
         ++
        eapply typed_false_ptr_lt in H7.
         assert (required_size l < buf_size) by nia.
        assert (v >= required_size l)%Z.
        { replace (Int.unsigned 0%int) with 0%Z in * by auto with ints.
          generalize H7.
          ptrofs_compute_add_mul.
          subst.

          all: subst; rep_omega_setup;
            auto with ints; autorewrite with norm; try rep_omega; try nia.
        }
        repeat forward.
        assert (v = required_size l) as V.
        subst. nia.
        rewrite V.
        rewrite Heqr.
        Exists ls (Int.repr ((r * 8) - (r + 1) * 8)%Z).
        replace (required_size l - required_size l)%Z with 0%Z by nia.
        entailer!.
        split.
         replace (required_size l - required_size l)%Z with 0%Z by nia.
        reflexivity.
        erewrite Zlength_map in H13.
        setoid_rewrite H13.
        reflexivity.
        replace (required_size l - required_size l)%Z with 0%Z in * by nia.
        remember (serialize_length_loop_app 0
                  (Z.to_nat (required_size l)) l) as ls.
        assert (required_size l = len ls) as L.
        {  erewrite Zlength_map in H13.
           subst.
           rewrite <- H13 at 1.
            replace (required_size l - required_size l)%Z with 0 by nia.
           reflexivity. }
         replace (required_size l - required_size l)%Z with 0 by nia.
         erewrite Zlength_map in H13.
         rewrite L.
         entailer!.
      * Intros ls j.
        unfold POSTCONDITION.
        unfold abbreviate.
        pose proof (req_size_32 l).
        assert (required_size l < buf_size) by nia.
        forward.
        unfold length_serialize in *.
        rewrite C in *.
        rewrite Int.unsigned_repr_eq in Heqp.
        rewrite Zmod_small in Heqp.
        erewrite <- Z.ltb_lt in H3.
        rewrite H3 in Heqp.
        inversion Heqp.
        unfold serialize_length_app.
        unfold offset_val.
        erewrite <- data_at_tuchar_singleton_array_eq.
        erewrite <- data_at_app.
        replace (1 + len ls)%Z with (len ls + 1)%Z by nia.
        erewrite <- data_at_app.
        setoid_rewrite <- H4.
        replace (len ls + 1 +
                 (buf_size
                  - len ls - 1))%Z
          with buf_size.
        replace (len (Int.zero_ext 8 (Int.repr 128 or Int.repr (required_size l))%int :: ls)) with
            (len ls + 1)%Z by
            (autorewrite with sublist list norm;
             nia).
        autorewrite with sublist.
        normalize.
        entailer!.
         all: (autorewrite with sublist list norm;
                     try nia; auto).
         erewrite Zlength_sublist_correct.
        nia.
        all: try (subst;
        erewrite loop_len_req_size;
        erewrite Z2Nat_id';
        erewrite Zmax0r;
        rep_omega).
        setoid_rewrite LB. lia.
        autorewrite with sublist.
        erewrite Zlength_sublist_correct; try  lia.
        subst.
        erewrite loop_len_req_size.
        erewrite Z2Nat_id'.
        erewrite Zmax0r.
        all: rep_omega.
       * lia.
Admitted.

*)


Require Export high_mods.
Require Import SO_facts3 vsS_syn_sem consistent.

Fixpoint newnew_pre alpha lv ln : SecOrder :=
  match lv, ln with
  | nil, _ => alpha
  | _, nil => alpha
  | cons x lv', cons n ln' =>
    replace_FOv (newnew_pre alpha lv' ln') x (Var n)
  end.

Lemma newnew_pre_nil : forall l alpha,
  newnew_pre alpha l nil = alpha.
Proof. induction l; intros alpha; auto. Qed.

Lemma want16 : forall l beta n xn ym,
    ~ (Var xn) = (Var ym) ->
    free_FO beta (Var ym) = false ->
    ym <= n ->  In (Var ym) l ->
    ~ In (Var ym) (FOvars_in
        (newnew_pre beta (rem_FOv (Var xn) l)
        (rev_seq (S n)
        (length (rem_FOv (Var xn) l))))).
Proof.
  induction l; intros beta n xn ym Hneq Hfree Hleb Hin2. contradiction.
  simpl in Hin2. destruct Hin2.
  + subst. simpl. rewrite FOvariable_dec_r; auto.
    simpl.  rewrite rep__ren_list. apply rename_FOv_list_not_eq.
    apply FOv_not. lia.
  + simpl. destruct (FOvariable_dec (Var xn) a); subst.
    simpl. apply IHl; auto.
    simpl. rewrite rep__ren_list.
    destruct (FOvariable_dec a (Var (S (n + length (rem_FOv (Var xn) l))))).
      subst. rewrite rename_FOv_list_refl. apply IHl; auto.
    destruct (FOvariable_dec (Var ym) a). subst.
    apply rename_FOv_list_not_eq. apply FOv_not. lia.
    rewrite is_in_FOvar_rename_FOv_list; auto.
    apply FOv_not. lia.
Qed.

Lemma want15 : forall beta xn a alpha,
  free_FO beta a = false ->
  In a (FOvars_in beta) ->
  SOQFree beta = true ->
  ~ att_allFO_var alpha (Var xn) ->
  ~ (Var xn) = a ->
  In a (FOvars_in alpha) ->
  ~ In  a (FOvars_in
    (newnew_pre (instant_cons_empty' alpha beta)
       (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' alpha beta)) )
       (rev_seq (S (Nat.max (Nat.max (max_FOv alpha) (max_FOv beta)) xn))
          (length
             (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' alpha beta))))))).
Proof.
  intros beta xn [ym] alpha Hfree Hin3 Hno Hat Hneq Hin2.
  apply want16; auto.
  apply free_FO_instant_cons_empty'_f; auto.
  unfold max_FOv. apply want19_pre in Hin2.
  lia. apply kk1; auto.
Qed.

Lemma want14 : forall l beta xn a alpha,
  SOQFree beta = true ->
  free_FO beta a = false ->
  ~ Var xn = a ->
  In a (FOvars_in beta) ->
  incl l (FOvars_in alpha) ->
  ~ att_allFO_var alpha (Var xn) ->
  In a (FOvars_in alpha) ->
  ~  att_allFO_var
    (newnew_pre (instant_cons_empty' alpha beta)
       (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' alpha beta)))
       (rev_seq (S (Nat.max (Nat.max (max_FOv alpha) (max_FOv beta)) xn))
          (length
             (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' alpha beta)))))) a.
Proof.
  intros l beta xn [ym] alpha Hno Hfree Hin Hneq Hin3 Hat Hin2.
  apply in_FOvar_att_allFO_x.  apply want15; auto.
Qed.

Lemma aa23 : forall l alpha x n,
  ~ l = nil ->
  var_in_SO alpha x ->
  ~ In x l ->
  ~ att_allFO_var alpha x ->
  (max_FOv alpha) <= n ->
  ~ att_allFO_var (newnew_pre alpha l (rev_seq (S n) (length l))) x.
Proof.
  induction l; intros alpha x n Hnil Hocc Hin Hat Hleb. auto.
  simpl in *.
  pose proof Hocc as Hocc'.   pose proof Hleb as Hleb'.
  unfold var_in_SO in Hocc. unfold max_FOv in *.
  case_eq l.
  + intros Hnil2. rewrite Hnil2 in *. simpl.
    rewrite <- plus_n_O.
    apply rep_FOv_att_allFO; try assumption.
    destruct x. intros H. inversion H. subst.
    apply want19_pre in Hocc. lia.
  + intros z l' Heq. apply rep_FOv_att_allFO.
    rewrite <- Heq. apply IHl; subst; firstorder.
    intros HH. destruct x. inversion HH. subst.
    apply want19_pre in Hocc. lia.
Qed.

Lemma aa23_EX : forall l alpha x n,
  ~ l = nil ->
  var_in_SO alpha x ->
  ~ In x l ->
  ~ att_exFO_var alpha x ->
  (max_FOv alpha) <= n ->
  ~ att_exFO_var (newnew_pre alpha l
    (rev_seq (S n) (length l))) x.
Proof.
  induction l; intros alpha x n Hnil Hocc Hin Hat Hleb.
    simpl. assumption.

    simpl. simpl in Hin. apply not_or_and in Hin.
    case_eq l. intros Hnil2. rewrite Hnil2 in *. simpl.
      rewrite <- plus_n_O.
      apply rep_FOv_att_exFO; try assumption.
      unfold var_in_SO in Hocc. unfold max_FOv in Hleb.
      destruct x. apply want19_pre in Hocc. intros HH. inversion HH.
      subst. firstorder.

      intros z l' Heq. assert (~ l = nil) as HH.
      intros HH2. rewrite HH2 in Heq. discriminate.
      destruct Hin as [Hin' Hin].
      specialize (IHl _ _ n HH Hocc Hin Hat Hleb).
      apply rep_FOv_att_exFO. rewrite <- Heq. apply IHl.
      rewrite <- Heq.
      intros H. destruct x. inversion H as [H']. subst.
      unfold max_FOv in Hleb. unfold var_in_SO in Hocc.
      apply want19_pre in Hocc. firstorder.
Qed.

Lemma aa24 : forall l alpha beta ym n,
  In (Var ym) (FOvars_in alpha) ->
  ~ In (Var ym) (FOvars_in beta) ->
  ~ In (Var ym) l ->  ym <= n ->
~ att_allFO_var
    (newnew_pre (instant_cons_empty' alpha beta) l
       (rev_seq (S n) (length l))) (Var ym).
Proof.
  induction l; intros alpha beta ym n H1 H2 H3 Hleb.
    simpl. apply att_allFO_instant_cons_empty'.
    apply in_FOvar_att_allFO_x. assumption.

    simpl. apply rep_FOv_att_allFO. apply IHl; auto.
    firstorder. intros HH. inversion HH. lia.
Qed.

Lemma kk14'  : forall lx ln x alpha,
~ In x lx -> closed_except alpha x ->
(S (max_FOv alpha)) <= (min_l ln) ->
closed_except (newnew_pre alpha lx ln) x.
Proof.
  induction lx; intros ln [xn] alpha Hin Hc Hleb. auto.
  simpl in *. destruct a as [ym].
  destruct ln. assumption.
  apply not_or_and in Hin. destruct Hin as [Hin1 Hin2].
  case_eq (min_l (cons n ln)).
    intros Hmn; rewrite Hmn in *. inversion Hleb.
  intros m Hmn.
  destruct (PeanoNat.Nat.eq_dec xn n) as [Hbeq2 | Hbeq2].
  + subst. apply kk19 in Hc.
    rewrite Hmn in Hleb.
    destruct (min_l_cons ln n) as [H1 | H2].
      rewrite H1 in Hmn. subst. lia.
    rewrite H2 in Hmn.
    apply min_l_leb_cons2 in H2. lia.
  + apply kk15; try assumption. auto.
    apply FOv_not. auto.
    case_eq ln.
      intros Hln. rewrite newnew_pre_nil.
      assumption.
    intros n' l' Hln. rewrite <- Hln.
    apply IHlx; try assumption.
    rewrite Hmn in Hleb.
    destruct (min_l_cons  ln n) as [H1 | H2].
    rewrite H1 in Hmn.
    pose proof H1 as H1'.
    apply min_l_leb_cons1 in H1. lia.
    subst. discriminate. lia.
Qed.

Lemma aa3' : forall lx ln alpha,
  length lx = length ln ->
  (S (max_FOv alpha)) <= (min_l ln) ->
   (max_FOv (newnew_pre alpha lx ln)) <=
          (max (max_FOv alpha) (max_l ln)).
Proof.
  induction lx; intros ln alpha Hl Hleb; simpl in *.
  + destruct ln. 2 : discriminate. lia.
  + destruct ln. discriminate.
    simpl in *. case_eq ln.
    ++ intros Hln; rewrite Hln in *.
       destruct lx. 2 : discriminate.
       simpl. destruct (in_dec FOvariable_dec a (FOvars_in alpha)).
       rewrite aa18_t. lia. lia. firstorder.
       rewrite rep_FOv_not_in. lia. firstorder.
    ++ intros m lm Hln. rewrite <- Hln.
       destruct (in_dec FOvariable_dec a (FOvars_in (newnew_pre alpha lx ln))).
       eapply (PeanoNat.Nat.le_trans). apply le_max_FOv_replace_FOv.
       assert (max_FOv (newnew_pre alpha lx ln) <=
               Nat.max (max_FOv alpha) (max_l ln)) as Hass.
         apply IHlx; firstorder. rewrite Hln in *. lia.
       lia.
       rewrite rep_FOv_not_in. eapply PeanoNat.Nat.le_trans.
       apply IHlx; firstorder. rewrite Hln in *. lia. lia.
       firstorder.
Qed.

Lemma aa : forall ln lx alpha n,
  length lx = length ln ->
  (S (max_FOv alpha)) <= (min_l ln)  ->
   (S (max_l ln)) <= n ->
   (S(max_FOv (newnew_pre alpha lx ln))) <= n.
Proof.
  intros ln lx alpha n Hl H1 H2.
  eapply PeanoNat.Nat.le_trans.
  + apply le_n_S. apply aa3'; auto.
  + pose proof (le_min__max_l ln). lia.
Qed.

Lemma newnew_pre_extra_n : forall lx l1 l2 alpha,
  length lx = length l1 ->
  newnew_pre alpha lx (app l1 l2) = newnew_pre alpha lx l1.
Proof.
  induction lx; intros l1 l2 alpha Heq. auto.
  destruct l1. simpl in *. discriminate.
  simpl. rewrite IHlx. reflexivity.
  simpl in *. inversion Heq. reflexivity.
Qed.

Lemma newnew_pre_extra_x : forall ln l1 l2 alpha,
  length ln = length l1 ->
  newnew_pre alpha (app l1 l2) ln = newnew_pre alpha l1 ln.
Proof.
  induction ln; intros l1 l2 alpha Heq.
    do 2 rewrite newnew_pre_nil. reflexivity.

    destruct l1. simpl in *. discriminate.
    simpl. rewrite IHln. reflexivity.
    simpl in *. inversion Heq. reflexivity.
Qed.

Lemma kk10 : forall lx ln alpha x,
  closed_except alpha x ->
  ~ In x lx ->
  (S (max_FOv alpha)) <= (min_l ln) ->
  decr_strict ln ->
  forall W Iv Ip Ir,
  SOturnst W Iv Ip Ir alpha <->
  SOturnst W Iv Ip Ir (newnew_pre alpha lx ln).
Proof.
  induction lx; intros ln alpha x Hc Hin Hleb Hd W Iv Ip Ir.
    simpl. apply iff_refl.
  simpl. destruct ln. apply iff_refl.
  simpl in Hin. apply not_or_and in Hin.
  destruct Hin. case_eq ln.
  + intros Hln. subst. rewrite newnew_pre_nil.
    apply (kk10_nil _ x); auto.

  + intros m ln' Hln. rewrite <- Hln.
    assert ((S (max_FOv alpha)) <= (min_l ln)) as Hleb2.
      simpl in *. subst. lia.
    inversion Hd. subst. remember (m :: ln') as ln.
    assert ((S(max_l ln)) <= n) as Hleb3.  lia.
    destruct (FOvariable_dec a (Var n)); subst.
      rewrite rep_FOv_rem. apply (IHlx _ _ x); auto.
    split; intros SOt.
    ++ destruct (aa11' (m :: ln') lx) as [[ln1 [ln2 [H1 H2]]] | [lx1 [lx2 [H1 H2]]]].
         -- rewrite H2. rewrite newnew_pre_extra_n. 2 : assumption.
            case_eq lx.
            * intros Hlx. simpl. destruct x as [xn].
              pose proof  (equiv_replace_FOv_free_FO_f alpha a (Var n)).
              unfold replace_FOv in H5.
              apply H5; try assumption.
              apply aa14 with (x := (Var xn));
              try assumption. auto.
              apply Hc.
              destruct (in_dec FOvariable_dec (Var xn) (FOvars_in alpha)).
              apply want19_pre in i. intros HH. inversion HH. subst.

              unfold max_FOv in Hleb. clear -Hleb i. simpl in *.
              lia. destruct Hc as [HH1 HH2]. apply free_FO_var_in in HH1.
              contradiction.
              intros HH. apply var_in_SO_max_FOv_gen2 in HH.
              apply HH. simpl in Hleb. clear -Hleb.
              destruct ln'; lia.

            * intros y lx' Hlx. rewrite <- Hlx.
              assert (~ var_in_SO (newnew_pre alpha lx ln1) (Var n)) as
                  Has. destruct n. simpl in *. destruct ln'; inversion Hleb.
                intros HH.  apply var_in_SO_max_FOv_gen2 in HH. apply HH.
                apply aa; auto. rewrite H2 in *.
                destruct ln2. simpl in *. rewrite app_nil_r in *. auto.
                rewrite min_l_app in Hleb2.
                lia. destruct ln1. rewrite Hlx in *. simpl in *. discriminate.
                discriminate. discriminate.
                apply aa16 with (l2 := ln2).  rewrite <- H2.  lia.
              apply equiv_replace_FOv_free_FO_f; auto.
              ** pose proof (kk14' lx ln1) as H3'.
                 apply aa14 with (x := x); auto.
                 apply H3'; try assumption.
                 apply (aa15 _ _ ln2); auto.
                 intros H'. rewrite H' in H1. simpl in H1.
                 rewrite Hlx in H1. discriminate.
                 rewrite <- H2. assumption.
              ** apply var_in_SO_free_FO. assumption.
              ** rewrite <- (newnew_pre_extra_n lx ln1 ln2).
                 rewrite <- H2. apply (IHlx _ alpha x).
                 all: try assumption.
(* -- *)
          -- rewrite H2. rewrite newnew_pre_extra_x. 2 : assumption.
             assert (~ var_in_SO (newnew_pre alpha lx1 (m :: ln')) (Var n)) as
                 Has. intros HH. destruct n. simpl in *.
               apply var_in_SO_max_FOv_gen2 in HH. apply HH.
               simpl in Hleb. lia.   apply var_in_SO_max_FOv_gen2 in HH.
               apply HH. apply aa; auto.
               apply equiv_replace_FOv_free_FO_f; auto.
             --- pose proof (kk14' lx1 (m :: ln')) as H3'.
                 apply aa14 with (x := x). apply H3'; try assumption.
                 subst. clear -H0. firstorder. auto.
             --- apply var_in_SO_free_FO. assumption.
             --- rewrite <- (newnew_pre_extra_x _ _ lx2).
                 rewrite <- H2. apply (IHlx (m :: ln') alpha x).
                 all: try assumption.

(* -- *)

    ++  unfold lt in H3. remember (m :: ln') as ln.
       destruct (aa11' ln lx) as [[ln1 [ln2 [H1 H2]]] | [lx1 [lx2 [H1 H2]]]].
       - rewrite H2 in *. rewrite newnew_pre_extra_n in *. 2 : assumption.
         case_eq lx.
         -- intros Hlx. simpl. destruct x as [xn]. rewrite Hlx in *.
            pose proof  (equiv_replace_FOv_free_FO_f alpha a (Var n)) as H5.
            unfold replace_FOv in H5.
            apply H5; try assumption.
            apply aa14 with (x := (Var xn));
              try assumption; auto.
            rewrite <- H2 in *.
            apply (aa17 _ ln n (Var xn)); try assumption.
            intros HH. apply var_in_SO_max_FOv_gen2 in HH. apply HH.
            rewrite <- H2 in *. clear -Hleb. simpl in *.
            destruct ln; lia.
         -- intros y lx' Hlx.
            assert (~ var_in_SO (newnew_pre alpha lx ln1) (Var n)) as
                Has. intros HH. apply var_in_SO_max_FOv_gen2 in HH.
              apply HH. apply aa; auto. destruct ln1. simpl in *.
              destruct lx; discriminate.
              clear -Hleb H3. eapply PeanoNat.Nat.le_trans.
              apply Hleb. change (n :: (n1 :: ln1) ++ ln2) with ((n :: (n1 :: ln1)) ++ ln2).
              destruct ln2. rewrite app_nil_r in *. simpl. lia.
              rewrite min_l_app. simpl. lia. discriminate. discriminate.
              destruct ln1.  simpl in *. destruct ln2. simpl in *.
              firstorder. simpl in *. destruct lx; discriminate.
              apply (aa16 _ ln2). rewrite <- H2 in *. lia.
            apply equiv_replace_FOv_free_FO_f in SOt; auto.
            * rewrite <- (newnew_pre_extra_n _ ln1 ln2) in SOt.
              rewrite <- H2 in *. apply (IHlx ln alpha x) in SOt.
              all: try assumption.
            * pose proof (kk14' lx ln1) as H4'.
              apply aa14 with (x := x).
              apply H4'; try assumption.
              apply (aa15 _ _ ln2).
              intros H'. rewrite H' in H1. simpl in H1.
              rewrite Hlx in H1. discriminate.
              assumption. auto.
            * apply var_in_SO_free_FO. assumption.

       - rewrite H2 in *. rewrite newnew_pre_extra_x in *. 2 : assumption.
         assert (~ var_in_SO (newnew_pre alpha lx1 ln) (Var n)) as
             Has. destruct n.
           simpl in *. destruct ln; firstorder.
           intros HH.  apply var_in_SO_max_FOv_gen2 in HH.
           apply HH. apply aa; auto.
         apply equiv_replace_FOv_free_FO_f in SOt; auto.
         -- rewrite <- (newnew_pre_extra_x _ _ lx2) in SOt.
            rewrite <- H2 in *. apply (IHlx ln alpha x).
            all: try assumption.
         -- pose proof (kk14' lx1 ln) as H4'.
            apply aa14 with (x := x).
            apply H4'; try assumption.
            firstorder. auto.
         -- apply var_in_SO_free_FO. assumption.
Qed.

Lemma newnew_pre_rename_FOv_list_l : forall lv ln alpha,
  FOvars_in (newnew_pre alpha lv ln) =
  rename_FOv_list_l (FOvars_in alpha) lv (FOvify ln).
Proof.
  induction lv; intros ln alpha. auto.
  simpl. destruct ln. auto.
  simpl. rewrite rep__ren_list. rewrite IHlv. auto.
Qed.

Lemma SOQFree_newnew_pre : forall l1 l2 alpha,
  SOQFree alpha = true ->
  SOQFree (newnew_pre alpha l1 l2) = true.
Proof.
  induction l1; intros l2 alpha H; auto.
  simpl. destruct l2. assumption.
  apply SOQFree_rep_FOv. auto.
Qed.

Lemma want3 : forall l alpha beta xn,
  SOQFree beta = true ->
  incl l (FOvars_in alpha) ->
  ~ att_allFO_var alpha (Var xn) ->
  closed_except beta (Var xn) ->
  ~ att_allFO_var beta (Var xn) ->
~ ex_att_allFO_lvar
  (newnew_pre (instant_cons_empty' alpha beta)
     (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' alpha beta)))
     (rev_seq (S (Nat.max (Nat.max (max_FOv alpha) (max_FOv beta)) xn))
        (length
           (rem_FOv
              (Var xn) (FOvars_in (instant_cons_empty' alpha beta)))))) l.
Proof.
  induction l; intros alpha beta xn Hno Hin Hat Hcl Hat2.
    intros H. inversion H.
  simpl in *. pose proof (incl_hd _ _ _ _ Hin) as H4. apply incl_lcons in Hin.
  intros H. inversion H; subst.
  + destruct a as [ym].
    destruct (FOvariable_dec (Var ym) (Var xn)) as [Heq | Heq].
    inversion Heq. subst.
    case_eq ( rem_FOv (Var xn) (FOvars_in (instant_cons_empty' alpha beta))).
      intros HH. rewrite HH in *. simpl in *.
      eapply att_allFO_instant_cons_empty' in H2; auto.
    intros mm lmm Hmm.
    apply aa23 in H2; auto.
    ++ rewrite Hmm . discriminate.
    ++ apply var_in_SO_instant_cons_empty'.
       inversion Hcl as [Hcl1 Hcl2].
       pose proof (var_in_SO_free_FO beta (Var xn)) as H0.
       rewrite Hcl1 in *. unfold var_in_SO in *.
       destruct (in_dec FOvariable_dec (Var xn) (FOvars_in beta)) as [H2' | H2'].
       auto. apply H0 in H2'. discriminate.
    ++ apply is_in_FOvar_rem_FOv_f.
    ++ apply att_allFO_instant_cons_empty'. auto.
    ++ rewrite max_FOv_instant_cons_empty'.
       unfold max_FOv. simpl.  lia.
    ++ destruct (in_dec FOvariable_dec (Var ym) (FOvars_in beta)).
    eapply want14 in H4; auto.
    unfold max_FOv in *. simpl in *.
    simpl in *. contradiction (H4 H2).
    all : auto. inversion Hcl as [Hcl1 Hcl2].
    apply Hcl2. auto. apply Hin.
    eapply aa24. apply H4. apply n. 3 : apply H2.
    intros HH. apply want13 in HH. unfold instant_cons_empty' in HH.
    apply kk8 in HH; auto. auto.
    pose proof (want19_pre _ _ H4).
    unfold max_FOv in *. lia.
  + apply IHl in H2; auto.
Qed.

Lemma lem3 : forall beta rel atm xn P,
  REL rel = true ->
  AT atm = true ->
  SOQFree beta = true ->
  closed_except beta (Var xn) ->
  ~ att_allFO_var beta (Var xn) ->
~ ex_att_allFO_lvar
     (newnew_pre (instant_cons_empty' (conjSO rel atm) beta)
        (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' (conjSO rel atm) beta)))
        (rev_seq (S (Nat.max (Nat.max (Nat.max (max_FOv rel) (max_FOv atm)) (max_FOv beta)) xn))
           (length
              (rem_FOv  (Var xn) (FOvars_in (instant_cons_empty' (conjSO rel atm) beta))
                )))) (FOv_att_P (conjSO rel atm) P).
Proof.
  intros beta rel atm xn P HREL HAT Hno Hcl Hatt.
  rewrite <- max_FOv_conjSO.
  apply want3; try assumption.
  apply incl_FOv_att_P. intros H.
  inversion H; subst.
  apply att_allFO_var_REL in H3; auto.
  apply att_allFO_var_AT in H3; auto.
Qed.

Lemma lem3_atm : forall beta atm xn P,
  AT atm = true ->
  SOQFree beta = true ->
  closed_except beta (Var xn) ->
  ~ att_allFO_var beta (Var xn) ->
~ ex_att_allFO_lvar
     (newnew_pre (instant_cons_empty' atm beta)
        (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' atm beta)))
        (rev_seq (S (Nat.max (Nat.max (max_FOv atm) (max_FOv beta)) xn))
           (length
              (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' atm beta))
                 )))) (FOv_att_P atm P).
Proof.
  intros beta  atm xn P  HAT Hno Hcl Hatt.
  apply want3; try assumption.  apply incl_FOv_att_P.
  simpl. intros H. apply att_allFO_var_AT in H; auto.
Qed.

Lemma want15_EX : forall beta xn a alpha,
  free_FO beta a = false ->
  In a (FOvars_in beta) ->
  SOQFree beta = true ->
  ~ att_exFO_var alpha (Var xn) ->
  ~ (Var xn) = a ->
  In a (FOvars_in alpha) ->
  ~ In a (FOvars_in
    (newnew_pre (instant_cons_empty' alpha beta)
       (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' alpha beta)))
       (rev_seq (S (Nat.max (Nat.max (max_FOv alpha) (max_FOv beta)) xn))
          (length
             (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' alpha beta))))))).
Proof.
  intros beta xn [ym] alpha Hfree Hin3 Hno Hat Hneq Hin2.
  apply want16; try assumption.
  apply free_FO_instant_cons_empty'_f; try assumption.
  unfold max_FOv. apply want19_pre in Hin2. lia.
  apply kk1; auto.
Qed.

Lemma want14_EX : forall l beta xn a alpha,
  SOQFree beta = true ->
  free_FO beta a = false ->
  ~ Var xn = a ->
  In a (FOvars_in beta) ->
  incl l (FOvars_in alpha) ->
  ~ att_exFO_var alpha (Var xn) ->
  In a (FOvars_in alpha) ->
 ~ att_exFO_var
    (newnew_pre (instant_cons_empty' alpha beta)
       (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' alpha beta)))
       (rev_seq (S (Nat.max (Nat.max (max_FOv alpha) (max_FOv beta)) xn))
          (length
             (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' alpha beta)) ))))
    a.
Proof.
  intros l beta xn [ym] alpha Hno Hfree Hin Hneq Hin3 Hat Hin2.
  apply is_in_FOvar_att_exFO_var_neg.
  apply want15_EX; try assumption.
Qed.

Lemma aa24_EX : forall l alpha beta ym n,
  In (Var ym) (FOvars_in alpha) ->
  ~ In (Var ym) (FOvars_in beta) ->
  ~ In (Var ym) l ->
  ym <= n ->
~ att_exFO_var
    (newnew_pre (instant_cons_empty' alpha beta) l
       (rev_seq (S n) (length l))) (Var ym).
Proof.
  induction l; intros alpha beta ym n H1 H2 H3 Hleb; simpl.
  + apply att_exFO_instant_cons_empty'.
    apply is_in_FOvar_att_exFO_var_neg. assumption.
  + destruct (PeanoNat.Nat.eq_dec (S (n + length l)) ym).
    subst. lia.
    apply rep_FOv_att_exFO.
    apply IHl; try assumption.
    simpl in H3. firstorder.
    apply FOv_not. auto.
Qed.

Lemma want3_EX : forall l alpha beta xn,
  SOQFree beta = true ->
  incl l (FOvars_in alpha) ->
  ~ att_exFO_var alpha (Var xn) ->
  closed_except beta (Var xn) ->
  ~ att_exFO_var beta (Var xn) ->
~ ex_att_exFO_lvar
  (newnew_pre (instant_cons_empty' alpha beta)
     (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' alpha beta)))
     (rev_seq (S (Nat.max (Nat.max (max_FOv alpha) (max_FOv beta)) xn))
        (length
           (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' alpha beta))
  )))) l.
Proof.
  induction l; intros alpha beta xn Hno Hin Hat Hcl Hat2.
  intros HH. inversion HH. pose proof (incl_hd _ _ _ _ Hin) as Hin'.
  apply incl_lcons in Hin.  destruct a as [ym].
  destruct (PeanoNat.Nat.eq_dec xn ym) as [Hbeq | Hbeq].
  + subst ym.
    case_eq (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' alpha beta))).
    intros H. simpl.
    intros HH. inversion HH; subst.
    apply att_exFO_instant_cons_empty' in H2;  auto.
    eapply IHl in Hat2; auto. rewrite H in Hat2.
    simpl in Hat2. contradiction. auto. auto.
    intros y l' Heq. rewrite <- Heq.
    intros HH. inversion HH; subst. apply aa23_EX in H1; auto.
    rewrite Heq. discriminate.
    apply var_in_SO_instant_cons_empty'.
    apply free_FO_var_in. apply Hcl. apply is_in_FOvar_rem_FOv_f.
    apply att_exFO_instant_cons_empty'. assumption.
    rewrite max_FOv_instant_cons_empty'. lia.
    apply IHl in H1; auto.
  + destruct (in_dec FOvariable_dec (Var ym) (FOvars_in beta)).
    intros HH. inversion HH; subst.
    eapply want14_EX in H1; auto.
    inversion Hcl as [Hcl1 Hcl2]. apply Hcl2. apply FOv_not. auto.
    apply FOv_not. auto.  apply Hin.
    apply IHl in H1; auto.
    intros HH. inversion HH; subst.
    eapply aa24_EX in H1; auto.
    intros HH2. apply want13 in HH2.
    eapply kk7. 2 : apply HH2. auto.
    apply FOv_not. auto.
    apply want19_pre in Hin'. unfold max_FOv. lia.
    apply IHl in H1; auto.
Qed.

Lemma lem5 : forall beta rel atm xn P,
  REL rel = true ->
  AT atm = true ->
  SOQFree beta = true ->
  closed_except beta (Var xn) ->
  ~ att_exFO_var beta (Var xn) ->
~ ex_att_exFO_lvar
     (newnew_pre (instant_cons_empty' (conjSO rel atm) beta)
        (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' (conjSO rel atm) beta)))
        (rev_seq (S (Nat.max (Nat.max (Nat.max (max_FOv rel) (max_FOv atm)) (max_FOv beta)) xn))
           (length
              (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' (conjSO rel atm) beta))
                )))) (FOv_att_P (conjSO rel atm) P).
Proof.
  intros beta rel atm xn P HREL HAT Hno Hcl Hatt.
  rewrite <- max_FOv_conjSO.
  apply want3_EX; try assumption.
  apply incl_FOv_att_P.
  intros HH; inversion HH; subst.
  apply att_exFO_var_REL in H2; auto.
  apply att_exFO_var_AT in H2; auto.
Qed.

Lemma lem5_atm : forall beta atm xn P,
  AT atm = true ->
  SOQFree beta = true ->
  closed_except beta (Var xn) ->
  ~att_exFO_var beta (Var xn) ->
~ ex_att_exFO_lvar
     (newnew_pre (instant_cons_empty' atm beta)
        (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' atm beta)))
        (rev_seq (S (Nat.max (Nat.max (max_FOv atm) (max_FOv beta)) xn))
           (length
              (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' atm beta))
                )))) (FOv_att_P atm P).
Proof.
  intros beta atm xn P  HAT Hno Hcl Hatt.
  apply want3_EX; try assumption.
  apply incl_FOv_att_P.
  simpl. apply att_exFO_var_AT.
  all : try assumption.
Qed.

Lemma lem2 : forall lP beta rel atm xn,
  REL rel = true ->
  AT atm = true ->
  SOQFree beta = true ->
  ~ att_allFO_var beta (Var xn) ->
  closed_except beta (Var xn) ->
~ ex_att_allFO_llvar
  (newnew_pre (instant_cons_empty' (conjSO rel atm) beta)
     (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' (conjSO rel atm) beta)))
     (rev_seq
        (S (Nat.max (Nat.max (Nat.max (max_FOv rel) (max_FOv atm)) (max_FOv beta)) xn))
        (length (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' (conjSO rel atm) beta)) ))))
  (FOv_att_P_l (conjSO rel atm) lP).
Proof.
  induction lP; intros beta rel atm xn HREL HAT Hno Hat1 Hcl H.
    inversion H.
  simpl in *. inversion H; subst.
  apply lem3 in H2; auto.
  apply IHlP in H2 ; assumption.
Qed.

Lemma lem2_atm : forall lP beta atm xn,
  AT atm = true ->
  SOQFree beta = true ->
  ~ att_allFO_var beta (Var xn) ->
  closed_except beta (Var xn) ->
~ ex_att_allFO_llvar
  (newnew_pre (instant_cons_empty' atm beta)
     (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' atm beta)))
     (rev_seq
        (S (Nat.max (Nat.max ( (max_FOv atm)) (max_FOv beta)) xn))
        (length (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' atm beta))))))
  (FOv_att_P_l atm lP).
Proof.
  induction lP; intros beta atm xn HAT Hno Hat1 Hcl H.
    inversion H.
  simpl in *. inversion H; subst.
  apply lem3_atm in H2; auto.
  apply IHlP in H2 ; assumption.
Qed.

Lemma lem4a : forall lP beta rel atm xn,
  REL rel = true ->
  AT atm = true ->
  SOQFree beta = true ->
  ~ att_exFO_var beta (Var xn) ->
  closed_except beta (Var xn) ->
~ ex_att_exFO_llvar
  (newnew_pre (instant_cons_empty' (conjSO rel atm) beta)
     (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' (conjSO rel atm) beta)))
     (rev_seq
        (S (Nat.max (Nat.max (Nat.max (max_FOv rel) (max_FOv atm)) (max_FOv beta)) xn))
        (length (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' (conjSO rel atm) beta))))))
  (FOv_att_P_l (conjSO rel atm) lP).
Proof.
  induction lP; intros beta rel atm xn HREL HAT Hno Hat1 Hcl.
  intros HH. inversion HH.
  simpl FOv_att_P_l. simpl.
  pose proof lem5 as H3. simpl in H3.
  intros HH. inversion HH; subst.
  eapply H3 in H1; try assumption.
  clear H3. apply IHlP in H1; assumption.
Qed.

Lemma lem4a_atm : forall lP beta atm xn,
  AT atm = true ->
  SOQFree beta = true ->
  ~ att_exFO_var beta (Var xn) ->
  closed_except beta (Var xn) ->
~ ex_att_exFO_llvar
  (newnew_pre (instant_cons_empty' atm beta)
     (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' atm beta)))
     (rev_seq
        (S (Nat.max (Nat.max ( (max_FOv atm)) (max_FOv beta)) xn))
        (length (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' atm beta))))))
  (FOv_att_P_l atm lP).
Proof.
  induction lP; intros beta atm xn HAT Hno Hat1 Hcl.
  intros HH. inversion HH.
  simpl FOv_att_P_l. simpl.
  pose proof lem5_atm as H3. simpl in H3.
  intros HH. inversion HH; subst.
  eapply H3 in H1; try assumption.
  clear H3. apply IHlP in H1; assumption.
Qed.

Lemma preds_in_newnew_pre : forall l1 l2 alpha,
  preds_in (newnew_pre alpha l1 l2) = (preds_in alpha).
Proof.
  induction l1; intros l2 alpha. auto.
  simpl. destruct l2. reflexivity.
  rewrite preds_in_rename_FOv. apply IHl1.
Qed.

Lemma hopeful2 : forall  lx rel atm y xn beta,
  FO_frame_condition (replace_pred_l (list_closed_allFO (implSO
    (conjSO rel atm)
    (newnew_pre (instant_cons_empty' (conjSO rel atm) beta)
      (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' (conjSO rel atm) beta)))
      (rev_seq (S (max (max_FOv (implSO (conjSO rel atm) beta)) xn))
        (length       (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' (conjSO rel atm) beta))))))) lx)
    (preds_in (list_closed_allFO
      (implSO (conjSO rel atm) beta) lx)) (list_var (length (preds_in (list_closed_allFO
      (implSO (conjSO rel atm) beta) lx))) y)
    (vsS_syn_l (FOv_att_P_l (conjSO rel atm) (preds_in (list_closed_allFO
      (implSO (conjSO rel atm) beta) lx))) y)) = true.
Proof.
  intros lx rel atm y xn beta.
  rewrite rep_pred_l_list_closed_allFO.
  rewrite FO_frame_condition_list_closed_allFO.
  rewrite rep_pred_l_implSO.
  simpl. rewrite preds_in_list_closed_allFO.
  rewrite please2.
  rewrite please2. reflexivity.
  rewrite preds_in_newnew_pre.
  apply (incl_trans _ _ _ _ (something3 _ _)).
  simpl. firstorder.
  simpl.  firstorder.
Qed.

Lemma hopeful2_atm : forall  lx atm y xn beta,
  FO_frame_condition (replace_pred_l (list_closed_allFO (implSO
    atm
    (newnew_pre (instant_cons_empty' atm beta)
      (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' atm beta)))
      (rev_seq (S (max (max_FOv (implSO atm beta)) xn))
        (length       (rem_FOv (Var xn) (FOvars_in (instant_cons_empty' atm beta))))))) lx)
    (preds_in (list_closed_allFO
      (implSO atm beta) lx)) (list_var (length (preds_in (list_closed_allFO
      (implSO atm beta) lx))) y)
    (vsS_syn_l (FOv_att_P_l atm (preds_in (list_closed_allFO
      (implSO atm beta) lx))) y)) = true.
Proof.
  intros lx atm y xn beta.
  rewrite rep_pred_l_list_closed_allFO.
  rewrite FO_frame_condition_list_closed_allFO.
  rewrite rep_pred_l_implSO.
  simpl. rewrite preds_in_list_closed_allFO.
  rewrite please2.
  rewrite please2. reflexivity.
  rewrite preds_in_newnew_pre.
  apply (incl_trans _ _ _ _ (something3 _ _)).
  simpl. firstorder.
  simpl. firstorder.
Qed.