Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.ZArith.ZArith.
Require Import Crypto.Spec.Curve25519.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Syntax.
Require Import compiler.Pipeline.
Require Import compiler.Symbols.
Require Import compiler.MMIO.
Require Import coqutil.Word.Bitwidth32.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Bedrock.Field.Interface.Compilation2.
Require Import Crypto.Bedrock.Field.Synthesis.New.UnsaturatedSolinas.
Require Import Crypto.Bedrock.Group.AdditionChains.
Require Import Crypto.Bedrock.Group.ScalarMult.LadderStep.
Require Import Crypto.Bedrock.Group.ScalarMult.CSwap.
Require Import Crypto.Bedrock.Group.ScalarMult.MontgomeryLadder.
Require Import Crypto.Bedrock.End2End.X25519.Field25519.
Require Import Crypto.Bedrock.End2End.X25519.MontgomeryLadder.
Require Import bedrock2Examples.LAN9250.
Require Import bedrock2Examples.lightbulb.
Require Import bedrock2Examples.memequal.
Require Import bedrock2Examples.memswap.
Require Import bedrock2Examples.memconst.
Require Import Rupicola.Examples.Net.IPChecksum.IPChecksum.

(******)

Require Crypto.Bedrock.End2End.RupicolaCrypto.ChaCha20.
(*
Require bedrock2.BasicC32Semantics.
Goal bedrock2.BasicC32Semantics.ext_spec = bedrock2.FE310CSemantics.ext_spec.
  reflexivity.
  cbn.
Require bedrock2.FE310CSemantics*)

(******)

Local Open Scope string_scope.
Import Syntax Syntax.Coercions NotationsCustomEntry.
Import ListNotations.
Import Coq.Init.Byte.

Definition garageowner : list byte :=
  [x7b; x06; x18; x0c; x54; x0c; xca; x9f; xa3; x16; x0b; x2f; x2b; x69; x89; x63; x77; x4c; xc1; xef; xdc; x04; x91; x46; x76; x8b; xb2; xbf; x43; x0e; x34; x34].

Local Notation ST := 0x80000000.
Local Notation PK := 0x80000040.
Local Notation BUF:= 0x80000060.

Definition initfn := func! {
  memconst_pk($PK);
  output! MMIOWRITE($0x10012038, $(Z.lor (Z.shiftl (0xf) 2) (Z.shiftl 1 9)));
  output! MMIOWRITE($0x10012008, $(Z.lor (Z.shiftl 1 11) (Z.shiftl 1 12)));
  output! MMIOWRITE($0x10024010, $2);
  unpack! err = lan9250_init()
}.

Definition loopfn := func! {
  st=$ST; pk=$PK; buf=$BUF;

  unpack! pktlen, err = recvEthernet(buf);
  require !err;
  require ($63 < pktlen);

  ethertype = load1(buf + $12) << $8 | load1(buf + $13);
  require ($1535 < ethertype);
  protocol = load1(buf+$23);
  require (protocol == $0x11);

  if $(14+20+8 +2+32 +4) == pktlen { (* getpk *)
    memswap(buf, buf+$6, $6); (* ethernet address *)
    memswap(buf+$(14+12), buf+$(14+16), $4); (* IP address *)
    memswap(buf+$(14+20+0), buf+$(14+20+2), $2); (* UDP port *)
    store1(buf+$(14+2), $0); (* ip length *)
    store1(buf+$(14+3), $(20+ 8+ 32+2)); (* ip length *)
    store1(buf+$(14+10), $0); (* preliminary ip checksum *)
    store1(buf+$(14+11), $0); (* preliminary ip checksum *)

    unpack! chk = ip_checksum(buf+$14, $20);
    store1(buf+$(14+11), chk>>$8);
    store1(buf+$(14+10), chk);

    store1(buf+$(14+20+4), $0); (* udp length *)
    store1(buf+$(14+20+5), $(8+ 32+2)); (* udp length *)
    store1(buf+$(14+20+6), $0); (* udp checksum *)
    store1(buf+$(14+20+7), $0); (* udp checksum *)

    x25519_base(buf+$(14+20+8 +2), st+$32);
    unpack! err = lan9250_tx(buf, $(14+20+8 +2+32))
  } else if $(14+20+8 +2+16 +4) == pktlen { (* operate *)
    stackalloc 32 as tmp;
    x25519(tmp, st+$32, pk);
    unpack! set0 = memequal(tmp, buf+$(14+20+8 +2), $16);
    unpack! set1 = memequal(tmp+$16, buf+$(14+20+8 +2), $16);

    io! mmio_val = MMIOREAD($0x1001200c);
    mmio_val = mmio_val & coq:(Z.clearbit (Z.clearbit (2^32-1) 11) 12);
    output! MMIOWRITE($0x1001200c, mmio_val | (set1<<$1 | set0) << $11);

    if (set0|set1) { (* rekey *)
        chacha20_block(st, st, (*nonce*)pk) (* NOTE: another impl? *)
    }
  }
}.

Import TracePredicate TracePredicateNotations SPI lightbulb_spec.
Notation OP := (lightbulb_spec.OP _).
Definition iocfg : list OP -> Prop :=
  one ("st", word.of_Z (0x10012038), word.of_Z (Z.lor (Z.shiftl (0xf) 2) (Z.shiftl 1 9))) +++
  one ("st", word.of_Z (0x10012008), word.of_Z (Z.lor (Z.shiftl 1 11) (Z.shiftl 1 12))) +++
  one ("st", word.of_Z (0x10024010), word.of_Z 2).
Definition BootSeq : list OP -> Prop :=
  iocfg +++ (lan9250_init_trace _
               ||| lan9250_boot_timeout _
               ||| (any+++spi_timeout _)).

Import WeakestPrecondition ProgramLogic SeparationLogic.
Local Notation "m =* P" := ((P%sep) m) (at level 70, only parsing) (* experiment*).
Local Notation "xs $@ a" := (Array.array ptsto (word.of_Z 1) a xs) (at level 10, format "xs $@ a").
Global Instance spec_of_initfn : spec_of "initfn" :=
  fnspec! "initfn" / bs R,
  { requires t m := m =* bs $@(word.of_Z PK) * R /\ length bs = 32%nat;
    ensures t' m' := m' =* garageowner$@(word.of_Z PK) * R /\
      exists iol, t' = iol ++ t /\
      exists ioh, mmio_trace_abstraction_relation ioh iol /\
      BootSeq ioh }.

Ltac fwd :=
  repeat match goal with
         | |- _ /\ _ => split
         | |- exists _, _ => eexists
         | _ => straightline
         end; trivial.
Ltac slv := try solve [ trivial | ecancel_assumption | SepAutoArray.listZnWords | intuition idtac | reflexivity | eassumption].

Local Instance spec_of_memconst_pk : spec_of "memconst_pk" := spec_of_memconst "memconst_pk" garageowner.
Local Instance WHY_spec_of_lan9250_init : spec_of "lan9250_init" := spec_of_lan9250_init.
Lemma initfn_ok : program_logic_goal_for_function! initfn.
Proof.
  repeat straightline.
  straightline_call.
  { ssplit. eassumption. rewrite H2. all : vm_compute; trivial. }
  repeat straightline.
  eapply WeakestPreconditionProperties.interact_nomem; repeat straightline.
  eexists; fwd; slv.
  { vm_compute. intuition congruence. }
  eapply WeakestPreconditionProperties.interact_nomem; repeat straightline.
  eexists; fwd; slv.
  { vm_compute. intuition congruence. }
  eapply WeakestPreconditionProperties.interact_nomem; repeat straightline.
  eexists; fwd; slv.
  { vm_compute. intuition congruence. }
  straightline_call; repeat straightline; fwd.
  { repeat (eapply align_trace_cons || exact (eq_sym (List.app_nil_l _)) || eapply align_trace_app). }
  { repeat (eapply List.Forall2_cons || eapply List.Forall2_refl || eapply List.Forall2_app; eauto). all: cbv[mmio_event_abstraction_relation]; eauto. }
  cbv [BootSeq ].
  eapply TracePredicate.concat_app.
  2: solve[cbv [choice]; intuition eauto].
  cbv [iocfg].
  eapply (TracePredicate.concat_app _ _ [_;_] [_]); [|cbv [one]; trivial].
  eapply (TracePredicate.concat_app _ _ [_] [_]); cbv [one]; trivial.
Qed.

Local Open Scope list_scope.
Require Crypto.Bedrock.End2End.RupicolaCrypto.Spec.
Import Tuple LittleEndianList.
Local Definition be2 z := rev (le_split 2 z).
Local Coercion to_list : tuple >-> list.
Local Coercion Z.b2z : bool >-> Z.

Definition state : Type := list byte * list byte. (* seed, xs25519 secret key *)

Definition garagedoor_iteration : state -> list (lightbulb_spec.OP _) -> state -> Prop :=
  fun '(seed, sk) ioh '(SEED, SK) =>
  (lightbulb_spec.lan9250_recv_no_packet _ ioh \/
    lightbulb_spec.lan9250_recv_packet_too_long _ ioh \/
    TracePredicate.concat TracePredicate.any (lightbulb_spec.spi_timeout _) ioh) \/
  (exists incoming, lightbulb_spec.lan9250_recv _ incoming ioh /\
  let ethertype := le_combine (rev (firstn 2 (skipn 12 incoming))) in ethertype < 1536 \/
  let ipproto := nth 23 incoming x00 in ipproto <> x11 \/
  (length incoming <> 14+20+8 +2+16 +4 /\ length incoming <> 14+20+8 +2+32 +4)%nat) \/
  exists (mac_local mac_remote : tuple byte 6),
  exists (ethertype : Z) (ih_const : tuple byte 2) (ip_length : Z) (ip_idff : tuple byte 5),
  exists (ipproto := x11) (ip_checksum : Z) (ip_local ip_remote : tuple byte 4),
  exists (udp_local udp_remote : tuple byte 2) (udp_length : Z) (udp_checksum : Z),
  exists (garagedoor_header : tuple byte 2) (garagedoor_payload : list byte),
  let incoming : list byte :=
    (mac_local ++ mac_remote ++ be2 ethertype ++
     ih_const ++ be2 ip_length ++
     ip_idff ++ [ipproto] ++ le_split 2 ip_checksum ++
     ip_remote ++ ip_local ++
     udp_remote ++ udp_local ++
     be2 udp_length ++ be2 udp_checksum ++
     garagedoor_header ++ garagedoor_payload) in
  (exists doorstate action : Naive.word32,
  TracePredicate.concat
      (lightbulb_spec.lan9250_recv _ incoming) (TracePredicate.concat
      (TracePredicate.one ("ld", lightbulb_spec.GPIO_DATA_ADDR _, doorstate))
      (TracePredicate.one ("st", lightbulb_spec.GPIO_DATA_ADDR _, action))) ioh
   /\ (
    let m := firstn 16 garagedoor_payload in
    let v := le_split 32 (F.to_Z (x25519_gallina (le_combine sk) (Field.feval_bytes(FieldRepresentation:=frep25519) garageowner))) in
    exists set0 set1 : Naive.word32,
    (word.unsigned set0 = 1 <-> firstn 16 v = m) /\
    (word.unsigned set1 = 1 <->  skipn 16 v = m) /\
    action = word.or (word.and doorstate (word.of_Z (Z.clearbit (Z.clearbit (2^32-1) 11) 12))) (word.slu (word.or (word.slu set1 (word.of_Z 1)) set0) (word.of_Z 11)) /\
    (* /\ (word.unsigned set0 <> 0 \/ word.unsigned set1 <> 0 -> SEED++SK = RupicolaCrypto.Spec.chacha20_encrypt k (Z.to_nat (word.unsigned counter)) _ _) *)
    (word.unsigned set1 = 0 -> word.unsigned set0 = 0 -> SEED=seed /\ SK=sk))) \/
  TracePredicate.concat (lightbulb_spec.lan9250_recv _ incoming)
  (lightbulb_spec.lan9250_send _
    (let ip_length := 62 in
     let udp_length := 42 in
     mac_remote ++ mac_local ++ be2 ethertype ++
     let ih C := ih_const ++ be2 ip_length ++
                 ip_idff ++ [ipproto] ++ le_split 2 C ++
                 ip_local ++ ip_remote in
     ih (Spec.ip_checksum (ih 0)) ++
     udp_local ++ udp_remote ++
     be2 udp_length ++ be2 0 ++
     garagedoor_header ++
     le_split 32 (F.to_Z (x25519_gallina (le_combine sk) (F.of_Z Field.M_pos 9)))))
  ioh /\ SEED=seed /\ SK=sk.

Local Instance spec_of_recvEthernet : spec_of "recvEthernet" := spec_of_recvEthernet.
Local Instance spec_of_lan9250_tx : spec_of "lan9250_tx" := spec_of_lan9250_tx.
Local Instance spec_of_memswap : spec_of "memswap" := spec_of_memswap.
Local Instance spec_of_memequal : spec_of "memequal" := spec_of_memequal.

Definition memrep bs R : state -> map.rep(map:=SortedListWord.map _ _) -> Prop := fun '(seed, sk) m =>
  m =*
    seed$@(word.of_Z ST) *
    sk$@(word.add (word.of_Z ST) (word.of_Z 32)) *
    garageowner$@(word.of_Z PK) *
    bs $@(word.of_Z BUF) * R /\
  length seed = 32%nat /\
  length sk = 32%nat /\
  length bs = 1520%nat.

Global Instance spec_of_loopfn : spec_of "loopfn" :=
  fnspec! "loopfn" / seed sk bs R,
  { requires t m := memrep bs R (seed, sk) m;
    ensures T M := exists SEED SK BS, memrep BS R (SEED, SK) M /\
    exists iol, T = iol ++ t /\
    exists ioh, SPI.mmio_trace_abstraction_relation ioh iol /\
    garagedoor_iteration (seed, sk) ioh (SEED, SK) }.

Import ZnWords.
Import coqutil.Tactics.autoforward.

Import Crypto.Util.FixCoqMistakes.

Local Existing Instance ChaCha20.spec_of_chacha20.

Lemma loopfn_ok : program_logic_goal_for_function! loopfn.
Proof.
  straightline.
  cbv [memrep garagedoor_iteration] in *.
  repeat straightline.
  rename H11 into Lseed. rename H12 into Lsk. rename H13 into H11.
  straightline_call; try ecancel_assumption; trivial; repeat straightline.
  intuition idtac; repeat straightline;
  eexists; split; repeat straightline; split; intros; try contradiction; [|]; repeat straightline.
  2: fwd; slv.

  pose proof H12 as Hbuf.
  seprewrite_in @bytearray_index_merge Hbuf. { ZnWords. }

  eexists; split; repeat straightline.
  rewrite word.unsigned_ltu, ?word.unsigned_of_Z_nowrap by ZnWords.ZnWords;
  destr Z.ltb; rewrite ?word.unsigned_of_Z_0, ?word.unsigned_of_Z_1; intuition try discriminate;
  autoforward with typeclass_instances in E.
  2: { fwd; slv. right. left. fwd; slv; intuition try ZnWords. }

  repeat straightline.
  eapply WeakestPreconditionProperties.dexpr_expr.
  eexists; split; repeat straightline.

  case (SepAutoArray.list_expose_nth x3 12 ltac:(ZnWords)) as (Hpp&Lpp).
  forget (List.firstn 12 x3) as mac.
  forget (nth 12 x3 Inhabited.default) as ethertype_hi.
  forget (List.skipn 13 x3) as pp.
  subst x3.
  repeat seprewrite_in @Array.bytearray_append H12; cbn [Array.array] in H12.
  rewrite ?app_length in *; cbn [length] in *; rewrite ?Lpp in *.
  change (Z.of_nat 12) with 12 in *.

  repeat straightline.

  destruct pp as [|ethertype_lo pp]; cbn [length app Array.array] in *.
  { exfalso; ZnWords. }
  Import SetEvars coqutil.Tactics.eplace Word.Naive LittleEndianList.
  eplace (word.add (word.add buf _) _) with (word.add buf _) in H12 by (ring_simplify; trivial).
  repeat straightline.

  let v := match goal with l := map.put _ "ethertype" ?v |- _ => v end in
  remember v as ethertype in *;
  assert (word.unsigned ethertype = le_combine [ethertype_lo; ethertype_hi]);
   [ rewrite Heqethertype | ]; clear Heqethertype.
  { pose proof byte.unsigned_range ethertype_hi.
    pose proof byte.unsigned_range ethertype_lo.
    subst_words.
    cbn [le_combine]. rewrite ?Z.shiftl_0_l, ?Z.lor_0_r.
    rewrite_strat (bottomup (terms word.unsigned_or_nowrap word.unsigned_and_nowrap word.unsigned_of_Z word.unsigned_slu)).
    2: ZnWords.
    cbv [word.wrap]; (rewrite_strat (bottomup (terms (Zmod_small)))); try ZnWords.ZnWords.
    { rewrite Z.lor_comm; reflexivity. } }

  eexists; split; repeat straightline.
  rewrite word.unsigned_ltu, ?word.unsigned_of_Z_nowrap by ZnWords.ZnWords;
  destr Z.ltb; rewrite ?word.unsigned_of_Z_0, ?word.unsigned_of_Z_1; intuition try discriminate;
  autoforward with typeclass_instances in E0.
  2: {
    fwd; slv; [].
    right. left. eexists. ssplit; try eassumption. left.
    rewrite skipn_app, skipn_all2, ?Lpp, ?app_nil_l by ZnWords.
    cbn [List.skipn minus firstn List.firstn List.app rev]. ZnWords. }

  case (SepAutoArray.list_expose_nth pp 9 ltac:(ZnWords)) as (Hppp&Lppp).
  forget (List.firstn 9 pp) as ih_l.
  forget (nth 9 pp Inhabited.default) as ipproto.
  forget (List.skipn 10 pp) as ppp.
  subst pp.
  repeat seprewrite_in @Array.bytearray_append H12; cbn [Array.array] in H12.
  rewrite ?app_length in *; cbn [length] in *; rewrite ?Lppp in *.
  change (Z.of_nat 9) with 9 in *.
  change (Z.of_nat 1) with 1 in *.

  repeat eplace (word.add (word.add buf _) _) with (word.add buf _) in H12 by (ring_simplify; trivial).

  repeat straightline.
  eexists; split; repeat straightline.
  subst protocol.
  pose proof byte.unsigned_range ipproto.
  rewrite word.unsigned_eqb, ?word.unsigned_and_nowrap, ?word.unsigned_of_Z_nowrap by ZnWords.ZnWords.
  destr Z.eqb; rewrite ?word.unsigned_of_Z_0, ?word.unsigned_of_Z_1; intuition try discriminate; autoforward with typeclass_instances in E1.
  2: {
    fwd; slv; [].
    right. left. eexists. ssplit; try eassumption. right. left.
    rewrite app_nth2 by ZnWords.
    rewrite app_comm_cons.
    rewrite app_nth2 by SepAutoArray.listZnWords.
    rewrite app_nth2 by SepAutoArray.listZnWords.
    rewrite app_nth1 by SepAutoArray.listZnWords.
    match goal with |- context[nth ?x] => replace x with O by SepAutoArray.listZnWords end.
    cbn. intro. subst. apply E1. reflexivity. }

  repeat straightline.
  eexists; split; repeat straightline.
  rewrite word.unsigned_eqb, ?word.unsigned_of_Z_nowrap by ZnWords.ZnWords.
  destr Z.eqb; rewrite ?word.unsigned_of_Z_0, ?word.unsigned_of_Z_1; intuition try discriminate; autoforward with typeclass_instances in E2.

  2: {
    repeat straightline.
    eexists; split; repeat straightline.
    rewrite word.unsigned_eqb, ?word.unsigned_of_Z_nowrap by ZnWords.ZnWords.
    destr Z.eqb; rewrite ?word.unsigned_of_Z_0, ?word.unsigned_of_Z_1; intuition try discriminate; autoforward with typeclass_instances in E3.
    2: {
      fwd; slv.
      right. left. eexists. ssplit; try eassumption. right. right. SepAutoArray.listZnWords. }
    repeat straightline.
    straightline_call; ssplit; try ecancel_assumption; try trivial; try ZnWords.
    { cbv. inversion 1. }

    rename Lppp into Lihl; assert (List.length ppp = 40)%nat as Lppp by ZnWords.

    repeat straightline.
    pose proof (List.firstn_skipn (14+20+8 +2 - 12-2-9-1) ppp) as HH.
    pose proof (@firstn_length_le _ ppp (14+20+8 +2 - 12-2-9-1) ltac:(ZnWords)).
    pose proof skipn_length (14+20+8 +2 - 12-2-9-1) ppp; rewrite Lppp in *.
    forget (List.firstn (14+20+8 +2 - 12-2-9-1) ppp) as pPP.
    forget (List.skipn (14+20+8 +2 - 12-2-9-1) ppp) as pPPP.
    simpl minus in H31, H32.
    subst ppp.
    repeat rewrite ?(app_assoc _ _ pPPP), ?app_comm_cons in H33.
    do 3 (seprewrite_in @Array.bytearray_append H33; cbn [Array.array] in H33).

    change (unsigned x) with (@word.unsigned _ word32 x) in H32.
    repeat straightline.
    pose proof (List.firstn_skipn 16 pPPP) as HH.
    pose proof (@firstn_length_le _ pPPP 16 ltac:(ZnWords)).
    pose proof skipn_length 16 pPPP. rewrite H32 in *.
    forget (List.firstn 16 pPPP) as cmp1.
    forget (List.skipn 16 pPPP) as trailer.
    subst pPPP.
    seprewrite_in_by (Array.bytearray_append cmp1) H33 SepAutoArray.listZnWords.

    remember (le_split 32 (F.to_Z (x25519_gallina (le_combine sk) (Field.feval_bytes _)))) as vv.
    repeat straightline.
    pose proof (List.firstn_skipn 16 vv) as Hvv.
    pose proof (@firstn_length_le _ vv 16 ltac:(subst vv; rewrite ?length_le_split; ZnWords)).
    pose proof skipn_length 16 vv.
    forget (List.firstn 16 vv) as vv0.
    forget (List.skipn 16 vv) as vv1.
    subst vv.
    rewrite <-Hvv in H33.
    rewrite length_le_split in *.
    seprewrite_in_by (Array.bytearray_append vv0) H33 SepAutoArray.listZnWords.

    repeat straightline.
    straightline_call; ssplit.
    { ecancel_assumption. }
    { use_sep_assumption. cancel. cancel_seps_at_indices 2%nat 0%nat.
      { Morphisms.f_equiv. SepAutoArray.listZnWords. }
      ecancel_done. }
    { ZnWords. }
    { ZnWords. }
    repeat straightline.

    repeat straightline.
    straightline_call; ssplit.
    { use_sep_assumption. cancel. cancel_seps_at_indices 1%nat 0%nat.
      { Morphisms.f_equiv. SepAutoArray.listZnWords. }
      ecancel_done. }
    { use_sep_assumption. cancel. cancel_seps_at_indices 2%nat 0%nat.
      { Morphisms.f_equiv. SepAutoArray.listZnWords. }
      ecancel_done. }
    { ZnWords. }
    { ZnWords. }

    repeat straightline.
    eexists. split. repeat straightline.
    eexists _, _; split; [eapply map.split_empty_r; reflexivity|].
    eexists; ssplit; trivial.
    { cbv. clear. intuition congruence. }

    repeat straightline.
    eexists. split. repeat straightline.
    eexists _, _; split; [eapply map.split_empty_r; reflexivity|].
    eexists; ssplit; trivial.
    eexists; ssplit; trivial.
    { cbv. clear. intuition congruence. }
    repeat straightline.

    eapply map.split_empty_r in H38; destruct H38.
    eapply map.split_empty_r in H39; destruct H39.
    seprewrite_in_by @bytearray_index_merge H33 SepAutoArray.listZnWords.
    seprewrite_in_by @bytearray_index_merge H33 SepAutoArray.listZnWords.
    seprewrite_in_by @bytearray_index_merge H33 SepAutoArray.listZnWords.
    seprewrite_in_by @bytearray_index_merge H33 SepAutoArray.listZnWords.
    seprewrite_in_by @bytearray_index_merge H33 SepAutoArray.listZnWords.
    assert (length (vv0 ++ vv1) = 32%nat) by SepAutoArray.listZnWords.

    change (word.of_Z 134217728) with st in H33.
    repeat straightline.
    eexists; ssplit; repeat straightline.
    { (* chacha20 *)
      (* NOTE: viewing the same memory in two different ways, ++ combined and split *)
      straightline_call; ssplit.
      { seprewrite_in_by @bytearray_index_merge H33 SepAutoArray.listZnWords.
        ecancel_assumption. }
      { SepAutoArray.listZnWords. }
      { ecancel_assumption. }
      { SepAutoArray.listZnWords. }
      { rewrite <-(List.firstn_skipn 12 garageowner) in H33.
        seprewrite_in_by (Array.bytearray_append (List.firstn 12 garageowner)) H33 SepAutoArray.listZnWords.
        ecancel_assumption. }
      { SepAutoArray.listZnWords. }
      repeat straightline.

      rewrite <-(List.firstn_skipn 32 x6) in H46.
      seprewrite_in_by (Array.bytearray_append (List.firstn 32 x6)) H46 SepAutoArray.listZnWords.
      replace (word.of_Z (BinInt.Z.of_nat (Datatypes.length (List.firstn 32 x6)))) with (word.of_Z 32 : word32) in * by SepAutoArray.listZnWords.

      ssplit; trivial.
      eexists _, _, _; ssplit; try ecancel_assumption; try SepAutoArray.listZnWords.

    eexists; ssplit.
    { subst a0 a. change (?x::?y::?t) with ([x;y]++t). rewrite app_assoc. trivial. }
    eexists; ssplit.
    { eapply Forall2_app; try eassumption.
      eapply Forall2_cons. 2:eapply Forall2_cons. 3:eapply Forall2_nil.
      all:[>left|right]; eexists _, _; ssplit; trivial. }
    right.
    right.
    eexists _, _, _, _, _, _, _, _, _, _, _, _, _, _, _. left; ssplit; trivial.
    eexists _, _.
    split.
    {
    eapply TracePredicate.concat_app.
    1: match goal with |- _ ?x _ => eplace x with _ end; [|eassumption].

    symmetry. (* NOTE: systematic list cancellation *)
    rewrite <-(firstn_skipn 6 mac) at 1; rewrite <-?app_assoc.
    eapply (f_equal2 app); [rewrite to_list_from_list; trivial|].
    eapply (f_equal2 app); [rewrite to_list_from_list; trivial|].
    change ([?x]++?y::?z) with ([x;y]++z).
    eapply (f_equal2 app).
    { cbv [be2]. progress change 2%nat with (List.length [ethertype_lo; ethertype_hi]).
      setoid_rewrite split_le_combine; trivial. }
    rewrite <-(firstn_skipn 2 ih_l) at 1; rewrite <-?app_assoc.
    eapply (f_equal2 app); [rewrite to_list_from_list; trivial|].
    rewrite <-(firstn_skipn 2 (List.skipn _ _)) at 1; rewrite <-?app_assoc, ?List.skipn_skipn.
    eapply (f_equal2 app).
    { cbv [be2]. eplace 2%nat with _ at 3; cycle 1.
      rewrite split_le_combine, rev_involutive; trivial.
      rewrite rev_length. SepAutoArray.listZnWords. }
    eapply (f_equal2 app); [rewrite to_list_from_list; trivial|].
    eapply (f_equal2 app). { f_equal. eapply byte.unsigned_inj. rewrite E1. trivial. }
    rewrite <-(firstn_skipn 2 pPP) at 1; rewrite <-?app_assoc.
    eapply (f_equal2 app).
    { eplace 2%nat with _ at 2; cycle 1.
      rewrite split_le_combine; trivial.
      SepAutoArray.listZnWords. }
    rewrite <-(firstn_skipn 4 (List.skipn _ _)) at 1; rewrite <-?app_assoc, ?List.skipn_skipn.
    eapply (f_equal2 app); [rewrite to_list_from_list; trivial|].
    rewrite <-(firstn_skipn 4 (List.skipn _ _)) at 1; rewrite <-?app_assoc, ?List.skipn_skipn.
    eapply (f_equal2 app); [rewrite to_list_from_list; trivial|].
    rewrite <-(firstn_skipn 2 (List.skipn _ _)) at 1; rewrite <-?app_assoc, ?List.skipn_skipn.
    eapply (f_equal2 app); [rewrite to_list_from_list; trivial|].
    rewrite <-(firstn_skipn 2 (List.skipn _ _)) at 1; rewrite <-?app_assoc, ?List.skipn_skipn.
    eapply (f_equal2 app); [rewrite to_list_from_list; trivial|].
    rewrite <-(firstn_skipn 2 (List.skipn _ _)) at 1; rewrite <-?app_assoc, ?List.skipn_skipn.
    eapply (f_equal2 app).
    { cbv [be2]. eplace 2%nat with _ at 7; cycle 1.
      rewrite split_le_combine, rev_involutive; trivial.
      rewrite rev_length. SepAutoArray.listZnWords. }
    rewrite <-(firstn_skipn 2 (List.skipn _ _)) at 1; rewrite <-?app_assoc, ?List.skipn_skipn.
    eapply (f_equal2 app).
    { cbv [be2]. eplace 2%nat with _ at 8; cycle 1.
      rewrite split_le_combine, rev_involutive; trivial.
      rewrite rev_length. SepAutoArray.listZnWords. }
    eapply (f_equal2 app). { rewrite to_list_from_list; trivial. }
    reflexivity.

    change [?x;?y] with ([x]++[y]).
    eapply TracePredicate.concat_app; cbv [TracePredicate.one]; f_equal. }

    rewrite <-Hvv.
    rewrite !ListUtil.firstn_app_sharp by ZnWords.
    rewrite !ListUtil.skipn_app_sharp by ZnWords.
    eexists _, _; ssplit; try eassumption; subst mmio_val; eauto.

    intros; exfalso. apply H39.
    rewrite word.unsigned_or_nowrap. apply Z.lor_eq_0_iff; auto.
    (* end chacha20*) }

Optimize Proof. Optimize Heap.

    ssplit; trivial.
    eexists _, _, _; ssplit; try ecancel_assumption; try SepAutoArray.listZnWords.
    eexists; ssplit.
    { subst a. change (?x::?y::?t) with ([x;y]++t). rewrite app_assoc. trivial. }
    eexists; ssplit.
    { eapply Forall2_app; try eassumption.
      eapply Forall2_cons. 2:eapply Forall2_cons. 3:eapply Forall2_nil.
      all:[>left|right]; eexists _, _; ssplit; trivial. }
    right.
    right.
    eexists _, _, _, _, _, _, _, _, _, _, _, _, _, _, _. left; ssplit; trivial.
    eexists _, _.
    split.
    {
    eapply TracePredicate.concat_app.
    1: match goal with |- _ ?x _ => eplace x with _ end; [|eassumption].

    symmetry. (* NOTE: systematic list cancellation *)
    rewrite <-(firstn_skipn 6 mac) at 1; rewrite <-?app_assoc.
    eapply (f_equal2 app); [rewrite to_list_from_list; trivial|].
    eapply (f_equal2 app); [rewrite to_list_from_list; trivial|].
    change ([?x]++?y::?z) with ([x;y]++z).
    eapply (f_equal2 app).
    { cbv [be2]. progress change 2%nat with (List.length [ethertype_lo; ethertype_hi]).
      setoid_rewrite split_le_combine; trivial. }
    rewrite <-(firstn_skipn 2 ih_l) at 1; rewrite <-?app_assoc.
    eapply (f_equal2 app); [rewrite to_list_from_list; trivial|].
    rewrite <-(firstn_skipn 2 (List.skipn _ _)) at 1; rewrite <-?app_assoc, ?List.skipn_skipn.
    eapply (f_equal2 app).
    { cbv [be2]. eplace 2%nat with _ at 3; cycle 1.
      rewrite split_le_combine, rev_involutive; trivial.
      rewrite rev_length. SepAutoArray.listZnWords. }
    eapply (f_equal2 app); [rewrite to_list_from_list; trivial|].
    eapply (f_equal2 app). { f_equal. eapply byte.unsigned_inj. rewrite E1. trivial. }
    rewrite <-(firstn_skipn 2 pPP) at 1; rewrite <-?app_assoc.
    eapply (f_equal2 app).
    { eplace 2%nat with _ at 2; cycle 1.
      rewrite split_le_combine; trivial.
      SepAutoArray.listZnWords. }
    rewrite <-(firstn_skipn 4 (List.skipn _ _)) at 1; rewrite <-?app_assoc, ?List.skipn_skipn.
    eapply (f_equal2 app); [rewrite to_list_from_list; trivial|].
    rewrite <-(firstn_skipn 4 (List.skipn _ _)) at 1; rewrite <-?app_assoc, ?List.skipn_skipn.
    eapply (f_equal2 app); [rewrite to_list_from_list; trivial|].
    rewrite <-(firstn_skipn 2 (List.skipn _ _)) at 1; rewrite <-?app_assoc, ?List.skipn_skipn.
    eapply (f_equal2 app); [rewrite to_list_from_list; trivial|].
    rewrite <-(firstn_skipn 2 (List.skipn _ _)) at 1; rewrite <-?app_assoc, ?List.skipn_skipn.
    eapply (f_equal2 app); [rewrite to_list_from_list; trivial|].
    rewrite <-(firstn_skipn 2 (List.skipn _ _)) at 1; rewrite <-?app_assoc, ?List.skipn_skipn.
    eapply (f_equal2 app).
    { cbv [be2]. eplace 2%nat with _ at 7; cycle 1.
      rewrite split_le_combine, rev_involutive; trivial.
      rewrite rev_length. SepAutoArray.listZnWords. }
    rewrite <-(firstn_skipn 2 (List.skipn _ _)) at 1; rewrite <-?app_assoc, ?List.skipn_skipn.
    eapply (f_equal2 app).
    { cbv [be2]. eplace 2%nat with _ at 8; cycle 1.
      rewrite split_le_combine, rev_involutive; trivial.
      rewrite rev_length. SepAutoArray.listZnWords. }
    eapply (f_equal2 app). { rewrite to_list_from_list; trivial. }
    reflexivity.

    change [?x;?y] with ([x]++[y]).
    eapply TracePredicate.concat_app; cbv [TracePredicate.one]; f_equal. }

    rewrite <-Hvv.
    rewrite !ListUtil.firstn_app_sharp by ZnWords.
    rewrite !ListUtil.skipn_app_sharp by ZnWords.
    eexists _, _; ssplit; try eassumption; subst mmio_val; eauto.
  }

  {
    repeat straightline.
    pose proof (List.firstn_skipn 6 mac) as HH.
    pose proof (@firstn_length_le _ mac 6 ltac:(ZnWords)).
    pose proof skipn_length 6 mac; rewrite ?Lpp in *.
    forget (List.firstn 6 mac) as mac_local.
    forget (List.skipn 6 mac) as mac_remote.
    subst mac.
    repeat seprewrite_in @Array.bytearray_append H12; cbn [Array.array] in H12.
    rewrite H26 in *.
    change (Z.of_nat 6) with 6 in *.

    straightline_call; ssplit; try ecancel_assumption; try ZnWords.

    repeat straightline.

    pose proof (List.firstn_skipn 2 ppp) as HH.
    pose proof (@firstn_length_le _ ppp 2 ltac:(ZnWords)).
    pose proof skipn_length 2 ppp as Lip_checksum.
    forget (List.firstn 2 ppp) as ip_checksum.
    forget (List.skipn 2 ppp) as pppp.
    subst ppp; rewrite ?app_length in *.
    repeat seprewrite_in @Array.bytearray_append H29; cbn [Array.array] in H29.
    rewrite ?H28 in *.
    change (Z.of_nat 24) with 24 in *.
    change (Z.of_nat 2) with 2 in *.
    eplace (word.add (word.add buf _) _) with (word.add buf _) in H29 by (ring_simplify; trivial).

    pose proof (List.firstn_skipn 4 pppp) as HH.
    pose proof (@firstn_length_le _ pppp 4 ltac:(ZnWords)).
    forget (List.firstn 4 pppp) as ip_remote.
    forget (List.skipn 4 pppp) as ppppp.
    subst pppp; rewrite ?app_length in *.
    repeat seprewrite_in @Array.bytearray_append H29; cbn [Array.array] in H29.
    rewrite ?H30 in *.
    change (Z.of_nat 28) with 28 in *.
    change (Z.of_nat 4) with 4 in *.
    eplace (word.add (word.add buf _) _) with (word.add buf _) in H29 by (ring_simplify; trivial).

    pose proof (List.firstn_skipn 4 ppppp) as HH.
    pose proof (@firstn_length_le _ ppppp 4 ltac:(ZnWords)).
    forget (List.firstn 4 ppppp) as ip_local.
    forget(List.skipn 4 ppppp) as pppppp.
    subst ppppp; rewrite ?app_length in *.
    repeat seprewrite_in @Array.bytearray_append H29; cbn [Array.array] in H29.
    rewrite ?H31 in *.
    change (Z.of_nat 30) with 30 in *.
    change (Z.of_nat 4) with 4 in *.
    eplace (word.add (word.add buf _) _) with (word.add buf _) in H29 by (ring_simplify; trivial).

    straightline_call; ssplit; try ecancel_assumption; try ZnWords.

    repeat straightline.

    pose proof (List.firstn_skipn 2 pppppp) as HH.
    pose proof (@firstn_length_le _ pppppp 2 ltac:(ZnWords)).
    forget (List.firstn 2 pppppp) as udp_remote.
    forget(List.skipn 2 pppppp) as pP.
    subst pppppp; rewrite ?app_length in *.
    repeat seprewrite_in @Array.bytearray_append H33; cbn [Array.array] in H33.
    rewrite ?H32 in *.
    change (Z.of_nat 34) with 34 in *.
    change (Z.of_nat 4) with 4 in *.
    eplace (word.add (word.add buf _) _) with (word.add buf _) in H33 by (ring_simplify; trivial).

    pose proof (List.firstn_skipn 2 pP) as HH.
    pose proof (@firstn_length_le _ pP 2 ltac:(ZnWords)).
    forget (List.firstn 2 pP) as udp_local.
    forget(List.skipn 2 pP) as pPP.
    subst pP; rewrite ?app_length in *.
    repeat seprewrite_in @Array.bytearray_append H33; cbn [Array.array] in H33.
    rewrite ?H34 in *.
    change (Z.of_nat 36) with 36 in *.
    change (Z.of_nat 4) with 4 in *.
    eplace (word.add (word.add buf _) _) with (word.add buf _) in H33 by (ring_simplify; trivial).

    straightline_call; ssplit; try ecancel_assumption; try ZnWords.

    repeat straightline.

    case (SepAutoArray.list_expose_nth ih_l 2 ltac:(ZnWords)) as (HH&LL).
    forget (List.firstn 2 ih_l) as ih_const.
    forget (nth 2 ih_l Inhabited.default) as ip_length_hi.
    forget (List.skipn 3 ih_l) as ip_length_lo.
    subst ih_l.
    repeat seprewrite_in @Array.bytearray_append H36; cbn [Array.array] in H36.
    rewrite ?app_length in *; cbn [length] in *; rewrite ?LL in *.
    change (Z.of_nat 1) with 1 in *.
    change (Z.of_nat 2) with 2 in *.
    eplace (word.add (word.add buf _) _) with (word.add buf _) in H36 by (ring_simplify; trivial).
    eplace (word.add (word.add buf _) _) with (word.add buf _) in H36 by (ring_simplify; trivial).

    repeat straightline.

    destruct ip_length_lo as [|ip_length_lo ip_idff ].
    { cbn [length] in *. exfalso; Lia.lia. }
    cbn [Array.array] in *.
    eplace (word.add (word.add buf _) _) with (word.add buf _) in H35 by (ring_simplify; trivial).

    repeat straightline.
    destruct ip_checksum as [|ip_checksum_0 [|ip_checksum_1 [|] ] ];
        try (cbn [length] in *; discriminate); cbn [Array.array] in *.
    eplace (word.add (word.add buf _) _) with (word.add buf _) in H37 by (ring_simplify; trivial).

    straightline.
    straightline.
    straightline.
    straightline.
    straightline.
    straightline.
    straightline.
    repeat straightline.
    assert (ptsto_to_array :
      forall {width : Z} {word : Interface.word width},
      word.ok word ->
      forall mem : map.map (word.rep(word:=word)) Byte.byte,
      map.ok mem -> forall a b,
      Lift1Prop.iff1 (ptsto a b) (Array.array(mem:=mem) ptsto (word.of_Z 1) a [b])).
    { cbn [Array.array]. intros. cancel. }

    assert (bytearray_address_merge :
  forall {width : Z} {word : Interface.word width},
  word.ok word ->
  forall mem : map.map (word.rep(word:=word)) Byte.byte,
  map.ok mem ->
  forall (xs ys : list byte) (start b : word.rep),
  word.unsigned (word.sub b start) = Z.of_nat (Datatypes.length xs) ->
  Lift1Prop.iff1 (xs$@start ⋆ ys$@b) ((xs ++ ys)$@start : mem -> Prop)).
  { intros.
    replace b with (word.add start (word.sub b start)).
    { eapply Array.bytearray_index_merge; trivial. }
    eapply word.unsigned_inj. rewrite ?word.unsigned_add, ?word.unsigned_sub.
    cbv [word.wrap].
    rewrite Zplus_mod_idemp_r.
    transitivity (word.unsigned b mod 2^width).
    { f_equal.  ring. }
    rewrite Z.mod_small; trivial; eapply word.unsigned_range. }

Optimize Proof. Optimize Heap.

  repeat seprewrite_in @ptsto_to_array H39.
  rewrite ?word.unsigned_of_Z_nowrap in H39 by ZnWords.
  seprewrite_in_by (@bytearray_address_merge _ _ _ _ _ ih_const) H39 ZnWords.
  seprewrite_in_by (fun x=>@bytearray_address_merge _ _ _ _ _ (ih_const++x)%list) H39 SepAutoArray.listZnWords.
  rewrite <-app_assoc in H39.
  seprewrite_in_by (fun x=>@bytearray_address_merge _ _ _ _ _ (ih_const++x)%list) H39 SepAutoArray.listZnWords.
  rewrite <-!app_assoc in H39.
  cbn [length] in *.
  seprewrite_in_by (fun x=>@bytearray_address_merge _ _ _ _ _ (ih_const++x)%list) H39 SepAutoArray.listZnWords.
  rewrite <-!app_assoc in H39.
  seprewrite_in_by (fun x=>@bytearray_address_merge _ _ _ _ _ (ih_const++x)%list) H39 SepAutoArray.listZnWords.
  rewrite <-!app_assoc in H39.
  seprewrite_in_by (fun x=>@bytearray_address_merge _ _ _ _ _ (ih_const++x)%list) H39 SepAutoArray.listZnWords.
  rewrite <-!app_assoc in H39.
  seprewrite_in_by (fun x=>@bytearray_address_merge _ _ _ _ _ (ih_const++x)%list) H39 SepAutoArray.listZnWords.
  rewrite <-!app_assoc in H39.
  seprewrite_in_by (fun x=>@bytearray_address_merge _ _ _ _ _ (ih_const++x)%list) H39 SepAutoArray.listZnWords.

  straightline_call; [(ssplit; cycle -1)|];
    cbv [Arrays.listarray_value Arrays.ai_repr Arrays._access_info Arrays.ai_width Arrays.ai_size Arrays.ai_type Memory.bytes_per] in *;
    change (Z.of_nat 1) with 1%Z in *;
    try ecancel_assumption;
    try SepAutoArray.listZnWords.

Optimize Proof. Optimize Heap.

  repeat straightline.

  repeat match goal with x := word.of_Z 0 |- _ => subst x end.
  repeat match goal with x := word.of_Z 62 |- _ => subst x end.
  rewrite !word.unsigned_of_Z_nowrap in H43 by Lia.lia.
  progress replace  ((ih_const ++ [byte.of_Z 0] ++ [byte.of_Z 62] ++ ip_idff ++ [ipproto] ++ [byte.of_Z 0] ++ [byte.of_Z 0] ++ ip_local) ++ ip_remote)%list
    with ((ih_const ++ [byte.of_Z 0] ++ [byte.of_Z 62] ++ ip_idff ++ [ipproto]) ++ [byte.of_Z 0] ++ [byte.of_Z 0] ++ ip_local ++ ip_remote)%list
    in * by (rewrite ?app_assoc; trivial).
  seprewrite_in @Array.bytearray_append H43.
  seprewrite_in (@Array.bytearray_append _ _ _ _ _ [byte.of_Z 0]) H43.
  seprewrite_in (@Array.bytearray_append _ _ _ _ _ [byte.of_Z 0]) H43.
  rewrite ?app_length in H43; cbn [length] in H43; rewrite ?LL in H43.
  replace (Datatypes.length ip_idff) with 5%nat in H43 by ZnWords.
  cbn [plus] in H43.
  repeat eplace (word.add (word.add buf _) _) with (word.add buf _) in H43 by (ring_simplify; trivial).

  Import symmetry.
  seprewrite_in (symmetry! (fun a=>@ptsto_to_array _ _ _ _ _ a (byte.of_Z 0))) H43.
  seprewrite_in (symmetry! (fun a=>@ptsto_to_array _ _ _ _ _ a (byte.of_Z 0))) H43.

  repeat straightline.
  match goal with H : ?P ?m |- store _ ?m _ _ _ => revert H end.
  repeat match goal with H : sep _ _ _ |- _ => clear H end.
  repeat straightline.

  do 6 (destruct pPP as [|? pPP]; (cbn [Datatypes.length] in *; try Lia.lia)).
  set ((b :: b0 :: b1 :: b2 :: b3 :: b4 :: pPP)$@(word.add buf (word.of_Z 38))) as X in H40.
  cbn [Array.array] in X. subst X.
  repeat eplace (word.add (word.add buf _) _) with (word.add buf _) in H40 by (ring_simplify; trivial).

  repeat straightline.
  pose proof (List.firstn_skipn 32 pPP) as HH.
  pose proof (@firstn_length_le _ pPP 32 ltac:(ZnWords)).
  forget (List.firstn 32 pPP) as _pkpad.
  forget(List.skipn 32 pPP) as pPPP.
  subst pPP; rewrite ?app_length in *.
  repeat seprewrite_in (@Array.bytearray_append _ _ _ _ _ _pkpad) H29.
  rewrite ?H33 in *.
  change (Z.of_nat 32) with 32 in *.
  repeat eplace (word.add (word.add buf _) _) with (word.add buf _) in H29 by (ring_simplify; trivial).
  straightline_call; ssplit; try ecancel_assumption; trivial.

Optimize Proof. Optimize Heap.

  repeat straightline.

  revert H37.
  repeat match goal with H : sep _ _ _ |- _ => clear H end.
  intros.
  repeat seprewrite_in @ptsto_to_array H37.
  seprewrite_in_by (fun xs ys=>@bytearray_address_merge _ _ _ _ _ xs ys buf) H37 ZnWords.
  seprewrite_in_by (fun xs ys=>@bytearray_address_merge _ _ _ _ _ xs ys buf) H37 SepAutoArray.listZnWords.
  seprewrite_in_by (fun xs ys=>@bytearray_address_merge _ _ _ _ _ xs ys buf) H37 SepAutoArray.listZnWords.
  seprewrite_in_by (fun xs ys=>@bytearray_address_merge _ _ _ _ _ xs ys buf) H37 SepAutoArray.listZnWords.
  seprewrite_in_by (fun xs ys=>@bytearray_address_merge _ _ _ _ _ xs ys buf) H37 SepAutoArray.listZnWords.
  seprewrite_in_by (fun xs ys=>@bytearray_address_merge _ _ _ _ _ xs ys buf) H37 SepAutoArray.listZnWords.
  seprewrite_in_by (fun xs ys=>@bytearray_address_merge _ _ _ _ _ xs ys buf) H37 SepAutoArray.listZnWords.
Optimize Proof. Optimize Heap.
  seprewrite_in_by (fun xs ys=>@bytearray_address_merge _ _ _ _ _ xs ys buf) H37 SepAutoArray.listZnWords.
  seprewrite_in_by (fun xs ys=>@bytearray_address_merge _ _ _ _ _ xs ys buf) H37 SepAutoArray.listZnWords.
  seprewrite_in_by (fun xs ys=>@bytearray_address_merge _ _ _ _ _ xs ys buf) H37 SepAutoArray.listZnWords.
  seprewrite_in_by (fun xs ys=>@bytearray_address_merge _ _ _ _ _ xs ys buf) H37 SepAutoArray.listZnWords.
Optimize Proof. Optimize Heap.
  seprewrite_in_by (fun xs ys=>@bytearray_address_merge _ _ _ _ _ xs ys buf) H37 SepAutoArray.listZnWords.
  seprewrite_in_by (fun xs ys=>@bytearray_address_merge _ _ _ _ _ xs ys buf) H37 SepAutoArray.listZnWords.
  seprewrite_in_by (fun xs ys=>@bytearray_address_merge _ _ _ _ _ xs ys buf) H37 SepAutoArray.listZnWords.
  seprewrite_in_by (fun xs ys=>@bytearray_address_merge _ _ _ _ _ xs ys buf) H37 SepAutoArray.listZnWords.
  seprewrite_in_by (fun xs ys=>@bytearray_address_merge _ _ _ _ _ xs ys buf) H37 SepAutoArray.listZnWords.
Optimize Proof. Optimize Heap.

  rename x3 into ipchk.
  match goal with x := word.sru ipchk _ |- _ => subst x end.
  progress rewrite ?word.unsigned_sru_nowrap, ?word.unsigned_of_Z_nowrap in H37 by ZnWords.

  straightline_call; [ssplit; cycle -1|]; try ecancel_assumption.
  { rewrite ?app_length, ?length_le_split. SepAutoArray.listZnWords. }
  { ZnWords. }

  pose proof length_le_split 32 (F.to_Z (x25519_gallina (le_combine sk) (F.of_Z Field.M_pos 9))) as Hpkl.
  seprewrite_in_by (fun xs ys=>@bytearray_address_merge _ _ _ _ _ xs ys buf) H37 SepAutoArray.listZnWords.
  seprewrite_in_by (fun xs ys=>@bytearray_address_merge _ _ _ _ _ xs ys buf) H37 SepAutoArray.listZnWords.

  repeat straightline.
  destruct H35; repeat straightline; [intuition idtac | ].
  { eexists; ssplit. eexists _, _; ssplit; slv.
    eexists; ssplit. subst a4. subst a. rewrite app_assoc. reflexivity.
    eexists; ssplit. eapply Forall2_app; eassumption.
    eauto using TracePredicate.any_app_more. }

  ssplit; trivial.
  eexists _, _, _; ssplit; slv.
  eexists; ssplit. subst a4. subst a. rewrite app_assoc. reflexivity.
  eexists; ssplit. eapply Forall2_app; eassumption.
  right. right.

  exists (from_list 6 mac_local ltac:(assumption)); rewrite to_list_from_list.
  exists (from_list 6 mac_remote ltac:(assumption)); rewrite to_list_from_list.
  cbv beta delta [be2].
  exists (le_combine [ethertype_lo; ethertype_hi]); rewrite split_le_combine' by trivial.
  exists (from_list 2 ih_const ltac:(assumption)); rewrite to_list_from_list.
  exists (le_combine [ip_length_lo; ip_length_hi]); rewrite split_le_combine' by trivial.
  exists (from_list 5 ip_idff ltac:(ZnWords)); rewrite to_list_from_list.
  exists (le_combine [ip_checksum_0; ip_checksum_1]); rewrite split_le_combine' by trivial.
  exists (from_list 4 ip_local ltac:(assumption)); rewrite to_list_from_list.
  exists (from_list 4 ip_remote ltac:(assumption)); rewrite to_list_from_list.
  exists (from_list 2 udp_local ltac:(assumption)); rewrite to_list_from_list.
  exists (from_list 2 udp_remote ltac:(assumption)); rewrite to_list_from_list.
  exists (le_combine [b0; b]); rewrite split_le_combine' by trivial.
  exists (le_combine [b2; b1]); rewrite split_le_combine' by trivial.
  exists (from_list 2 [b3;b4] eq_refl); rewrite to_list_from_list.
  exists (_pkpad ++ pPPP).

  assert (x11 = ipproto) as Hp. { eapply byte.unsigned_inj. rewrite E1. trivial. }
  destruct Hp.

  right.
  ssplit; trivial.
  eapply TracePredicate.concat_app.
  all : match goal with |- _ ?x _ => eplace x with _; try eassumption; [] end.
  assert (app_singleton_l : forall {A} (x:A) xs, [x] ++ xs = x :: xs) by (intros; reflexivity).
  2 : simpl le_split at 1.
  all : cbn [rev].
  all : repeat (rewrite <-?app_assoc, ?app_nil_l, ?app_singleton_l, <-?app_comm_cons).
  all : trivial; repeat (f_equal; []).

  match goal with c := Impl.ip_checksum_impl ?y |- context[Spec.ip_checksum ?x] =>
    progress rewrite <-(Impl.ip_checksum_impl_ok' y : _ = word.unsigned c) in *;
    progress replace x with y in * end.
  2: {
    repeat (rewrite <-?app_assoc, ?app_nil_l, ?app_singleton_l, <-?app_comm_cons).
    trivial. }
  remember (Spec.ip_checksum _) as chk.
  unfold le_split at 1.
  repeat (rewrite <-?app_assoc, ?app_nil_l, ?app_singleton_l, <-?app_comm_cons).
  trivial. }

  Unshelve.
  all : try SepAutoArray.listZnWords.
Qed.

Require Import Crypto.Bedrock.End2End.X25519.MontgomeryLadderProperties.
Import bedrock2.Syntax.
Import coqutil.Macros.WithBaseName.

(* these wrappers exist because CompilerInvariant requires execution proofs with arbitrary locals in the starting state, which ProgramLogic does not support *)
Definition init := func! { initfn() } .
Definition loop := func! { loopfn() } .
Definition memconst_pk := memconst garageowner.
Definition ip_checksum := ip_checksum_br2fn.

Definition funcs :=
  &[, init; loop;
    initfn; loopfn;
    memswap; memequal; memconst_pk;
    ip_checksum;
    ChaCha20.chacha20_block; ChaCha20.quarter;
    lan9250_tx ]
    ++lightbulb.function_impls
    ++MontgomeryLadder.funcs.

Lemma chacha20_ok: forall functions, ChaCha20.spec_of_chacha20 (&,ChaCha20.chacha20_block::&,ChaCha20.quarter::functions).
  intros.
  simple eapply ChaCha20.chacha20_block_body_correct.
  constructor.
  eapply ChaCha20.quarter_body_correct.
  constructor.
Qed.

Import SPI.
Lemma link_loopfn : spec_of_loopfn funcs.
Proof.
  eapply loopfn_ok; try eapply memswap.memswap_ok; try eapply memequal_ok.
    repeat (eapply recvEthernet_ok || eapply lightbulb_handle_ok);
        eapply lan9250_readword_ok; eapply spi_xchg_ok;
        (eapply spi_write_ok || eapply spi_read_ok).
    eapply ip_checksum_br2fn_ok; exact I.
    eapply x25519_base_ok; try eapply fe25519_from_word_correct; try eapply link_montladder; try eapply fe25519_to_bytes_correct.
    eapply lan9250_tx_ok; try eapply lan9250_writeword_ok; try eapply spi_xchg_ok; (eapply spi_write_ok || eapply spi_read_ok).
    eapply x25519_ok; try eapply fe25519_from_bytes_correct; try eapply link_montladder; try eapply fe25519_to_bytes_correct.
    eapply chacha20_ok.
Qed. Optimize Heap.

Require compiler.ToplevelLoop.
Definition ml: MemoryLayout.MemoryLayout(word:=Naive.word32) := {|
  MemoryLayout.code_start    := word.of_Z 0x20400000;
  MemoryLayout.code_pastend  := word.of_Z 0x21400000;
  MemoryLayout.heap_start    := word.of_Z 0x80000000;
  MemoryLayout.heap_pastend  := word.of_Z 0x80002000;
  MemoryLayout.stack_start   := word.of_Z 0x80002000;
  MemoryLayout.stack_pastend := word.of_Z 0x80004000;
|}.

Lemma ml_ok : MemoryLayout.MemoryLayoutOk ml. Proof. split; cbv; trivial; inversion 1. Qed.

Local Instance : FlatToRiscvCommon.bitwidth_iset 32 Decode.RV32IM := eq_refl.
Derive garagedoor_compiler_result SuchThat
  (ToplevelLoop.compile_prog (string_keyed_map:=@SortedListString.map) MMIO.compile_ext_call ml funcs
  = Success garagedoor_compiler_result)
  As garagedoor_compiler_result_ok.
Proof.
  match goal with x := _ |- _ => cbv delta [x]; clear x end.
  vm_compute.
  match goal with |- @Success ?A ?x = Success ?e => is_evar e;
    exact (@eq_refl (result A) (@Success A x)) end.
Qed. Optimize Heap.

Definition garagedoor_stack_size := snd garagedoor_compiler_result.
Definition garagedoor_finfo := snd (fst garagedoor_compiler_result).
Definition garagedoor_insns := fst (fst garagedoor_compiler_result).
Definition garagedoor_bytes := Pipeline.instrencode garagedoor_insns.
Definition garagedoor_symbols : list byte := Symbols.symbols garagedoor_finfo.

Require Import compiler.CompilerInvariant.
Require Import compiler.NaiveRiscvWordProperties.
Local Existing Instance SortedListString.map.

Lemma compiler_emitted_valid_instructions :
  bverify.bvalidInstructions Decode.RV32IM garagedoor_insns = true.
Proof. vm_cast_no_check (eq_refl true). Qed.

Definition good_trace s t s' :=
  exists ioh, SPI.mmio_trace_abstraction_relation ioh t /\
  (BootSeq +++ stateful garagedoor_iteration s s') ioh.
Import ExprImpEventLoopSpec.
Definition garagedoor_spec : ProgramSpec := {|
  datamem_start := MemoryLayout.heap_start ml;
  datamem_pastend := MemoryLayout.heap_pastend ml;
  goodTrace t := exists s0 s, good_trace s0 t s;
  isReady t m := exists s0 s, good_trace s0 t s /\ exists bs R, memrep bs R s m |}.

Lemma good_trace_from_isRead a a0 : isReady garagedoor_spec a a0 ->
  isReady garagedoor_spec a a0 /\
  ExprImpEventLoopSpec.goodTrace garagedoor_spec a.
Proof.
  cbv [isReady goodTrace garagedoor_spec]; intuition eauto.
  case H as (?&?&?&?&?&H); eauto.
Qed.

Lemma link_initfn : spec_of_initfn funcs.
Proof.
  eapply initfn_ok.
  eapply memconst_ok.
  eapply lan9250_init_ok;
    try (eapply lan9250_wait_for_boot_ok || eapply lan9250_mac_write_ok);
    (eapply lan9250_readword_ok || eapply lan9250_writeword_ok);
        eapply spi_xchg_ok;
        (eapply spi_write_ok || eapply spi_read_ok).
Qed. Optimize Heap.

Import ToplevelLoop GoFlatToRiscv .
Local Notation invariant := (ll_inv compile_ext_call ml garagedoor_spec).
Lemma invariant_proof :
  forall initial : MetricRiscvMachine,
    getPc (getMachine initial) = MemoryLayout.code_start ml ->
    getNextPc (getMachine initial) = word.add (getPc (getMachine initial)) (word.of_Z 4)->
    regs_initialized.regs_initialized (getRegs (getMachine initial)) ->
    getLog (getMachine initial) = [] ->
    (forall a, word.unsigned (MemoryLayout.code_start ml) <= word.unsigned a < word.unsigned (MemoryLayout.code_pastend ml) -> In a (getXAddrs (getMachine initial))) ->
    valid_machine initial ->
    (imem (MemoryLayout.code_start ml) (MemoryLayout.code_pastend ml) garagedoor_insns *
     LowerPipeline.mem_available (MemoryLayout.heap_start ml) (MemoryLayout.heap_pastend ml) *
     LowerPipeline.mem_available (MemoryLayout.stack_start ml) (MemoryLayout.stack_pastend ml))%sep (getMem (getMachine initial)) ->

     invariant initial /\
     (forall st, invariant st -> mcomp_sat (run1 Decode.RV32IM) st invariant /\
       exists extend s0 s1, good_trace s0 (extend ++ getLog (getMachine st)) s1).
Proof.
  intros.

  unshelve epose proof compiler_invariant_proofs _ _ _ _ _ garagedoor_spec as HCI; shelve_unifiable; try exact _.
  { exact (naive_word_riscv_ok 5%nat). }
  { eapply SortedListString.ok. }
  { eapply compile_ext_call_correct. }
  { intros. cbv [compile_ext_call compile_interact]; BreakMatch.break_match; trivial. }
  { exact ml_ok. }
  ssplit; intros; ssplit; eapply HCI; eauto; [].

  econstructor.
  eexists garagedoor_insns.
  eexists garagedoor_finfo.
  eexists garagedoor_stack_size.
  rewrite garagedoor_compiler_result_ok; ssplit; trivial using compiler_emitted_valid_instructions.
  2,3:vm_compute; inversion 1.
  econstructor (* ProgramSatisfiesSpec *).
  1: vm_compute; reflexivity.
  1: instantiate (1:=snd init).
  3: instantiate (1:=snd loop).
  1,3: exact eq_refl.
  1,2: cbv [hl_inv]; intros; eapply WeakestPreconditionProperties.sound_cmd.
  1,3: eapply Crypto.Util.Bool.Reflect.reflect_bool; vm_compute; reflexivity.

  all : repeat straightline; subst args.
  { repeat straightline.
    cbv [LowerPipeline.mem_available LowerPipeline.ptsto_bytes] in *.
    cbv [datamem_pastend datamem_start garagedoor_spec heap_start heap_pastend ml] in H6.
    SeparationLogic.extract_ex1_and_emp_in H6.
    change (BinIntDef.Z.of_nat (Datatypes.length anybytes) = 0x2000) in H6_emp0.
    Tactics.rapply WeakestPreconditionProperties.Proper_call;
      [|eapply link_initfn]; try eassumption.
    2: {
      rewrite <-(List.firstn_skipn 0x40 anybytes) in H6.
      rewrite <-(List.firstn_skipn 0x20 (List.skipn _ anybytes)) in H6.
      do 2 seprewrite_in @Array.bytearray_append H6.
      rewrite 2firstn_length, skipn_length, 2Nat2Z.inj_min, Nat2Z.inj_sub, H6_emp0 in H6.
      split.
      { use_sep_assumption. cancel. cancel_seps_at_indices 0%nat 0%nat; [|ecancel_done].
        Morphisms.f_equiv. }
      { rewrite firstn_length, skipn_length. Lia.lia. }
      { Lia.lia. } }
    intros ? ? ? ?; repeat straightline; eapply good_trace_from_isRead.
    subst a; rewrite app_nil_r.
    rewrite <-(List.firstn_skipn 0x20 (List.firstn _ anybytes)) in H11.
    rewrite <-(List.firstn_skipn 1520 (skipn 32 (skipn 64 anybytes))) in H11.
    do 2 seprewrite_in @Array.bytearray_append H11.
    rewrite ?firstn_length, ?skipn_length, ?Nat2Z.inj_min, ?Nat2Z.inj_sub, H6_emp0 in H11.
    cbv [isReady garagedoor_spec good_trace]. eexists (_,_), (_,_); fwd. eauto.
    { rewrite <-app_nil_l. eapply TracePredicate.concat_app; eauto. econstructor. }
    cbv [memrep]. ssplit.
    { use_sep_assumption. cancel.
      cancel_seps_at_indices 0%nat 0%nat; [reflexivity|].
      cancel_seps_at_indices 0%nat 0%nat; [reflexivity|].
      cancel_seps_at_indices 0%nat 0%nat; [reflexivity|].
      ecancel_done. }
    all : repeat rewrite ?firstn_length, ?skipn_length; try Lia.lia. }

  {  match goal with H : goodTrace _ _ |- _ => clear H end.
    cbv [isReady goodTrace good_trace garagedoor_spec] in *; repeat straightline.
    DestructHead.destruct_head' state.
    Tactics.rapply WeakestPreconditionProperties.Proper_call;
      [|eapply link_loopfn]; try eassumption.
    intros ? ? ? ?; repeat straightline; eapply good_trace_from_isRead.
    eexists; fwd; try eassumption.
    cbv [good_trace] in *; repeat straightline.
    { subst a.  (eexists; split; [eapply Forall2_app; eauto|]).
      eapply stateful_app_r, stateful_singleton; eauto. } }

  Unshelve.
  all : trivial using SortedListString.ok.
Qed.

(*
Print Assumptions link_loopfn. (* Closed under the global context *)
Print Assumptions invariant_proof. (* propositional_extensionality, functional_extensionality_dep *)
*)


Require Import Coq.Classes.Morphisms.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Tuple.
Require Import Crypto.Util.Tactics.RewriteHyp.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Notations.

Section homogenous_type.
  Context {base_type_code : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          {var : base_type_code -> Type}.

  Local Notation flat_type := (flat_type base_type_code).
  Local Notation type := (type base_type_code).
  Local Notation interp_flat_type := (@interp_flat_type base_type_code).
  Local Notation exprf := (@exprf base_type_code op var).
  Local Notation expr := (@expr base_type_code op var).

  (** Sometimes, we want to deal with partially-interpreted
      expressions, things like [prod (exprf A) (exprf B)] rather than
      [exprf (Prod A B)], or like [prod (var A) (var B)] when we start
      with the type [Prod A B].  These convenience functions let us
      recurse on the type in only one place, and replace one kind of
      pairing operator (be it [pair] or [Pair] or anything else) with
      another kind, and simultaneously mapping a function over the
      base values (e.g., [Var] (for turning [var] into [exprf]) or
      [Const] (for turning [interp_base_type] into [exprf])). *)
  Fixpoint smart_interp_flat_map {f g}
           (h : forall x, f x -> g (Tbase x))
           (tt : g Unit)
           (pair : forall A B, g A -> g B -> g (Prod A B))
           {t}
    : interp_flat_type f t -> g t
    := match t return interp_flat_type f t -> g t with
       | Syntax.Tbase _ => h _
       | Unit => fun _ => tt
       | Prod A B => fun v : interp_flat_type _ A * interp_flat_type _ B
                     => pair _ _
                             (@smart_interp_flat_map f g h tt pair A (fst v))
                             (@smart_interp_flat_map f g h tt pair B (snd v))
       end.
  Fixpoint smart_interp_flat_map2 {f1 f2 g}
           (h : forall x, f1 x -> f2 x -> g (Tbase x))
           (tt : g Unit)
           (pair : forall A B, g A -> g B -> g (Prod A B))
           {t}
    : interp_flat_type f1 t -> interp_flat_type f2 t -> g t
    := match t return interp_flat_type f1 t -> interp_flat_type f2 t -> g t with
       | Syntax.Tbase _ => h _
       | Unit => fun _ _ => tt
       | Prod A B => fun (v1 : interp_flat_type _ A * interp_flat_type _ B)
                         (v2 : interp_flat_type _ A * interp_flat_type _ B)
                     => pair _ _
                             (@smart_interp_flat_map2 f1 f2 g h tt pair A (fst v1) (fst v2))
                             (@smart_interp_flat_map2 f1 f2 g h tt pair B (snd v1) (snd v2))
       end.
  Fixpoint smart_interp_flat_map3 {f1 f2 f3 g}
           (h : forall x, f1 x -> f2 x -> f3 x -> g (Tbase x))
           (tt : g Unit)
           (pair : forall A B, g A -> g B -> g (Prod A B))
           {t}
    : interp_flat_type f1 t -> interp_flat_type f2 t -> interp_flat_type f3 t -> g t
    := match t return interp_flat_type f1 t -> interp_flat_type f2 t -> interp_flat_type f3 t -> g t with
       | Syntax.Tbase _ => h _
       | Unit => fun _ _ _ => tt
       | Prod A B => fun (v1 : interp_flat_type _ A * interp_flat_type _ B)
                         (v2 : interp_flat_type _ A * interp_flat_type _ B)
                         (v3 : interp_flat_type _ A * interp_flat_type _ B)
                     => pair _ _
                             (@smart_interp_flat_map3 f1 f2 f3 g h tt pair A (fst v1) (fst v2) (fst v3))
                             (@smart_interp_flat_map3 f1 f2 f3 g h tt pair B (snd v1) (snd v2) (snd v3))
       end.
  Definition smart_interp_map_hetero {f g g'}
             (h : forall x, f x -> g (Tbase x))
             (tt : g Unit)
             (pair : forall A B, g A -> g B -> g (Prod A B))
             (abs : forall A B, (g A -> g B) -> g' (Arrow A B))
             {t}
    : interp_type_gen_hetero g (interp_flat_type f) t -> g' t
    := match t return interp_type_gen_hetero g (interp_flat_type f) t -> g' t with
       | Arrow A B => fun v => abs _ _
                                   (fun x => @smart_interp_flat_map f g h tt pair _ (v x))
       end.
  Fixpoint SmartValf {T} (val : forall t : base_type_code, T t) t : interp_flat_type T t
    := match t return interp_flat_type T t with
       | Syntax.Tbase _ => val _
       | Unit => tt
       | Prod A B => (@SmartValf T val A, @SmartValf T val B)
       end.
  Section SmartValf_monad.
    Context (M : Type -> Type) (ret : forall T, T -> M T)
            (bind : forall A B, M A -> (A -> M B) -> M B).
    Fixpoint SmartValfM
             {T} (val : forall t : base_type_code, M (T t)) t : M (interp_flat_type T t)
      := match t return M (interp_flat_type T t) with
         | Syntax.Tbase _ => val _
         | Unit => ret _ tt
         | Prod A B => bind _ _ (@SmartValfM T val A)
                            (fun a => bind _ _ (@SmartValfM T val B)
                                           (fun b => ret _ (a, b)))
         end.
  End SmartValf_monad.

  (** [SmartVar] is like [Var], except that it inserts
      pair-projections and [Pair] as necessary to handle [flat_type],
      and not just [base_type_code] *)
  Local Notation exprfb := (fun t => exprf (Tbase t)).
  Definition SmartValf_option {T} (val : forall t, option (T t)) t
    : option (interp_flat_type T t)
    := @SmartValfM
         (fun t => option t) (fun t v => @Some t v)
         (fun _ _ x f => match x with
                         | Some x => f x
                         | None => None
                         end)
         T val t.
  Definition SmartPairf {t} : interp_flat_type exprfb t -> exprf t
    := @smart_interp_flat_map exprfb exprf (fun t x => x) TT (fun A B x y => Pair x y) t.
  Lemma SmartPairf_Pair {A B} (e1 : interp_flat_type _ A) (e2 : interp_flat_type _ B)
    : SmartPairf (t:=Prod A B) (e1, e2)%core = Pair (SmartPairf e1) (SmartPairf e2).
  Proof using Type. reflexivity. Qed.
  Definition SmartVarf {t} : interp_flat_type var t -> exprf t
    := @smart_interp_flat_map var exprf (fun t => Var) TT (fun A B x y => Pair x y) t.
  Definition SmartVarf_Pair {A B v}
    : @SmartVarf (Prod A B) v = Pair (SmartVarf (fst v)) (SmartVarf (snd v))
    := eq_refl.
  Definition SmartVarfMap {var var'} (f : forall t, var t -> var' t) {t}
    : interp_flat_type var t -> interp_flat_type var' t
    := @smart_interp_flat_map var (interp_flat_type var') f tt (fun A B x y => pair x y) t.
  Lemma SmartVarfMap_compose {var' var'' var''' t} f g x
    : @SmartVarfMap var'' var''' g t (@SmartVarfMap var' var'' f t x)
      = @SmartVarfMap _ _ (fun t v => g t (f t v)) t x.
  Proof using Type.
    unfold SmartVarfMap; clear; induction t; simpl; destruct_head_hnf unit; destruct_head_hnf prod;
      rewrite_hyp ?*; congruence.
  Qed.
  Lemma SmartVarfMap_id {var' t} x : @SmartVarfMap var' var' (fun _ x => x) t x = x.
  Proof using Type.
    unfold SmartVarfMap; clear; induction t; simpl; destruct_head_hnf unit; destruct_head_hnf prod;
      rewrite_hyp ?*; congruence.
  Qed.
  Definition SmartVarfMap_Pair {var' var''} {f' : forall t, var' t -> var'' t} {A B}
             v
    : @SmartVarfMap var' var'' f' (Prod A B) v
      = (SmartVarfMap f' (fst v), SmartVarfMap f' (snd v))
    := eq_refl.
  Lemma SmartVarfMap_tuple' {var' var''} {f' : forall t, var' t -> var'' t} {T n}
             v
    : @SmartVarfMap var' var'' f' (tuple' T n) v
      = flat_interp_untuple' (Tuple.map' (@SmartVarfMap var' var'' f' _) (flat_interp_tuple' v)).
  Proof.
    induction n as [|n IHn]; [ reflexivity | destruct v as [v0 v1] ].
    simpl; rewrite SmartVarfMap_Pair, IHn; simpl.
    reflexivity.
  Qed.
  Definition SmartVarfMap_tuple {var' var''} {f' : forall t, var' t -> var'' t} {T n}
             v
    : @SmartVarfMap var' var'' f' (tuple T n) v
      = tuple_map (@SmartVarfMap var' var'' f' _) v.
  Proof.
    destruct n as [|n]; [ destruct v; reflexivity | ].
    apply SmartVarfMap_tuple'.
  Qed.
  Global Instance smart_interp_flat_map_Proper {f g}
    : Proper ((forall_relation (fun t => pointwise_relation _ eq))
                ==> eq
                ==> (forall_relation (fun A => forall_relation (fun B => pointwise_relation _ (pointwise_relation _ eq))))
                ==> forall_relation (fun t => eq ==> eq))
             (@smart_interp_flat_map f g).
  Proof using Type.
    unfold forall_relation, pointwise_relation, respectful.
    intros F G HFG x y ? Q R HQR t a b ?; subst y b.
    induction t; simpl in *; auto.
    rewrite_hyp !*; reflexivity.
  Qed.
  Global Instance SmartVarfMap_Proper {var' var''}
    : Proper (forall_relation (fun t => pointwise_relation _ eq) ==> forall_relation (fun t => eq ==> eq))
             (@SmartVarfMap var' var'').
  Proof using Type.
    repeat intro; eapply smart_interp_flat_map_Proper; trivial; repeat intro; reflexivity.
  Qed.
  Definition SmartVarfMap2 {var var' var''} (f : forall t, var t -> var' t -> var'' t) {t}
    : interp_flat_type var t -> interp_flat_type var' t -> interp_flat_type var'' t
    := @smart_interp_flat_map2 var var' (interp_flat_type var'') f tt (fun A B x y => pair x y) t.
  Lemma SmartVarfMap2_fst_arg {var' var''} {t}
        (x : interp_flat_type var' t)
        (y : interp_flat_type var'' t)
    : SmartVarfMap2 (fun _ a b => a) x y = x.
  Proof using Type.
    unfold SmartVarfMap2; clear; induction t; simpl; destruct_head_hnf unit; destruct_head_hnf prod;
      rewrite_hyp ?*; congruence.
  Qed.
  Lemma SmartVarfMap2_snd_arg {var' var''} {t}
        (x : interp_flat_type var' t)
        (y : interp_flat_type var'' t)
    : SmartVarfMap2 (fun _ a b => b) x y = y.
  Proof using Type.
    unfold SmartVarfMap2; clear; induction t; simpl; destruct_head_hnf unit; destruct_head_hnf prod;
      rewrite_hyp ?*; congruence.
  Qed.
  Definition SmartVarfMap3 {var var' var'' var'''} (f : forall t, var t -> var' t -> var'' t -> var''' t) {t}
    : interp_flat_type var t -> interp_flat_type var' t -> interp_flat_type var'' t -> interp_flat_type var''' t
    := @smart_interp_flat_map3 var var' var'' (interp_flat_type var''') f tt (fun A B x y => pair x y) t.
  Definition SmartVarfTypeMap {var} (f : forall t, var t -> Type) {t}
    : interp_flat_type var t -> Type
    := @smart_interp_flat_map var (fun _ => Type) f unit (fun _ _ P Q => P * Q)%type t.
  Definition SmartVarfPropMap {var} (f : forall t, var t -> Prop) {t}
    : interp_flat_type var t -> Prop
    := @smart_interp_flat_map var (fun _ => Prop) f True (fun _ _ P Q => P /\ Q)%type t.
  Definition SmartVarfTypeMap2 {var var'} (f : forall t, var t -> var' t -> Type) {t}
    : interp_flat_type var t -> interp_flat_type var' t -> Type
    := @smart_interp_flat_map2 var var' (fun _ => Type) f unit (fun _ _ P Q => P * Q)%type t.
  Definition SmartVarfPropMap2 {var var'} (f : forall t, var t -> var' t -> Prop) {t}
    : interp_flat_type var t -> interp_flat_type var' t -> Prop
    := @smart_interp_flat_map2 var var' (fun _ => Prop) f True (fun _ _ P Q => P /\ Q)%type t.
  Definition SmartFlatTypeMap {var'} (f : forall t, var' t -> base_type_code) {t}
    : interp_flat_type var' t -> flat_type
    := @smart_interp_flat_map var' (fun _ => flat_type) (fun t v => Tbase (f t v)) Unit (fun _ _ => Prod) t.
  Definition SmartFlatTypeMap_Pair {var'} (f : forall t, var' t -> base_type_code) {A B}
        (x : interp_flat_type var' (A * B))
    : SmartFlatTypeMap f x
      = (SmartFlatTypeMap f (@fst (interp_flat_type _ _) (interp_flat_type _ _) x)
         * SmartFlatTypeMap f (@snd (interp_flat_type _ _) (interp_flat_type _ _) x))%ctype
    := eq_refl.
  Definition SmartFlatTypeUnMap (t : flat_type)
    : interp_flat_type (fun _ => base_type_code) t
    := SmartValf (fun t => t) t.
  Fixpoint SmartFlatTypeMapInterp {var' var''} (f : forall t, var' t -> base_type_code)
           (fv : forall t v, var'' (f t v)) t {struct t}
    : forall v, interp_flat_type var'' (SmartFlatTypeMap f (t:=t) v)
    := match t return forall v, interp_flat_type var'' (SmartFlatTypeMap f (t:=t) v) with
       | Syntax.Tbase x => fv _
       | Unit => fun v => v
       | Prod A B => fun xy : interp_flat_type _ A * interp_flat_type _ B
                     => (@SmartFlatTypeMapInterp _ _ f fv A (fst xy),
                         @SmartFlatTypeMapInterp _ _ f fv B (snd xy))
       end.
  Fixpoint SmartFlatTypeMapInterp2 {var' var'' var'''} (f : forall t, var' t -> base_type_code)
           (fv : forall t v, var'' t -> var''' (f t v)) t {struct t}
    : forall v, interp_flat_type var'' t -> interp_flat_type var''' (SmartFlatTypeMap f (t:=t) v)
    := match t return forall v, interp_flat_type var'' t -> interp_flat_type var''' (SmartFlatTypeMap f (t:=t) v) with
       | Syntax.Tbase x => fv _
       | Unit => fun v _ => v
       | Prod A B => fun (xy : interp_flat_type _ A * interp_flat_type _ B)
                         (x'y' : interp_flat_type _ A * interp_flat_type _ B)
                     => (@SmartFlatTypeMapInterp2 _ _ _ f fv A (fst xy) (fst x'y'),
                         @SmartFlatTypeMapInterp2 _ _ _ f fv B (snd xy) (snd x'y'))
       end.
  Fixpoint SmartFlatTypeMapUnInterp var' var'' var''' (f : forall t, var' t -> base_type_code)
           (fv : forall t (v : var' t), var'' (f t v) -> var''' t)
           {t} {struct t}
    : forall v, interp_flat_type var'' (SmartFlatTypeMap f (t:=t) v)
                -> interp_flat_type var''' t
    := match t return forall v, interp_flat_type var'' (SmartFlatTypeMap f (t:=t) v)
                                -> interp_flat_type var''' t with
       | Syntax.Tbase x => fv _
       | Unit => fun _ v => v
       | Prod A B => fun (v : interp_flat_type _ A * interp_flat_type _ B)
                         (xy : interp_flat_type _ (SmartFlatTypeMap _ (fst v)) * interp_flat_type _ (SmartFlatTypeMap _ (snd v)))
                     => (@SmartFlatTypeMapUnInterp _ _ _ f fv A _ (fst xy),
                         @SmartFlatTypeMapUnInterp _ _ _ f fv B _ (snd xy))
       end.
  Definition SmartVarMap {var' var''} (f : forall t, var' t -> var'' t) (f' : forall t, var'' t -> var' t) {t}
    : interp_type_gen (interp_flat_type var') t -> interp_type_gen (interp_flat_type var'') t
    := match t return interp_type_gen (interp_flat_type var') t -> interp_type_gen (interp_flat_type var'') t with
       | Arrow src dst => fun F x => SmartVarfMap f (F (SmartVarfMap f' x))
       end.
  Lemma SmartVarMap_id {var' t} x v : @SmartVarMap var' var' (fun _ x => x) (fun _ x => x) t x v = x v.
  Proof using Type. destruct t; simpl; rewrite !SmartVarfMap_id; reflexivity. Qed.
  Definition SmartVarVarf {t} : interp_flat_type var t -> interp_flat_type exprfb t
    := SmartVarfMap (fun t => Var).
  Definition SmartVarVarf_Pair {A B} (v : interp_flat_type _ _ * interp_flat_type _ _)
    : @SmartVarVarf (Prod A B) v
      = (SmartVarVarf (fst v), SmartVarVarf (snd v))
    := eq_refl.
  Lemma SmartPairfSmartVarVarf_SmartVarf {t} v
    : SmartPairf (SmartVarVarf v) = SmartVarf (t:=t) v.
  Proof.
    induction t; try reflexivity; simpl.
    rewrite SmartVarf_Pair, SmartVarVarf_Pair, SmartPairf_Pair; f_equal;
      auto.
  Qed.
End homogenous_type.

Global Arguments SmartVarf {_ _ _ _} _.
Global Arguments SmartPairf {_ _ _ t} _.
Global Arguments SmartValf {_} T _ t.
Global Arguments SmartVarVarf {_ _ _ _} _.
Global Arguments SmartVarfMap {_ _ _} _ {!_} _ / .
Global Arguments SmartVarfMap2 {_ _ _ _} _ {!t} _ _ / .
Global Arguments SmartVarfMap3 {_ _ _ _ _} _ {!t} _ _ _ / .
Global Arguments SmartVarfTypeMap {_ _} _ {_} _.
Global Arguments SmartVarfPropMap {_ _} _ {_} _.
Global Arguments SmartVarfTypeMap2 {_ _ _} _ {t} _ _.
Global Arguments SmartVarfPropMap2 {_ _ _} _ {t} _ _.
Global Arguments SmartFlatTypeMap {_ _} _ {_} _.
Global Arguments SmartFlatTypeUnMap {_} _.
Global Arguments SmartFlatTypeMapInterp {_ _ _ _} _ {_} _.
Global Arguments SmartFlatTypeMapInterp2 {_ _ _ _ f} fv {t} _ _.
Global Arguments SmartFlatTypeMapUnInterp {_ _ _ _ _} fv {_ _} _.
Global Arguments SmartVarMap {_ _ _} _ _ {!_} _ / _.

Section hetero_type.
  Fixpoint flatten_flat_type {base_type_code} (t : flat_type (flat_type base_type_code)) : flat_type base_type_code
    := match t with
       | Tbase T => T
       | Unit => Unit
       | Prod A B => Prod (@flatten_flat_type _ A) (@flatten_flat_type _ B)
       end.

  Section smart_flat_type_map2.
    Context {base_type_code1 base_type_code2 : Type}.

    Definition SmartFlatTypeMap2 {var' : base_type_code1 -> Type} (f : forall t, var' t -> flat_type base_type_code2) {t}
      : interp_flat_type var' t -> flat_type base_type_code2
      := @smart_interp_flat_map base_type_code1 var' (fun _ => flat_type base_type_code2) f Unit (fun _ _ => Prod) t.
    Fixpoint SmartFlatTypeMap2Interp {var' var''} (f : forall t, var' t -> flat_type base_type_code2)
             (fv : forall t v, interp_flat_type var'' (f t v)) t {struct t}
      : forall v, interp_flat_type var'' (SmartFlatTypeMap2 f (t:=t) v)
      := match t return forall v, interp_flat_type var'' (SmartFlatTypeMap2 f (t:=t) v) with
         | Tbase x => fv _
         | Unit => fun v => v
         | Prod A B => fun xy : interp_flat_type _ A * interp_flat_type _ B
                       => (@SmartFlatTypeMap2Interp _ _ f fv A (fst xy),
                           @SmartFlatTypeMap2Interp _ _ f fv B (snd xy))
         end.
    Fixpoint SmartFlatTypeMapUnInterp2 var' var'' var''' (f : forall t, var' t -> flat_type base_type_code2)
             (fv : forall t (v : var' t), interp_flat_type var'' (f t v) -> var''' t)
             {t} {struct t}
      : forall v, interp_flat_type var'' (SmartFlatTypeMap2 f (t:=t) v)
                  -> interp_flat_type var''' t
      := match t return forall v, interp_flat_type var'' (SmartFlatTypeMap2 f (t:=t) v)
                                  -> interp_flat_type var''' t with
         | Tbase x => fv _
         | Unit => fun _ v => v
         | Prod A B => fun (v : interp_flat_type _ A * interp_flat_type _ B)
                           (xy : interp_flat_type _ (SmartFlatTypeMap2 _ (fst v)) * interp_flat_type _ (SmartFlatTypeMap2 _ (snd v)))
                       => (@SmartFlatTypeMapUnInterp2 _ _ _ f fv A _ (fst xy),
                           @SmartFlatTypeMapUnInterp2 _ _ _ f fv B _ (snd xy))
         end.
    Fixpoint SmartFlatTypeMap2Interp2 {var' var'' var'''} (f : forall t, var' t -> flat_type base_type_code2)
             (fv : forall t v, var'' t -> interp_flat_type var''' (f t v)) t {struct t}
      : forall v, interp_flat_type var'' t -> interp_flat_type var''' (SmartFlatTypeMap2 f (t:=t) v)
      := match t return forall v, interp_flat_type var'' t -> interp_flat_type var''' (SmartFlatTypeMap2 f (t:=t) v) with
         | Tbase x => fv _
         | Unit => fun v _ => v
         | Prod A B => fun (xy : interp_flat_type _ A * interp_flat_type _ B)
                           (x'y' : interp_flat_type _ A * interp_flat_type _ B)
                       => (@SmartFlatTypeMap2Interp2 _ _ _ f fv A (fst xy) (fst x'y'),
                           @SmartFlatTypeMap2Interp2 _ _ _ f fv B (snd xy) (snd x'y'))
         end.

    Lemma SmartFlatTypeMapUnInterp2_SmartFlatTypeMap2Interp2
          var' var'' var'''
          (f : forall t, var' t -> flat_type base_type_code2)
          (fv : forall t (v : var' t), interp_flat_type var'' (f t v) -> var''' t)
          (gv : forall t v, var''' t -> interp_flat_type var'' (f t v))
          {t} v
          (e : interp_flat_type var''' t)
      : @SmartFlatTypeMapUnInterp2
          _ _ _ f fv t v
          (@SmartFlatTypeMap2Interp2
             _ _ _ f gv t v e)
        = SmartVarfMap2 (fun t v e => fv t v (gv t v e)) v e.
    Proof using Type.
      induction t; simpl in *; destruct_head' unit;
        rewrite_hyp ?*; reflexivity.
    Qed.
  End smart_flat_type_map2.

  Section smart_flat_type.
    Context {base_type_code1 base_type_code2 : Type}
            (f : base_type_code1 -> base_type_code2).
    Fixpoint lift_flat_type (t : flat_type base_type_code1)
      : flat_type base_type_code2
      := match t with
         | Tbase T => Tbase (f T)
         | Unit => Unit
         | Prod A B => Prod (lift_flat_type A) (lift_flat_type B)
         end.

    Section with_var.
      Context {var1 : base_type_code1 -> Type}
              {var2 : base_type_code2 -> Type}
              (fvar : forall t, var1 t -> var2 (f t))
              (fvar' : forall t, var2 (f t) -> var1 t).

      Fixpoint transfer_interp_flat_type {t}
        : interp_flat_type var1 t
          -> interp_flat_type var2 (lift_flat_type t)
        := match t with
           | Tbase T => fvar _
           | Unit => fun v => v
           | Prod A B => fun ab : interp_flat_type _ A * interp_flat_type _ B
                         => (@transfer_interp_flat_type _ (fst ab),
                             @transfer_interp_flat_type _ (snd ab))%core
           end.

      Fixpoint untransfer_interp_flat_type {t}
        : interp_flat_type var2 (lift_flat_type t)
          -> interp_flat_type var1 t
        := match t with
           | Tbase T => fvar' _
           | Unit => fun v => v
           | Prod A B => fun ab : interp_flat_type _ (lift_flat_type A)
                                  * interp_flat_type _ (lift_flat_type B)
                         => (@untransfer_interp_flat_type _ (fst ab),
                             @untransfer_interp_flat_type _ (snd ab))%core
           end.
    End with_var.
  End smart_flat_type.
End hetero_type.

Global Arguments SmartFlatTypeMap2 {_ _ _} _ {!_} _ / .
Global Arguments SmartFlatTypeMap2Interp {_ _ _ _ _} fv {_} _.
Global Arguments SmartFlatTypeMap2Interp2 {_ _ _ _ _ _} fv {t} v _.
Global Arguments SmartFlatTypeMapUnInterp2 {_ _ _ _ _ _} fv {_ _} _.

Section interp_lemmas.
  Context {base_type_code : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          {interp_base_type : base_type_code -> Type}
          {interp_op : forall s d, op s d -> interp_flat_type interp_base_type s -> interp_flat_type interp_base_type d}.

  Local Notation exprfb := (fun t => exprf _ op (Tbase t)).

  Lemma interpf_SmartVarf
        {t} (e : interp_flat_type _ t)
  : @interpf _ interp_base_type _ interp_op _ (SmartVarf (var:=interp_base_type) e)
    = e.
  Proof.
    induction t as [ t | | A IHA B IHB ]; try destruct e; try reflexivity.
    rewrite !SmartVarf_Pair; cbn; rewrite IHA, IHB.
    reflexivity.
  Qed.

  Lemma interpf_SmartPairf'
        {t} (e : interp_flat_type exprfb t)
  : @interpf _ interp_base_type _ interp_op _ (SmartPairf e)
    = SmartVarfMap (fun t => interpf interp_op) e.
  Proof.
    induction t as [ t | | A IHA B IHB ]; try reflexivity.
    { destruct e.
      rewrite !SmartPairf_Pair, !SmartVarfMap_Pair, <- !IHA, <- !IHB.
      reflexivity. }
  Qed.

  Lemma interpf_SmartPairf
        {t} (e : interp_flat_type exprfb t)
  : @interpf _ interp_base_type _ interp_op _ (SmartPairf (var:=interp_base_type) e)
    = SmartVarfMap (fun t => interpf interp_op) e.
  Proof. apply interpf_SmartPairf'. Qed.
End interp_lemmas.


(** * Definition of Context Free Grammars *)
Require Import Coq.Strings.String Coq.Lists.List.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Common.

Set Implicit Arguments.

Local Open Scope string_like_scope.
Local Open Scope type_scope.

Section cfg.
  Context {Char} {HSL : StringLikeMin Char} {predata : @parser_computational_predataT Char} (G : grammar Char).

  Context (valid : nonterminals_listT).

  (** Relation defining if a productions is maybe empty *)
  Inductive maybe_empty_productions : productions Char -> Type :=
  | MaybeEmptyHead : forall pat pats, maybe_empty_production pat
                                      -> maybe_empty_productions (pat::pats)
  | MaybeEmptyTail : forall pat pats, maybe_empty_productions pats
                                      -> maybe_empty_productions (pat::pats)
  with maybe_empty_production : production Char -> Type :=
  | MaybeEmptyProductionNil : maybe_empty_production nil
  | MaybeEmptyProductionCons : forall it its, maybe_empty_item it
                                              -> maybe_empty_production its
                                              -> maybe_empty_production (it::its)
  with maybe_empty_item : item Char -> Type :=
  | MaybeEmptyNonTerminal : forall nt, is_valid_nonterminal valid (of_nonterminal nt)
                                      -> maybe_empty_productions (Lookup G nt)
                                      -> maybe_empty_item (NonTerminal nt).
End cfg.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(** printing two_n %\ensuremath{2n}% #2n# *)
(** printing Small %\ensuremath{\frac13^n}% *)
(** printing Smaller %\ensuremath{\frac13^{2n^2}}% *)

Require Export CoRN.reals.CSumsReals.
Require Export CoRN.fta.KeyLemma.
Require Import CoRN.algebra.CRing_as_Ring.
From Coq Require Import Lia.

(**
** Main Lemma
*)

Section Main_Lemma.

(**
%\begin{convention}%
Let [a : nat->IR], [n : nat], [a_0 : IR]  and [eps : IR] such that [0 < n],
[([0] [<] eps)], [forall (k : nat)([0] [<=] (a k))], [(a n) [=] [1]], and
[(eps [<=] a_0)].
%\end{convention}%
*)

Variable a : nat -> IR.
Variable n : nat.
Hypothesis gt_n_0 : 0 < n.
Variable eps : IR.
Hypothesis eps_pos : [0] [<] eps.
Hypothesis a_nonneg : forall k : nat, [0] [<=] a k.
Hypothesis a_n_1 : a n [=] [1].
Variable a_0 : IR.
Hypothesis eps_le_a_0 : eps [<=] a_0.

Lemma a_0_pos : [0] [<] a_0.
Proof.
 apply less_leEq_trans with eps; auto.
Qed.

(**
%\begin{convention}% We define the following local abbreviations:
 - [two_n := 2 * n]
 - [Small := p3m n]
 - [Smaller := p3m (two_n * n)]

%\end{convention}%
*)

(* begin hide *)
Let two_n := 2 * n.
Let Small := p3m n.
Let Smaller := p3m (two_n * n).
(* end hide *)

Lemma Main_1a' : forall (t : IR) (j k : nat),
 let r' := t[*]p3m (S (S j)) in let r := t[*]p3m (S j) in
 (forall i, 1 <= i -> i <= n -> a i[*]r'[^]i[-]eps [<=] a k[*]r'[^]k) ->
 forall i : nat, 1 <= i -> i <= n -> a i[*] (r [/]ThreeNZ) [^]i[-]eps [<=] a k[*] (r [/]ThreeNZ) [^]k.
Proof.
 (* begin hide *)
 intros.
 cut ((t[*]p3m (S j)) [/]ThreeNZ [=] t[*]p3m (S (S j))). intro.
  astepl (a i[*] (t[*]p3m (S (S j))) [^]i[-]eps).
  astepr (a k[*] (t[*]p3m (S (S j))) [^]k).
  auto.
 Step_final (t[*]p3m (S j) [/]ThreeNZ).
Qed.
(* end hide *)

Lemma Main_1b' : forall (t : IR) (j k : nat),
 let r' := t[*]p3m j in let r := t[*]p3m (S j) in
 (forall i, 1 <= i -> i <= n -> a i[*]r'[^]i[-]eps [<=] a k[*]r'[^]k) ->
 forall i, 1 <= i -> i <= n -> a i[*] (r[*]Three) [^]i[-]eps [<=] a k[*] (r[*]Three) [^]k.
Proof.
 (* begin hide *)
 intros.
 cut (t[*]p3m (S j) [*]Three [=] t[*]p3m j). intro.
  astepl (a i[*] (t[*]p3m j) [^]i[-]eps).
  astepr (a k[*] (t[*]p3m j) [^]k).
  auto.
 Step_final (t[*] (p3m (S j) [*]Three)).
Qed.
(* end hide *)

Lemma Main_1a : forall (r : IR) (k : nat), [0] [<=] r -> 1 <= k -> k <= n ->
 (forall i, 1 <= i -> i <= n -> a i[*] (r [/]ThreeNZ) [^]i[-]eps [<=] a k[*] (r [/]ThreeNZ) [^]k) ->
 let p_ := fun i : nat => a i[*]r[^]i in let p_k := a k[*]r[^]k in
 Sum 1 (pred k) p_ [<=] Half[*] ([1][-]Small) [*]p_k[+]Half[*]Three[^]n[*]eps.
Proof.
 (* begin hide *)
 intros r k H H0 H1 H2 p_ p_k.
 unfold p_, p_k in |- *.
 apply leEq_transitive with (Sum 1 (pred k)
   (fun i : nat => Three[^]i[*] (a k[*] (r [/]ThreeNZ) [^]k[+]eps))).
  apply Sum_resp_leEq.
   auto with arith.
  intros i H3 H4.
  cut (Three[^]i [#] ZeroR).
   intro H5.
   apply shift_leEq_mult' with H5.
    apply nexp_resp_pos.
    apply pos_three.
   astepl (a i[*] (r[^]i[/] Three[^]i[//]H5)).
   astepl (a i[*] (r [/]ThreeNZ) [^]i).
   astepr (eps[+]a k[*] (r [/]ThreeNZ) [^]k).
   apply shift_leEq_plus'.
   apply H2.
    assumption.
   lia.
  apply nexp_resp_ap_zero.
  apply three_ap_zero.
 apply leEq_wdl with (Sum 1 (pred k) (fun i : nat => Three[^]i) [*]
   (a k[*] (r [/]ThreeNZ) [^]k[+]eps)).
  cut (Three[-][1] [#] ZeroR).
   intro H3.
   astepl ((Three[^]S (pred k) [-]Three[^]1[/] Three[-][1][//]H3) [*]
     (a k[*] (r [/]ThreeNZ) [^]k[+]eps)).
   rewrite <- (S_pred _ _ H0).
   astepl ((Three[^]k[-]Three[/] Three[-][1][//]H3) [*] (a k[*] (r [/]ThreeNZ) [^]k[+]eps)).
   rstepl ([1] [/]TwoNZ[*] (Three[^]k[-]Three) [*] (a k[*] (r [/]ThreeNZ) [^]k) [+]
     [1] [/]TwoNZ[*] (Three[^]k[-]Three) [*]eps).
   apply leEq_transitive with (Half[*] ([1][-]Small) [*] (a k[*]r[^]k) [+]
     [1] [/]TwoNZ[*] (Three[^]k[-]Three) [*]eps).
    apply plus_resp_leEq.
    cut (Three[^]k [#] ZeroR).
     intro H4.
     astepl ([1] [/]TwoNZ[*] (Three[^]k[-]Three) [*] (a k[*] (r[^]k[/] Three[^]k[//]H4))).
     rstepl ([1] [/]TwoNZ[*]a k[*]r[^]k[*] ([1][-] (Three[/] Three[^]k[//]H4))).
     rstepr (Half[*]a k[*]r[^]k[*] ([1][-]Small)).
     unfold Half in |- *.
     apply mult_resp_leEq_lft.
      apply minus_resp_leEq_both.
       apply leEq_reflexive.
      unfold Small in |- *.
      unfold p3m in |- *.
      cut (Three[^]pred k [#] ZeroR).
       intro H5.
       apply leEq_wdr with ([1][/] Three[^]pred k[//]H5).
        cut (Three[^]n [#] ZeroR).
         intro H6.
         astepl ([1][/] Three[^]n[//]H6).
         apply recip_resp_leEq.
          apply nexp_resp_pos.
          apply pos_three.
         apply great_nexp_resp_le.
          apply less_leEq; apply one_less_three.
         lia.
        apply nexp_resp_ap_zero.
        apply three_ap_zero.
       apply eq_div.
       pattern k at 1 in |- *.
       rewrite (S_pred _ _ H0).
       astepl ([1][*] (Three[*]Three[^]pred k):IR).
       clear H3 H4 H5.
       astepl ((Three[*]Three[^]pred k):IR). reflexivity.
       apply nexp_resp_ap_zero.
      apply three_ap_zero.
     apply mult_resp_nonneg.
      apply mult_resp_nonneg.
       apply less_leEq.
       astepr (Half:IR).
       apply pos_half.
      apply a_nonneg.
     apply nexp_resp_nonneg; auto.
    apply nexp_resp_ap_zero.
    apply three_ap_zero.
   apply plus_resp_leEq_lft.
   rstepl ([1] [/]TwoNZ[*]eps[*] (Three[^]k[-]Three)).
   rstepr (Half[*]eps[*]Three[^]n).
   unfold Half in |- *.
   apply mult_resp_leEq_lft.
    apply leEq_transitive with (Three[^]k:IR).
     astepr (Three[^]k[-]ZeroR).
     apply minus_resp_leEq_rht.
     apply less_leEq; apply pos_three.
    apply great_nexp_resp_le; auto.
    apply less_leEq; apply one_less_three.
   apply less_leEq; apply mult_resp_pos; auto.
   astepr (Half:IR); apply pos_half.
  rstepl (Two:IR).
  apply two_ap_zero.
 apply eq_symmetric_unfolded.
 apply mult_distr_sum_rht with (f := fun i : nat => (Three:IR) [^]i).
Qed.
(* end hide *)

Lemma Main_1b : forall (r : IR) (k : nat), [0] [<=] r -> 1 <= k -> k <= n ->
 (forall i,  1 <= i -> i <= n -> a i[*] (r[*]Three) [^]i[-]eps [<=] a k[*] (r[*]Three) [^]k) ->
 let p_ := fun i => a i[*]r[^]i in let p_k := a k[*]r[^]k in
 Sum (S k) n p_ [<=] Half[*] ([1][-]Small) [*]p_k[+]Half[*]Three[^]n[*]eps.
Proof.
 (* begin hide *)
 intros r k H H0 H1 H2 p_ p_k.
 unfold p_, p_k in |- *.
 cut (forall i : nat, Three[^]i [#] ZeroR).
  intro H3.
  2: intro i; apply pos_ap_zero.
  2: apply nexp_resp_pos.
  2: apply pos_three.
 apply leEq_transitive with (Sum (S k) n
   (fun i : nat => a k[*] (r[*]Three) [^]k[+]eps[/] Three[^]i[//]H3 i)).
  apply Sum_resp_leEq.
   auto with arith.
  intros i H4 H5.
  apply shift_leEq_div.
   apply nexp_resp_pos; apply pos_three.
  rstepr (eps[+]a k[*] (r[*]Three) [^]k).
  apply shift_leEq_plus'.
  rstepl (a i[*] (r[^]i[*]Three[^]i) [-]eps).
  astepl (a i[*] (r[*]Three) [^]i[-]eps).
  apply H2; auto with arith.
  apply le_trans with (S k); auto.
 astepl (Sum (S k) n (fun i : nat => (a k[*] (r[*]Three) [^]k[+]eps) [*][1][/] Three[^]i[//]H3 i)).
 astepl (Sum (S k) n (fun i : nat => (a k[*] (r[*]Three) [^]k[+]eps) [*] ([1][/] Three[^]i[//]H3 i))).
 apply leEq_wdl with ((a k[*] (r[*]Three) [^]k[+]eps) [*]
   Sum (S k) n (fun i : nat => [1][/] Three[^]i[//]H3 i)).
  2: apply eq_symmetric_unfolded.
  2: apply mult_distr_sum_lft with (f := fun i : nat => [1][/] Three[^]i[//]H3 i).
 astepl ((a k[*] (r[*]Three) [^]k[+]eps) [*] Sum (S k) n (fun i : nat => ([1] [/]ThreeNZ) [^]i)).
 cut ([1][-][1] [/]ThreeNZ [#] ZeroR).
  2: rstepl ((Two:IR) [/]ThreeNZ).
  2: apply div_resp_ap_zero_rev.
  2: apply two_ap_zero.
 intro H4.
 astepl ((a k[*] (r[*]Three) [^]k[+]eps) [*] (([1] [/]ThreeNZ) [^]S k[-] ([1] [/]ThreeNZ) [^]S n[/]
   [1][-][1] [/]ThreeNZ[//]H4)).
 astepl ((a k[*] (r[*]Three) [^]k[+]eps) [*] ([1] [/]ThreeNZ[*] ([1] [/]ThreeNZ) [^]k[-]
   [1] [/]ThreeNZ[*] ([1] [/]ThreeNZ) [^]n[/] [1][-][1] [/]ThreeNZ[//]H4)).
 rstepl ([1] [/]TwoNZ[*] (a k[*] (r[*]Three) [^]k) [*]
   (([1] [/]ThreeNZ) [^]k[-] ([1] [/]ThreeNZ) [^]n) [+]
     [1] [/]TwoNZ[*]eps[*] (([1] [/]ThreeNZ) [^]k[-] ([1] [/]ThreeNZ) [^]n)).
 apply leEq_transitive with (Half[*] ([1][-]Small) [*] (a k[*]r[^]k) [+]
   [1] [/]TwoNZ[*]eps[*] (([1] [/]ThreeNZ) [^]k[-] ([1] [/]ThreeNZ) [^]n)).
  apply plus_resp_leEq.
  astepl ([1] [/]TwoNZ[*] (a k[*] (r[^]k[*]Three[^]k)) [*]
    (([1] [/]ThreeNZ) [^]k[-] ([1] [/]ThreeNZ) [^]n)).
  rstepl ([1] [/]TwoNZ[*]a k[*]r[^]k[*]
    (Three[^]k[*] ([1] [/]ThreeNZ) [^]k[-]Three[^]k[*] ([1] [/]ThreeNZ) [^]n)).
  unfold Half in |- *.
  rstepr ([1] [/]TwoNZ[*]a k[*]r[^]k[*] ([1][-]Small)).
  apply mult_resp_leEq_lft.
   astepl (((Three:IR) [*][1] [/]ThreeNZ) [^]k[-]Three[^]k[*] ([1] [/]ThreeNZ) [^]n).
   astepl ((((Three:IR) [*][1]) [/]ThreeNZ) [^]k[-]Three[^]k[*] ([1] [/]ThreeNZ) [^]n).
   astepl (((Three:IR) [/]ThreeNZ) [^]k[-]Three[^]k[*] ([1] [/]ThreeNZ) [^]n).
   astepl (OneR[^]k[-]Three[^]k[*] ([1] [/]ThreeNZ) [^]n).
   astepl (OneR[-]Three[^]k[*] ([1] [/]ThreeNZ) [^]n).
   apply less_leEq.
   apply minus_resp_less_rht.
   unfold Small in |- *.
   unfold p3m in |- *.
   rstepl (OneR[*] ([1] [/]ThreeNZ) [^]n).
   apply mult_resp_less.
    astepl (OneR[^]k).
    apply nexp_resp_less; auto.
     apply less_leEq; apply pos_one.
    apply one_less_three.
   apply nexp_resp_pos.
   apply pos_div_three; apply pos_one.
  apply mult_resp_nonneg.
   apply mult_resp_nonneg.
    apply less_leEq.
    apply pos_div_two; apply pos_one.
   apply a_nonneg.
  apply nexp_resp_nonneg; assumption.
 apply plus_resp_leEq_lft.
 rstepr (Half[*]eps[*]Three[^]n).
 unfold Half in |- *.
 apply mult_resp_leEq_lft.
  apply leEq_transitive with OneR.
   apply leEq_transitive with ((OneR [/]ThreeNZ) [^]k).
    astepr ((OneR [/]ThreeNZ) [^]k[-][0]).
    apply less_leEq.
    apply minus_resp_less_rht.
    apply nexp_resp_pos.
    apply pos_div_three; apply pos_one.
   astepr ([1][^]k:IR).
   apply nexp_resp_leEq.
    apply less_leEq; apply pos_div_three; apply pos_one.
   astepr (OneR [/]OneNZ).
   apply less_leEq; apply recip_resp_less.
    apply pos_one.
   apply one_less_three.
  astepl (OneR[^]n).
  apply nexp_resp_leEq; apply less_leEq.
   apply pos_one.
  apply one_less_three.
 apply less_leEq.
 apply mult_resp_pos; auto.
 apply pos_div_two; apply pos_one.
Qed.
(* end hide *)

Lemma Main_1 : forall (r : IR) (k : nat), [0] [<=] r -> 1 <= k -> k <= n ->
 (forall i,  1 <= i ->  i <= n -> a i[*] (r [/]ThreeNZ) [^]i[-]eps [<=] a k[*] (r [/]ThreeNZ) [^]k) ->
 (forall i,  1 <= i -> i <= n -> a i[*] (r[*]Three) [^]i[-]eps [<=] a k[*] (r[*]Three) [^]k) ->
 let p_ := fun i => a i[*]r[^]i in let p_k := a k[*]r[^]k in
 Sum 1 (pred k) p_[+]Sum (S k) n p_ [<=] ([1][-]Small) [*]p_k[+]Three[^]n[*]eps.
Proof.
 (* begin hide *)
 intros r k H H0 H1 H2 H3 p_ p_k.
 unfold p_, p_k in |- *.
 set (h := Half[*] ([1][-]Small) [*]p_k[+]Half[*]Three[^]n[*]eps) in *.
 apply leEq_wdr with (h[+]h); unfold h, p_k in |- *.
  apply plus_resp_leEq_both.
   apply Main_1a; auto.
  apply Main_1b; auto.
 unfold Half in |- *; rational.
Qed.
(* end hide *)

Lemma Main_2' : forall (t : IR) (i k : nat),
 a i[*] (t[*]p3m 0) [^]i[-]eps [<=] a k[*] (t[*]p3m 0) [^]k -> a i[*]t[^]i[-]eps [<=] a k[*]t[^]k.
Proof.
 intros.
 cut (t[*]p3m 0 [=] t). intro.
  astepl (a i[*] (t[*]p3m 0) [^]i[-]eps).
  astepr (a k[*] (t[*]p3m 0) [^]k).
  auto.
 Step_final (t[*][1]).
Qed.

Lemma Main_2 : forall (t : IR) (j k : nat), let r := t[*]p3m j in
 [0] [<=] t -> a k[*]t[^]k [=] a_0[-]eps -> (forall i, 1 <= i -> i <= n -> a i[*]t[^]i[-]eps [<=] a k[*]t[^]k) ->
 forall i, 1 <= i -> i <= n -> a i[*]r[^]i [<=] a_0.
Proof.
 (* begin hide *)
 intros.
 unfold r in |- *.
 apply leEq_transitive with (a i[*]t[^]i).
  astepl (a i[*] (t[^]i[*]p3m j[^]i)).
  rstepl (p3m j[^]i[*] (a i[*]t[^]i)).
  astepr ([1][*] (a i[*]t[^]i)).
  apply mult_resp_leEq_rht.
   astepr ([1][^]i:IR).
   apply nexp_resp_leEq.
    apply less_leEq; apply p3m_pos.
   apply p3m_small.
  astepl ([0][*]t[^]i).
  apply mult_resp_leEq_rht; auto.
  astepl ([0][^]i:IR).
  apply nexp_resp_leEq; auto.
  apply leEq_reflexive.
 apply leEq_wdr with (eps[+]a k[*]t[^]k).
  apply shift_leEq_plus'; auto.
 astepl (eps[+] (a_0[-]eps)); rational.
Qed.
(* end hide *)

Lemma Main_3a : forall (t : IR) (j k k_0 : nat), let r := t[*]p3m j in
 k_0 <= n -> a k_0[*]t[^]k_0 [=] a_0[-]eps -> a k_0[*]r[^]k_0[-]eps [<=] a k[*]r[^]k ->
 p3m (j * n) [*]a_0[-]Two[*]eps [<=] a k[*]r[^]k.
Proof.
 (* begin hide *)
 intros.
 unfold r in |- *.
 rstepl (p3m (j * n) [*]a_0[-]eps[-]eps).
 apply leEq_transitive with (a k_0[*] (t[*]p3m j) [^]k_0[-]eps); auto.
 apply minus_resp_leEq.
 astepr (a k_0[*] (t[^]k_0[*]p3m j[^]k_0)).
 astepr (a k_0[*] (t[^]k_0[*]p3m (j * k_0))).
 rstepr (p3m (j * k_0) [*] (a k_0[*]t[^]k_0)).
 astepr (p3m (j * k_0) [*] (a_0[-]eps)).
 astepr (p3m (j * k_0) [*]a_0[-]p3m (j * k_0) [*]eps).
 apply minus_resp_leEq_both.
  apply mult_resp_leEq_rht.
   apply p3m_mon'; auto with arith.
  apply less_leEq; apply a_0_pos.
 astepr ([1][*]eps).
 apply mult_resp_leEq_rht.
  apply p3m_small.
 apply less_leEq; auto.
Qed.
(* end hide *)

Lemma Main_3 : forall (t : IR) (j k k_0 : nat), let r := t[*]p3m j in
 j < two_n -> k_0 <= n -> a k_0[*]t[^]k_0 [=] a_0[-]eps -> a k_0[*]r[^]k_0[-]eps [<=] a k[*]r[^]k ->
 Smaller[*]a_0[-]Two[*]eps [<=] a k[*]r[^]k.
Proof.
 (* begin hide *)
 intros t j k k_0 r H H0 H1 H2.
 unfold r in |- *.
 apply leEq_transitive with (p3m (j * n) [*]a_0[-]Two[*]eps).
  apply minus_resp_leEq.
  apply mult_resp_leEq_rht.
   unfold Smaller in |- *.
   apply p3m_mon'.
   apply mult_le_compat_r; auto with arith.
  apply less_leEq; apply a_0_pos.
 apply Main_3a with k_0; auto.
Qed.
(* end hide *)

Lemma Main : {r : IR | [0] [<=] r | {k : nat | 1 <= k /\ k <= n /\
 (let p_ := fun i => a i[*]r[^]i in let p_k := a k[*]r[^]k in
  Sum 1 (pred k) p_[+]Sum (S k) n p_ [<=] ([1][-]Small) [*]p_k[+]Three[^]n[*]eps /\
  r[^]n [<=] a_0 /\ Smaller[*]a_0[-]Two[*]eps [<=] p_k /\ p_k [<=] a_0)}}.
Proof.
 (* begin hide *)
Proof.
 elim (Key a n gt_n_0 eps eps_pos a_nonneg a_n_1 a_0 eps_le_a_0).
 intro t. intros H0 H1.
 elim (H1 two_n). intro k. intros H2.
 elim H2. intros H3 H4.
 elim H4. intros H5 H6.
 elim H6. intros H7 H8.
 elim (kseq_prop k n H3 H5). intro j. intros H9.
 elim H9. intros H10 H11. elim H11. intros H12 H13.
 clear H9 H6 H4 H2 H1.
 cut ([0] [<=] t[*]p3m (S j)). intro H14.
  2: apply mult_resp_nonneg; auto.
  2: apply less_leEq; apply p3m_pos.
 exists (t[*]p3m (S j)).
  auto.
 exists (k (S j)).
 elim (H3 (S j)); intros H3' H3''.
 split. auto.
  split. auto.
  intros p_ p_k. (* patch *)
 split; unfold p_, p_k in |- *.
  apply Main_1; auto.
   intros i H15 H16.
   apply Main_1a'; auto.
   intros i0 H17 H18.
   rewrite H13.
   apply H8; auto with arith.
  intros i H15 H16.
  apply Main_1b'; auto.
  intros i0 H17 H18.
  rewrite <- H12.
  apply H8; auto with arith.
  apply le_trans with (S j); auto with arith.
 split.
  astepl ([1][*] (t[*]p3m (S j)) [^]n).
  astepl (a n[*] (t[*]p3m (S j)) [^]n).
  apply Main_2 with (k 0); auto.
  intros i H15 H16.
  apply Main_2'.
  apply H8; auto with arith.
 elim (H3 0); intros H3''' H3''''.
 split.
  apply Main_3 with (k 0); auto.
  apply H8; auto with arith.
 apply Main_2 with (k 0); auto.
 intros i H15 H16.
 apply Main_2'; auto with arith.
Qed.
(* end hide *)

End Main_Lemma.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

 *)

Require Export rules_useful.

Hint Resolve wf_term_subst : slow.

Lemma subset_free_vars_csub_app3 {o} :
  forall (t : @NTerm o) sub1 sub2,
    disjoint (remove_nvars (dom_csub sub1) (free_vars t)) (dom_csub sub2)
    -> csubst t (sub1 ++ sub2) = csubst t sub1.
Proof.
  unfold csubst; introv disj.
  rw <- @csub2sub_app.
  apply simple_lsubst_app2.
  - introv i j k.
    assert (cl_sub (csub2sub sub1)) as cl by eauto 3 with slow.
    apply in_sub_eta in i; repnd.
    pose proof (flat_map_free_vars_range_cl_sub (csub2sub sub1) cl) as h.
    assert (LIn t0 (flat_map free_vars (range (csub2sub sub1)))) as it.
    { rw lin_flat_map; eexists; dands; eauto. }
    rw h in it; simpl in it; tcsp.
  - introv i.
    assert (prog_sub (csub2sub sub2)) as prog by eauto 3 with slow.
    rw <- @prog_sub_eq in prog; apply prog.
    apply in_sub_eta in i; tcsp.
  - introv i j k.
    allrw @dom_csub_eq.
    pose proof (disj v) as xx.
    rw in_remove_nvars in xx.
    autodimp xx hyp; tcsp.
Qed.

Lemma lsubstc_app_weak_r {o} :
  forall (t : @NTerm o) w x u s1 s2 c,
    disjoint (remove_nvars [x] (free_vars t)) (dom_csub s2)
    -> {c' : cover_vars t ((x,u) :: s1)
        & lsubstc
            t
            w
            ((x,u) :: s1 ++ s2)
            c
          = lsubstc t w ((x,u) :: s1) c'}.
Proof.
  introv disj.

  assert (cover_vars t ((x,u) :: s1)) as cov.
  {
    allrw @cover_vars_eq.
    allrw subvars_eq.
    introv i; applydup c in i; allsimpl; clear c.
    allrw @dom_csub_app.
    allrw in_app_iff.
    repndors; tcsp.
    apply disjoint_sym in disj.
    apply disj in i0.
    rw in_remove_nvars in i0; simpl in i0.
    destruct (deq_nvar x x0); auto.
    destruct i0; tcsp.
  }

  exists cov.

  apply lsubstc_eq_if_csubst.
  rewrite @app_comm_cons.
  apply subset_free_vars_csub_app3; simpl.
  introv i.
  apply disj.
  allrw in_remove_nvars; repnd; dands; auto.
  allsimpl.
  intro j; destruct i; tcsp.
Qed.

Lemma lsubstc_snoc_weak_r {o} :
  forall (t : @NTerm o) w x u s y v c,
    (x <> y -> !LIn y (free_vars t))
    -> {c' : cover_vars t ((x,u) :: s)
        & lsubstc
            t
            w
            ((x,u) :: snoc s (y,v))
            c
          = lsubstc t w ((x,u) :: s) c'}.
Proof.
  introv disj.

  assert (cover_vars t ((x,u) :: s)) as cov.
  {
    allrw @cover_vars_eq.
    allrw subvars_eq.
    introv i; applydup c in i; allsimpl; clear c.
    allrw @dom_csub_snoc; allsimpl.
    allrw in_snoc.
    repndors; subst; tcsp.
    destruct (deq_nvar x y); tcsp.
  }

  exists cov.

  apply lsubstc_eq_if_csubst.
  rewrite snoc_as_append.
  rewrite @app_comm_cons.
  apply subset_free_vars_csub_app3; simpl.
  introv i j; allsimpl; repndors; subst; tcsp.
  allrw in_remove_nvars; repnd; allsimpl.
  allrw not_over_or; repnd; tcsp.
Qed.

Ltac lsubstc_weak :=
  match goal with
  | [ |- context[lsubstc ?t ?w ((?x,?u) :: ?s1 ++ ?s2) ?c] ] =>
    let disj := fresh "disj" in
    let h    := fresh "h" in
    let cov  := fresh "cov" in
    assert (disjoint (remove_nvars [x] (free_vars t)) (dom_csub s2)) as disj;
      [ auto
      | pose proof (lsubstc_app_weak_r t w x u s1 s2 c disj) as h;
        destruct h as [ cov h ];
        rewrite h; clear h
      ]

  | [ |- context[lsubstc ?t ?w ((?x,?u) :: snoc ?s (?y,?v)) ?c] ] =>
    let disj := fresh "disj" in
    let h    := fresh "h" in
    let cov  := fresh "cov" in
    assert (x <> y -> !LIn y (free_vars t)) as disj;
      [ auto
      | pose proof (lsubstc_snoc_weak_r t w x u s y v c disj) as h;
        destruct h as [ cov h ];
        rewrite h; clear h
      ]
  end.

(* !!MOVE *)
Lemma isprog_vars_equality {p} :
  forall (a b c : @NTerm p) vs,
    isprog_vars vs (mk_equality a b c)
                <=> (isprog_vars vs a # isprog_vars vs b # isprog_vars vs c).
Proof.
  introv.
  repeat (rw @isprog_vars_eq; simpl).
  autorewrite with slow.
  allrw subvars_app_l.
  allrw <- @wf_term_eq.
  allrw <- @wf_equality_iff; split; sp.
Qed.

(* !!MOVE *)
Lemma isprog_vars_member {p} :
  forall (a b : @NTerm p) vs,
    isprog_vars vs (mk_member a b)
                <=> (isprog_vars vs a # isprog_vars vs b).
Proof.
  introv.
  repeat (rw @isprog_vars_eq; simpl).
  autorewrite with slow.
  allrw subvars_app_l.
  allrw <- @wf_term_eq.
  allrw <- @wf_equality_iff; split; sp.
Qed.

(* !!MOVE *)
Lemma isprog_vars_iff_covered {o} :
  forall (t : @NTerm o) (vs : list NVar),
    isprog_vars vs t <=> (covered t vs # wf_term t).
Proof.
  tcsp.
Qed.

(* !!MOVE *)
Lemma isprog_vars_lsubst2 {o} :
  forall (t : @NTerm o) vs sub,
    wf_term t
    -> (forall v u, LIn (v, u) sub -> isprog_vars vs u)
    -> isprog_vars (vs ++ dom_sub sub) t
    -> isprog_vars vs (lsubst t sub).
Proof.
  introv w k1 k2.
  allrw @isprog_vars_eq; repnd.
  dands.

  {
    eapply subvars_eqvars;[|apply eqvars_sym; apply eqvars_free_vars_disjoint].
    rw subvars_app_l; dands.

    - rw subvars_remove_nvars; auto.

    - eapply subvars_trans;[apply sub_free_vars_sub_keep_first_subvars|].
      rw subvars_eq; introv i.
      apply in_sub_free_vars in i; exrepnd.
      apply k1 in i0.
      apply isprog_vars_eq in i0; repnd.
      rw subvars_eq in i2; apply i2 in i1; auto.
  }

  { apply nt_wf_lsubst_iff; dands; auto.
    introv i j.
    apply sub_find_some in j.
    apply k1 in j; eauto 3 with slow.
  }
Qed.

(* !!MOVE *)
Lemma isprog_vars_comm {o} :
  forall (t : @NTerm o) vs1 vs2,
    isprog_vars (vs1 ++ vs2) t
    -> isprog_vars (vs2 ++ vs1) t.
Proof.
  introv isp.
  allrw @isprog_vars_eq; repnd; dands; auto.
  apply subvars_comm_r; auto.
Qed.

(* !!MOVE *)
Lemma isprog_vars_subst2 {o} :
  forall (t : @NTerm o) v u vs,
    wf_term t
    -> isprog_vars vs u
    -> isprog_vars (v :: vs) t
    -> isprog_vars vs (subst t v u).
Proof.
  introv w k1 k2.
  apply isprog_vars_lsubst2; simpl; auto.

  - introv i; repndors; cpx.

  - apply isprog_vars_comm; simpl; auto.
Qed.