From compcert Require Import Maps AST Values Memory Globalenvs Ctypes.
From compcert Require Coqlib Clight Clightdefs.

Require Import String List ZArith Lia.

Require Import sflib.
Require Import StdlibExt IntegersExt.
Require Import IPModel IntByteModel.

Require Import NWSysModel.
Require Import RTSysEnv.
Require Import MWITree.

Require Import VerifProgBase.
Require Import config_prm main_prm SystemProgs.

Local Open Scope Z.
Local Opaque Z.of_nat Z.to_nat.
Arguments Z.add: simpl nomatch.

Section INIT_DATA_LEMMAS.
  Context `{SystemEnv}.

  Variable p: Clight.program.
  Let ge := Genv.globalenv p.

  Variable m: Mem.mem.
  Hypothesis INIT_MEM: Genv.init_mem p = Some m.

  Section TASK_ID.
    (* App is responsible to define TASK_ID  *)

    Variable tid: nat.
    Hypothesis RANGE_TID: (Z.of_nat tid <= Byte.max_signed)%Z.

    Hypothesis DEFMAP: (prog_defmap p) ! main_prm._TASK_ID =
                       Some (Gvar (v_TASK_ID_p (Z.of_nat tid))).

    Lemma _init_mem_tid
      : exists b_tid,
        Genv.find_symbol ge main_prm._TASK_ID = Some b_tid /\
        (b_tid < Genv.genv_next ge)%positive /\
        Mem.load Mint8signed m b_tid 0%Z =
        Some (Vint (IntNat.of_nat tid)).
    Proof.
      apply Genv.find_def_symbol in DEFMAP.
      destruct DEFMAP as (b & FSYMB & FDEF).

      esplits; eauto.
      { eapply Genv.genv_symb_range. eauto. }

      eapply Genv.init_mem_characterization_gen in FDEF; eauto.
      destruct FDEF as (RANGE_PERM & PERM_ORDER &
                        LOAD_STORE & LOADBYTES).

      hexploit LOAD_STORE.
      { ss. }
      clear LOAD_STORE. clear - RANGE_TID.
      intro LOAD_STORE. ss. des.
      rewrite Mem.load_int8_signed_unsigned.
      rewrite LOAD_STORE. ss.

      repeat f_equal.
      rewrite Int.sign_ext_zero_ext by ss.

      apply sign_ext_byte_range.
      r. split; ss.
      etransitivity.
      - instantiate (1:= 0%Z). ss.
      - nia.
    Qed.
  End TASK_ID.

  (** ** pals_period *)

  Section PALS_PERIOD.
    Hypothesis DEFMAP:
      (prog_defmap p) ! main_prm._PALS_PERIOD =
      Some (Gvar (config_prm.v_PALS_PERIOD (Z.of_nat period))).

    Lemma _init_mem_pals_period
      : exists b_pprd,
        Genv.find_symbol ge main_prm._PALS_PERIOD = Some b_pprd /\
        (b_pprd < Genv.genv_next ge)%positive /\
        Mem.load Mint64 m b_pprd 0%Z =
        Some (Vlong (IntNat.of_nat64 period)).
    Proof.
      apply Genv.find_def_symbol in DEFMAP.
      destruct DEFMAP as (b & FSYMB & FDEF).

      esplits; eauto.
      { eapply Genv.genv_symb_range. eauto. }

      eapply Genv.init_mem_characterization_gen in FDEF; eauto.
      destruct FDEF as (RANGE_PERM & PERM_ORDER &
                        LOAD_STORE & LOADBYTES).

      hexploit LOAD_STORE.
      { ss. }
      clear LOAD_STORE.
      intro LOAD_STORE. ss. des.
      rewrite LOAD_STORE. ss.
    Qed.
  End PALS_PERIOD.

  Section MAX_CSKEW.
    Hypothesis DEFMAP:
      (prog_defmap p) ! main_prm._MAX_CSKEW =
      Some (Gvar (config_prm.v_MAX_CSKEW (Z.of_nat max_clock_skew))).

    Lemma _init_mem_max_cskew
      : exists b_sk,
        Genv.find_symbol ge main_prm._MAX_CSKEW = Some b_sk /\
        (b_sk < Genv.genv_next ge)%positive /\
        Mem.load Mint64 m b_sk 0%Z =
        Some (Vlong (IntNat.of_nat64 max_clock_skew)).
    Proof.
      apply Genv.find_def_symbol in DEFMAP.
      destruct DEFMAP as (b & FSYMB & FDEF).

      esplits; eauto.
      { eapply Genv.genv_symb_range. eauto. }

      eapply Genv.init_mem_characterization_gen in FDEF; eauto.
      destruct FDEF as (RANGE_PERM & PERM_ORDER &
                        LOAD_STORE & LOADBYTES).

      hexploit LOAD_STORE.
      { ss. }
      clear LOAD_STORE.
      intro LOAD_STORE. ss. des.
      rewrite LOAD_STORE. ss.
    Qed.
  End MAX_CSKEW.

  Section MAX_NWDELAY.
    Hypothesis DEFMAP:
      (prog_defmap p) ! main_prm._MAX_NWDELAY =
      Some (Gvar (config_prm.v_MAX_NWDELAY (Z.of_nat max_nw_delay))).

    Lemma _init_mem_max_nwdelay
      : exists b_nd,
        Genv.find_symbol ge main_prm._MAX_NWDELAY = Some b_nd /\
        (b_nd < Genv.genv_next ge)%positive /\
        Mem.load Mint64 m b_nd 0%Z =
        Some (Vlong (IntNat.of_nat64 max_nw_delay)).
    Proof.
      apply Genv.find_def_symbol in DEFMAP.
      destruct DEFMAP as (b & FSYMB & FDEF).

      esplits; eauto.
      { eapply Genv.genv_symb_range. eauto. }

      eapply Genv.init_mem_characterization_gen in FDEF; eauto.
      destruct FDEF as (RANGE_PERM & PERM_ORDER &
                        LOAD_STORE & LOADBYTES).

      hexploit LOAD_STORE.
      { ss. }
      clear LOAD_STORE.
      intro LOAD_STORE. ss. des.
      rewrite LOAD_STORE. ss.
    Qed.
  End MAX_NWDELAY.

  Section NUM_TASKS.
    Hypothesis DEFMAP:
      (prog_defmap p) ! main_prm._NUM_TASKS =
      Some (Gvar (config_prm.v_NUM_TASKS (Z.of_nat num_tasks))).

    Lemma _init_mem_num_tasks
      : exists b_nt,
        Genv.find_symbol ge main_prm._NUM_TASKS = Some b_nt /\
        (b_nt < Genv.genv_next ge)%positive /\
        Mem.load Mint32 m b_nt 0%Z =
        Some (Vint (IntNat.of_nat num_tasks)).
    Proof.
      apply Genv.find_def_symbol in DEFMAP.
      destruct DEFMAP as (b & FSYMB & FDEF).

      esplits; eauto.
      { eapply Genv.genv_symb_range. eauto. }

      eapply Genv.init_mem_characterization_gen in FDEF; eauto.
      destruct FDEF as (RANGE_PERM & PERM_ORDER &
                        LOAD_STORE & LOADBYTES).

      hexploit LOAD_STORE.
      { ss. }
      clear LOAD_STORE.
      intro LOAD_STORE. ss. des.
      rewrite LOAD_STORE. ss.
    Qed.
  End NUM_TASKS.

  Section NUM_MCASTS.
    Hypothesis DEFMAP:
      (prog_defmap p) ! main_prm._NUM_MCASTS =
      Some (Gvar (config_prm.v_NUM_MCASTS (Z.of_nat num_mcasts))).

    Lemma _init_mem_num_mcasts
      : exists b_nmc,
        Genv.find_symbol ge main_prm._NUM_MCASTS = Some b_nmc /\
        (b_nmc < Genv.genv_next ge)%positive /\
        Mem.load Mint32 m b_nmc 0%Z =
        Some (Vint (IntNat.of_nat num_mcasts)).
    Proof.
      apply Genv.find_def_symbol in DEFMAP.
      destruct DEFMAP as (b & FSYMB & FDEF).

      esplits; eauto.
      { eapply Genv.genv_symb_range. eauto. }

      eapply Genv.init_mem_characterization_gen in FDEF; eauto.
      destruct FDEF as (RANGE_PERM & PERM_ORDER &
                        LOAD_STORE & LOADBYTES).

      hexploit LOAD_STORE.
      { ss. }
      clear LOAD_STORE.
      intro LOAD_STORE. ss. des.
      rewrite LOAD_STORE. ss.
    Qed.
  End NUM_MCASTS.

  Section MSG_SIZE.
    Hypothesis DEFMAP:
      (prog_defmap p) ! main_prm._MSG_SIZE =
      Some (Gvar (config_prm.v_MSG_SIZE (Z.of_nat msg_size))).

    Lemma _init_mem_msg_size
      : exists b_msz,
        Genv.find_symbol ge main_prm._MSG_SIZE = Some b_msz /\
        (b_msz < Genv.genv_next ge)%positive /\
        Mem.load Mint32 m b_msz 0%Z =
        Some (Vint (IntNat.of_nat msg_size)).
    Proof.
      apply Genv.find_def_symbol in DEFMAP.
      destruct DEFMAP as (b & FSYMB & FDEF).

      esplits; eauto.
      { eapply Genv.genv_symb_range. eauto. }

      eapply Genv.init_mem_characterization_gen in FDEF; eauto.
      destruct FDEF as (RANGE_PERM & PERM_ORDER &
                        LOAD_STORE & LOADBYTES).

      hexploit LOAD_STORE.
      { ss. }
      clear LOAD_STORE.
      intro LOAD_STORE. ss. des.
      rewrite LOAD_STORE. ss.
    Qed.
  End MSG_SIZE.

  Section PORT.
    Hypothesis DEFMAP:
      (prog_defmap p) ! main_prm._PORT =
      Some (Gvar (config_prm.v_PORT (Z.of_nat port))).

    Lemma _init_mem_port
      : exists b_pn,
        Genv.find_symbol ge main_prm._PORT = Some b_pn /\
        (b_pn < Genv.genv_next ge)%positive /\
        Mem.load Mint32 m b_pn 0%Z =
        Some (Vint (IntNat.of_nat port)).
    Proof.
      apply Genv.find_def_symbol in DEFMAP.
      destruct DEFMAP as (b & FSYMB & FDEF).

      esplits; eauto.
      { eapply Genv.genv_symb_range. eauto. }

      eapply Genv.init_mem_characterization_gen in FDEF; eauto.
      destruct FDEF as (RANGE_PERM & PERM_ORDER &
                        LOAD_STORE & LOADBYTES).

      hexploit LOAD_STORE.
      { ss. }
      clear LOAD_STORE.
      intro LOAD_STORE. ss. des.
      rewrite LOAD_STORE. ss.
    Qed.
  End PORT.

  Section IP_ADDR.
    Let v_IP_ADDR_i: globvar type :=
      config_prm.v_IP_ADDR (Z.of_nat max_num_tasks)
                           (Z.of_nat max_num_mcasts)
                           dest_ips_brep.

    Hypothesis DEFMAP: (prog_defmap p) ! main_prm._IP_ADDR =
                       Some (Gvar v_IP_ADDR_i).

    Lemma _init_mem_ip_addr
      : exists b_ip_addr,
        Genv.find_symbol ge main_prm._IP_ADDR = Some b_ip_addr /\
        (b_ip_addr < Genv.genv_next ge)%positive /\
        iForall (fun n ip_bs =>
                   Mem.loadbytes
                     m b_ip_addr (Z.of_nat (n * 16))
                     (Zlength ip_bs + 1) =
                   Some (inj_bytes (snoc ip_bs Byte.zero)))
                0 (task_ips_brep ++ (map fst mcasts))
    .
    Proof.
      apply Genv.find_def_symbol in DEFMAP.
      destruct DEFMAP as (b & FSYMB & FDEF).

      eexists. split; eauto.
      split.
      { eapply Genv.genv_symb_range. eauto. }

      eapply Genv.init_mem_characterization_gen in FDEF; eauto.
      destruct FDEF as (RANGE_PERM & PERM_ORDER &
                        LOAD_STORE & LOADBYTES).

      hexploit LOADBYTES.
      { eauto. }

      clear - ge.
      replace (init_data_list_size (gvar_init v_IP_ADDR_i))
        with (Z.of_nat (max_num_tasks + max_num_mcasts) * 16)%Z.
      2: { ss.
           rewrite init_data_list_size_app. ss.
           rewrite flat_map_concat_map.
           erewrite init_data_list_size_concat.
           2: { i. rewrite in_map_iff in IN. des.
                unfold ip_init_data in IN. subst.
                ss. }
           rewrite Zlength_correct.
           rewrite map_length.

           assert (length dest_ips_brep <= max_num_tasks + max_num_mcasts)%nat.
           { pose proof num_tasks_bound as NT.
             pose proof num_mcasts_bound as NMC.
             pose proof task_ips_convert_brep as CONV_T.
             pose proof mcast_ips_convert_brep as CONV_M.
             apply Forall2_length in CONV_T.
             apply Forall2_length in CONV_M.

             unfold dest_ips_brep.
             rewrite app_length. rewrite map_length.
             unfold bytes in *. nia.
           }
           unfold bytes in *.
           rewrite Zlength_correct. nia.
      }

      ss.
      clear. intros LOADBYTES.

      apply iForall_nth. i. r.
      destruct (nth_error (task_ips_brep ++ map fst mcasts) n)
        as [ip_bs| ] eqn: IP_BS.
      2: { desf.
           exfalso.
           unfold bytes in *.
           congruence. }
      fold bytes in *.
      rewrite IP_BS. ss.

      assert (LEN_IP: Forall (fun ip_bs' => (length ip_bs' < 16)%nat) dest_ips_brep).
      { apply Forall_forall.
        unfold dest_ips_brep.
        intros bs IN.
        apply in_app_or in IN.
        des.
        - apply In_nth_error in IN. des.
          pose proof task_ips_convert_brep as CONV.
          eapply Forall2_nth1 in CONV; eauto. des.
          hexploit IP.valid_ip_brep_spec; eauto. i. des.
          unfold IP.max_byte_length in *. ss.
        - apply In_nth_error in IN. des.
          pose proof mcast_ips_convert_brep as CONV.
          apply map_nth_error_iff in IN. des.
          destruct a as [ip' mbrs]. ss. subst.

          eapply Forall2_nth1 in CONV; eauto. des.
          hexploit IP.valid_ip_brep_spec; eauto. i. des.
          unfold IP.max_byte_length in *. ss.
      }

      eapply Mem_loadbytes_sublist with
          (n1:= Z.of_nat (n * 16)) (n2:= (Zlength ip_bs + 1)%Z)
        in LOADBYTES; cycle 1.
      { nia. }
      { rewrite Zlength_correct. nia. }
      { match goal with
        | |- (?lhs <= _)%Z => replace lhs with (Z.of_nat (n * 16 + S (length ip_bs)))
        end.
        2: { rewrite Zlength_correct. nia. }

        assert (length ip_bs < 16)%nat.
        { rewrite Forall_nth in LEN_IP.
          specialize (LEN_IP n). r in LEN_IP.
          unfold dest_ips_brep in LEN_IP.
          unfold bytes in *.
          rewrite IP_BS in LEN_IP. ss. }
        assert (n < max_num_tasks + max_num_mcasts)%nat.
        { apply nth_error_Some1' in IP_BS.
          rewrite app_length in IP_BS.
          rewrite map_length in IP_BS.

          pose proof task_ips_convert_brep as CONV_T.
          apply Forall2_length in CONV_T.
          pose proof mcast_ips_convert_brep as CONV_M.
          apply Forall2_length in CONV_M.

          pose proof num_tasks_bound.
          pose proof num_mcasts_bound.
          unfold bytes in *. nia.
        }
        nia.
      }
      ss.
      rewrite LOADBYTES.
      f_equal.
      clear LOADBYTES.
      fold dest_ips_brep in IP_BS.

      match goal with
      | |- context[flat_map _ _ ++ ?x] => generalize x as rest
      end.

      revert n IP_BS LEN_IP.
      generalize dest_ips_brep.
      intro l.

      induction l as [| h t IH]; i.
      { exfalso.
        destruct n; ss. }

      destruct n as [| n'].
      { simpl in IP_BS. clarify. ss.
        assert (LEN_IP_BS: (length ip_bs < 16)%nat).
        { inv LEN_IP. ss. }
        clear LEN_IP IH.
        rewrite Zlength_correct. ss.

        match goal with
        | |- context [firstn ?n] => replace n with (length ip_bs + 1)%nat by nia
        end.

        repeat rewrite Int.unsigned_repr by apply ubyte_in_uint_range.
        repeat rewrite simpl_init_byte.
        destruct ip_bs as [| h1 tl]; ss.
        do 15 (destruct tl as [| ? tl]; ss; []).
        exfalso. nia.
      }
      { simpl in IP_BS.
        hexploit IH; eauto.
        { inv LEN_IP. ss. }
        intro FN.
        rewrite flat_map_concat_map. ss.
        replace (S n' * 16)%nat with (16 + n' * 16)%nat by ss.

        repeat rewrite Int.unsigned_repr by apply ubyte_in_uint_range.
        repeat rewrite simpl_init_byte. ss.
        rewrite Nat2Z.id. ss.
        rewrite <- flat_map_concat_map.
        rewrite Nat2Z.id in FN.  eauto.
      }
    Qed.
  End IP_ADDR.

  Lemma load_store_init_data_mcmem
        b ofs
        mip_bs mbrs tid'
        (VALID_TID: (tid' < num_tasks)%nat)
        (MCMEM: Genv.load_store_init_data
                  ge m b ofs (mcmem_init_data
                                (Z.of_nat max_num_tasks)
                                (group_memflags (mip_bs, mbrs))))
    : Mem.load Mint8signed m b (ofs + Z.of_nat tid') =
      Some (Vint (if existsb (Nat.eqb tid') mbrs
                  then Int.one else Int.zero)).
  Proof.
    unfold group_memflags in MCMEM. ss.
    unfold mcmem_init_data in *.
    apply load_store_init_data_app in MCMEM. des.

    clear MCMEM0.

    assert (AUX: forall nt ofs' tid' i
                   (TID: (tid' < nt)%nat)
                   (MCMEM : Genv.load_store_init_data
                              ge m b ofs'
                              (map (fun b: bool =>
                                      Init_int8 (Int.repr (if b then 1 else 0)))
                                   (imap (fun n _ => existsb (Nat.eqb n) mbrs)
                                         i (repeat tt nt))))
             ,
               Mem.load Mint8signed m b (ofs' + Z.of_nat tid') =
               Some (Vint (if existsb (Nat.eqb (i + tid')) mbrs
                           then Int.one else Int.zero))).
    { clear.
      intro nt.
      induction nt as [| nt' IH]; i; ss.
      { nia. }
      destruct tid' as [| tid']; ss.
      { des.
        rewrite plus_0_r. rewrite Z.add_0_r.
        rewrite Mem.load_int8_signed_unsigned.
        rewrite MCMEM. ss.
        desf. }
      des.

      hexploit (IH (ofs' + 1)%Z tid' (S i)).
      { nia. }
      { eauto. }
      intro LOAD.

      replace (Z.of_nat (S tid')) with (1 + Z.of_nat tid')%Z by nia.
      replace (i + S tid')%nat with (S i + tid')%nat by nia.
      rewrite Z.add_assoc. apply LOAD.
    }
    hexploit AUX; eauto.
  Qed.

  Lemma mcmem_init_data_list_size
        ginfo
    : init_data_list_size
        (mcmem_init_data (Z.of_nat max_num_tasks)
                         (group_memflags ginfo)) =
      (Z.of_nat max_num_tasks).
  Proof.
    assert (LEN_GMFS: length (group_memflags ginfo) = num_tasks).
    { unfold group_memflags.
      rewrite imap_length.
      apply repeat_length. }

    unfold mcmem_init_data.
    rewrite init_data_list_size_app.

    match goal with
    | |- (init_data_list_size (map ?f ?l) + _)%Z = _ =>
      replace (init_data_list_size (map f l)) with (Zlength l)
    end.
    2: { clear.
         induction (group_memflags ginfo) as [| h t IH]; ss.
         rewrite Zlength_cons.
         rewrite <- IH. nia. }

    rewrite Zlength_correct.
    rewrite LEN_GMFS.

    assert (NT_BOUND: (num_tasks <= max_num_tasks)%nat).
    { pose proof num_tasks_bound.
      unfold num_tasks. ss. }

    destruct (Z.ltb_spec (Z.of_nat num_tasks)
                         (Z.of_nat max_num_tasks)) as [LT|GE].
    - ss. nia.
    - ss. nia.
  Qed.

  Lemma load_store_init_data_flatmap_mcmem
        b ofs mcasts'
        midx mip_bs mbrs tid'
        (MCMEM: Genv.load_store_init_data
                  ge m b ofs
                  (flat_map (mcmem_init_data
                               (Z.of_nat max_num_tasks))
                            (map group_memflags mcasts')))
        (MIDX: nth_error mcasts' midx = Some (mip_bs, mbrs))
        (* (MAX_NUM_MEMBERS: (length mbrs <= num_tasks)%nat) *)
        (TID': (tid' < num_tasks)%nat)
    : Mem.load Mint8signed m b
               (ofs + Z.of_nat ((max_num_tasks * midx + tid'))) =
      Some (Vint (if existsb (Nat.eqb tid') mbrs
                  then Int.one else Int.zero)).
  Proof.
    depgen ofs. revert midx MIDX.
    induction mcasts' as [| h_mc t_mc IH]; i; ss.
    { destruct midx; ss. }

    destruct midx as [| midx]; ss.
    { clarify.
      apply load_store_init_data_app in MCMEM. des.
      rewrite Nat.mul_0_r. ss.
      eapply load_store_init_data_mcmem; eauto.
    }
    apply load_store_init_data_app in MCMEM. des.

    rewrite mcmem_init_data_list_size in *.
    hexploit IH; eauto. intro LOAD.
    match goal with
    | LOAD: Mem.load _ m b ?ofs1 = Some ?a |-
      Mem.load _ m b ?ofs2 = Some ?a =>
      replace ofs2 with ofs1 by nia
    end.
    congruence.
  Qed.

  Section MCAST_MEMBER.
    Hypothesis DEFMAP:
      (prog_defmap p) ! main_prm._MCAST_MEMBER =
      Some (Gvar (config_prm.v_MCAST_MEMBER
                    (Z.of_nat max_num_tasks)
                    (Z.of_nat max_num_mcasts)
                    mcast_memflags)).

    Lemma _init_mem_mcm
      : exists b_mcm,
        Genv.find_symbol ge main_prm._MCAST_MEMBER = Some b_mcm /\
        (b_mcm < Genv.genv_next ge)%positive /\
        (forall mid midx tid' mip_bs mbrs
           (MCAST_ID: mid = (num_tasks + midx)%nat)
           (MCASTS_MID: nth_error mcasts midx = Some (mip_bs, mbrs))
           (RANGE_TID: (tid' < num_tasks)%nat),
            Mem.load Mint8signed m b_mcm
                     (Z.of_nat (max_num_tasks * midx + tid')) =
            Some (Vint (if existsb (Nat.eqb tid') mbrs
                        then Int.one else Int.zero)))
    .
    Proof.
      apply Genv.find_def_symbol in DEFMAP.
      destruct DEFMAP as (b & FSYMB & FDEF).

      eexists.
      split; eauto.
      split.
      { eapply Genv.genv_symb_range. eauto. }

      eapply Genv.init_mem_characterization_gen in FDEF; eauto.
      destruct FDEF as (RANGE_PERM & PERM_ORDER &
                        LOAD_STORE & LOADBYTES).
      ss.
      hexploit LOAD_STORE.
      { ss. }
      clear LOAD_STORE. clear LOADBYTES.
      intro LOAD_STORE.
      apply load_store_init_data_app in LOAD_STORE. des.

      i. hexploit load_store_init_data_flatmap_mcmem; eauto.
    Qed.
  End MCAST_MEMBER.

  (* writable *)

  Section SEND_BUF.
    Hypothesis DEFMAP:
      (prog_defmap p) ! main_prm._send_buf =
      Some (Gvar (main_prm.v_send_buf (Z.of_nat msg_size_k))).

    Lemma _init_mem_send_buf
      : exists b_sbuf,
        Genv.find_symbol ge main_prm._send_buf = Some b_sbuf /\
        (b_sbuf < Genv.genv_next ge)%positive /\
        Mem.loadbytes m b_sbuf 0 8 = Some (inj_bytes (IntByte.to_bytes64 Int64.zero)) /\
        (* Mem.load Mint64 m b_sbuf 0 = Some (Vlong Int64.zero) /\ *)
        Mem.load Mint8signed m b_sbuf 8 = Some (Vint Int.zero) /\
        Mem.loadbytes m b_sbuf 9 (Z.of_nat msg_size) =
        Some (inj_bytes (List.repeat Byte.zero msg_size)) /\
        Mem.range_perm m b_sbuf 0 (Z.of_nat pld_size) Cur Writable
    .
    Proof.
      apply Genv.find_def_symbol in DEFMAP.
      destruct DEFMAP as (b & FSYMB & FDEF).

      eexists.
      split; eauto.
      split.
      { eapply Genv.genv_symb_range. eauto. }

      eapply Genv.init_mem_characterization_gen in FDEF; eauto.
      destruct FDEF as (RANGE_PERM & PERM_ORDER &
                        LOAD_STORE & LOADBYTES).

      hexploit LOADBYTES; ss.
      clear LOADBYTES.

      assert (STRT_SZ_EQ: msg_struct_sz (Z.of_nat msg_size_k) =
                          Z.of_nat max_pld_size).
      { unfold msg_struct_sz, max_pld_size.
        unfold max_msg_size. nia. }
      rewrite STRT_SZ_EQ in *.
      rewrite Z.max_l in * by nia.
      rewrite Z.add_0_r in *.
      rewrite app_nil_r.
      rewrite Nat2Z.id.
      rewrite list_repeat_eq.

      intro LOADBYTES.
      assert (SIZE_DIV: exists rest,
                 (max_pld_size = 8 + (1 + (msg_size + rest)))%nat).
      { clear.
        unfold max_pld_size.
        exists (max_msg_size - msg_size)%nat.
        unfold max_msg_size.
        pose proof msg_size_bound. nia. }
      des.
      rewrite SIZE_DIV in LOADBYTES.

      rewrite Nat2Z.inj_add in LOADBYTES.
      eapply Mem_loadbytes_split' in LOADBYTES; cycle 1.
      { nia. }
      { nia. }

      replace (Z.of_nat 8) with 8%Z in * by ss.
      replace (Z.to_nat 8) with 8%nat in * by ss.

      destruct LOADBYTES as [LOAD_TIME LOADBYTES].
      split.
      { erewrite LOAD_TIME. ss. }

      rewrite Nat2Z.inj_add in LOADBYTES.
      eapply Mem_loadbytes_split' in LOADBYTES; ss.
      2: { nia. }

      destruct LOADBYTES as [LOAD_TID LOADBYTES].
      split.
      { erewrite Mem.loadbytes_load; eauto; ss.
        solve_divide. }

      rewrite Nat2Z.inj_add in LOADBYTES.
      replace (Z.of_nat 1) with 1%Z in * by ss.
      replace (Z.to_nat 1) with 1%nat in * by ss.
      eapply Mem_loadbytes_split' in LOADBYTES; cycle 1.
      { nia. }
      { nia. }
      destruct LOADBYTES as [LOADBYTES LOADBYTES_REST].

      split; ss.
      { rewrite LOADBYTES. f_equal.
        rewrite Nat2Z.id.
        unfold inj_bytes.
        rewrite map_repeat.
        rewrite repeat_app.
        rewrite firstn_app_exact.
        2: { rewrite repeat_length. ss. }
        ss.
      }
      clear - RANGE_PERM.

      assert (pld_size <= max_pld_size)%nat.
      { unfold max_pld_size, pld_size.
        unfold max_msg_size.
        pose proof msg_size_bound. nia. }

      unfold v_send_buf in RANGE_PERM.
      unfold Genv.perm_globvar in RANGE_PERM. ss.

      ii. apply RANGE_PERM. nia.
    Qed.
  End SEND_BUF.

  Lemma _init_Mem_msg_entries
        b ofs
        (LBS: Mem.loadbytes m b ofs inb_sz =
              Some (repeat (Byte Byte.zero) inb_nsz))
    : iForall (Mem_msg_entry m b ofs) 0
              (repeat None num_tasks).
  Proof.
    apply iForall_nth. ss. i.
    destruct (lt_ge_dec n num_tasks).
    2: { rewrite repeat_nth_error_None; ss. }
    rewrite repeat_nth_error_Some by ss.
    ss.

    erewrite Mem_loadbytes_sublist; eauto; cycle 1.
    { nia. }
    { nia. }
    { hexploit (within_inb_nsz2 n mentry_ensz); eauto.
      { apply range_mentry_ensz. }
      unfold mentry_ensz. nia. }

    f_equal.
    rewrite Nat2Z.id.

    pose proof num_tasks_bound' as NT_BOUND.
    replace inb_nsz with (mentry_nsz * n +
                          mentry_nsz * (max_num_tasks - n))%nat.
    2: { unfold inb_nsz. nia. }

    rewrite repeat_app.
    rewrite skipn_app_exact.
    2: { rewrite repeat_length. nia. }

    destruct (max_num_tasks - n)%nat as [|n'] eqn: SUB.
    { exfalso. nia. }

    replace (mentry_nsz * S n')%nat with
        (S (max_msg_size + mentry_nsz * n'))%nat.
    2: { unfold mentry_nsz. nia. }
    ss.
  Qed.

  (* assert (MENTRY_SZ_DIV: exists rest, *)
  (*            (mentry_nsz = mentry_ensz + rest)%nat). *)
  (* { exists (mentry_nsz - mentry_ensz)%nat. *)
  (*   clear. *)
  (*   pose proof range_mentry_ensz. nia. } *)

  (*   des. rewrite MENTRY_SZ_DIV. *)

  (*   rewrite <- Nat.add_assoc. *)
  (*   rewrite repeat_app. *)
  (*   rewrite firstn_app_exact. *)
  (*   2: { rewrite repeat_length. ss. } *)

  (*   unfold inj_bytes, mentry_to_bytes. ss. *)
  (*   unfold mentry_ensz. rewrite plus_comm. ss. *)
  (*   rewrite map_repeat. ss. *)
  (* Qed. *)

  Section MSTORE.
    Hypothesis DEFMAP:
      (prog_defmap p) ! main_prm._mstore =
      Some (Gvar (main_prm.v_mstore (Z.of_nat msg_size_k)
                                    (Z.of_nat max_num_tasks))).

    Lemma _init_mem_mstore
      : exists b_mst,
        Genv.find_symbol ge main_prm._mstore = Some b_mst /\
        (b_mst < Genv.genv_next ge)%positive /\
        Mem.load Mint32 m b_mst 0 = Some (Vint Int.zero) /\
        Mem.range_perm m b_mst 0 4 Cur Writable /\
        Mem_inbox m b_mst 4 (List.repeat None num_tasks) /\
        Mem_inbox m b_mst (4 + inb_sz) (List.repeat None num_tasks)
    .
    Proof.
      apply Genv.find_def_symbol in DEFMAP.
      destruct DEFMAP as (b & FSYMB & FDEF).

      eexists.
      split; eauto.
      split.
      { eapply Genv.genv_symb_range. eauto. }

      eapply Genv.init_mem_characterization_gen in FDEF; eauto.
      destruct FDEF as (RANGE_PERM & PERM_ORDER &
                        LOAD_STORE & LOADBYTES).

      (* assert (INBOX_SZ_NNEG: 0 <= inb_sz). *)
      (* { apply range_inb_sz_precise. } *)

      hexploit LOADBYTES; ss.
      rewrite <- inb_sz_eq.

      clear LOADBYTES.
      rewrite Z.max_l by nia.
      rewrite app_nil_r.
      rewrite list_repeat_eq.
      rewrite Z2Nat.inj_add by nia.
      rewrite Z.add_0_r in *.
      (* rewrite <- Z2Nat.inj_add by nia. *)

      intro LOADBYTES.
      eapply Mem_loadbytes_split' in LOADBYTES; ss.
      2: { nia. }

      rewrite repeat_app in LOADBYTES.
      rewrite firstn_app_exact in LOADBYTES.
      2: { rewrite repeat_length. ss. }
      rewrite skipn_app_exact in LOADBYTES.
      2: { rewrite repeat_length. ss. }

      change (Z.to_nat 4) with 4%nat in LOADBYTES.
      destruct LOADBYTES as [LOAD_RCV LOADBYTES].

      split.
      { erewrite Mem.loadbytes_load; eauto; ss.
        solve_divide. }
      split.
      { ii. apply RANGE_PERM.
        rewrite <- inb_sz_eq.
        rewrite Z.max_l by nia.
        nia. }

      rewrite <- Zplus_diag_eq_mult_2 in LOADBYTES.
      eapply Mem_loadbytes_split' in LOADBYTES; try nia.
      rewrite Z2Nat.inj_add in LOADBYTES by nia.
      rewrite repeat_app in LOADBYTES.
      rewrite firstn_app_exact in LOADBYTES.
      2: { rewrite repeat_length. ss. }
      rewrite skipn_app_exact in LOADBYTES.
      2: { rewrite repeat_length. ss. }

      rewrite Nat2Z.id in LOADBYTES by ss.
      destruct LOADBYTES as [LOAD_INB1 LOAD_INB2].

      split.
      - clear LOAD_INB2.
        r. splits; ss; cycle 1.
        { (* unfold empty_msg_entry. *)
          rewrite repeat_length. ss. }
        { clear - RANGE_PERM.
          ii. apply RANGE_PERM.
          rewrite <- inb_sz_eq. nia. }
        eapply _init_Mem_msg_entries; eauto.
      - clear LOAD_INB1.
        r. splits; ss; cycle 1.
        { (* unfold empty_msg_entry. *)
          rewrite repeat_length. ss. }
        { clear - RANGE_PERM.
          ii. apply RANGE_PERM.
          rewrite <- inb_sz_eq. nia. }
        eapply _init_Mem_msg_entries; eauto.
    Qed.

  End MSTORE.

  Section SEND_HIST.
    Hypothesis DEFMAP:
      (prog_defmap p) ! main_prm._send_hist =
      Some (Gvar (main_prm.v_send_hist (Z.of_nat max_num_tasks))).

    Lemma _init_mem_send_hist
      : exists b_sh,
        Genv.find_symbol ge main_prm._send_hist = Some b_sh /\
        (b_sh < Genv.genv_next ge)%positive /\
        Mem.loadbytes m b_sh 0 (Z.of_nat num_tasks) =
        Some (map bool2memval (List.repeat false num_tasks)) /\
        Mem.range_perm m b_sh 0 (Z.of_nat num_tasks) Cur Writable
    .
    Proof.
      apply Genv.find_def_symbol in DEFMAP.
      destruct DEFMAP as (b & FSYMB & FDEF).

      eexists.
      split; eauto.
      split.
      { eapply Genv.genv_symb_range. eauto. }

      eapply Genv.init_mem_characterization_gen in FDEF; eauto.
      destruct FDEF as (RANGE_PERM & PERM_ORDER &
                        LOAD_STORE & LOADBYTES).
      ss.
      assert (MAX_NT_DIV: exists rst, (max_num_tasks = num_tasks + rst)%nat).
      { clear. pose proof num_tasks_bound'.
        exists (max_num_tasks - num_tasks)%nat. nia. }
      des.

      split.
      - hexploit LOADBYTES; eauto.
        rewrite Z.max_l by nia.
        rewrite Z.add_0_r.
        rewrite MAX_NT_DIV.
        rewrite Nat2Z.inj_add.
        rewrite list_repeat_eq.
        rewrite Z2Nat.inj_add by nia.
        rewrite app_nil_r.
        rewrite repeat_app.

        intro LB1.
        apply Mem_loadbytes_split' in LB1; try nia.
        destruct LB1 as [LB LB_R].
        rewrite Nat2Z.id in *.
        rewrite firstn_app_exact in LB.
        2: { rewrite repeat_length. ss. }

        rewrite LB. f_equal.
        rewrite map_repeat. ss.
      - ii. apply RANGE_PERM.
        rewrite Z.max_l by nia.
        rewrite Z.add_0_r. nia.
    Qed.

  End SEND_HIST.

  Section TXS.
    Hypothesis DEFMAP:
      (prog_defmap p) ! main_prm._txs =
      Some (Gvar (main_prm.v_txs)).

    Lemma _init_mem_txs
      : exists b_txs,
        Genv.find_symbol ge main_prm._txs = Some b_txs /\
        (b_txs < Genv.genv_next ge)%positive /\
        Mem.load Mint32 m b_txs 0%Z = Some (Vint Int.zero) /\
        Mem.range_perm m b_txs 0%Z 4 Cur Writable.
    Proof.
      apply Genv.find_def_symbol in DEFMAP.
      destruct DEFMAP as (b & FSYMB & FDEF).

      eexists.
      split; eauto.
      split.
      { eapply Genv.genv_symb_range. eauto. }

      eapply Genv.init_mem_characterization_gen in FDEF; eauto.
      destruct FDEF as (RANGE_PERM & PERM_ORDER &
                        LOAD_STORE & LOADBYTES).

      hexploit LOAD_STORE.
      { ss. }
      clear LOAD_STORE.
      intro LOAD_STORE. ss. des.
      splits; eauto.
      rr in LOAD_STORE.
      rewrite LOAD_STORE; ss.
      solve_divide.
    Qed.
  End TXS.

  Section RXS.
    Hypothesis DEFMAP:
      (prog_defmap p) ! main_prm._rxs =
      Some (Gvar (main_prm.v_rxs)).

    Lemma _init_mem_rxs
      : exists b_rxs,
        Genv.find_symbol ge main_prm._rxs = Some b_rxs /\
        (b_rxs < Genv.genv_next ge)%positive /\
        Mem.load Mint32 m b_rxs 0%Z = Some (Vint Int.zero) /\
        Mem.range_perm m b_rxs 0%Z 4 Cur Writable.
    Proof.
      apply Genv.find_def_symbol in DEFMAP.
      destruct DEFMAP as (b & FSYMB & FDEF).

      eexists.
      split; eauto.
      split.
      { eapply Genv.genv_symb_range. eauto. }

      eapply Genv.init_mem_characterization_gen in FDEF; eauto.
      destruct FDEF as (RANGE_PERM & PERM_ORDER &
                        LOAD_STORE & LOADBYTES).

      hexploit LOAD_STORE.
      { ss. }
      clear LOAD_STORE.
      intro LOAD_STORE. ss. des.
      splits; eauto.
      rr in LOAD_STORE.
      rewrite LOAD_STORE; ss.
      solve_divide.
    Qed.
  End RXS.

End INIT_DATA_LEMMAS.

Section INIT_MEM_INVERSION.
  Import Clight.
  Context `{SystemEnv}.
  (* Context `{CProgSysEvent}. *)
  Variable cprog: Clight.program.
  Variable m_i: mem.
  Let ge := globalenv cprog.

  Hypothesis INIT_MEM: Genv.init_mem cprog = Some m_i.
  (* Variable gvars: list (ident * cglobvar). *)
  Variable tid: nat.
  Variable gfuns: list (ident * fundef).
  Variable cenvs: list (ident * composite).
  Hypothesis RANGE_TID: (tid < num_tasks)%nat.

  Context `{genv_props ge (main_gvar_ilist tid) gfuns cenvs}.

  (* (* init_mem_inversion *) *)
  (* Let glob_init: Genv.globals_initialized ge ge m_i. *)
  (* Proof. *)
  (*   apply Genv.init_mem_characterization_gen; eauto. *)
  (* Qed. *)

  Lemma main_gvar_find_def
        i gv b
        (FSYMB: Genv.find_symbol ge i = Some b)
        (IN: In (i, gv) (main_gvar_ilist tid))
    : Genv.find_def ge b = Some (Gvar gv).
  Proof.
    hexploit (in_gvar_ilist i); eauto.
    i. des. clarify.
    apply Genv.find_var_info_iff; eauto.
  Qed.

  Lemma bytes_of_init_data_list_map
        (ge': genv) l
    : Genv.bytes_of_init_data_list ge' l =
      concat (map (Genv.bytes_of_init_data ge') l).
  Proof.
    induction l as [| h t IH]; ss.
    rewrite IH. ss.
  Qed.

  (* Lemma loadbytes_ip_aux *)
  (*       (ge': genv) m (ip_bs: bytes) b ofs *)
  (*       (LEN_BD: length ip_bs < 16) *)
  (*       (LBS: Mem.loadbytes m b ofs 16 = *)
  (*             Some (concat (map (Genv.bytes_of_init_data ge') *)
  (*                               (ip_init_data ip_bs)))) *)
  (*   : Mem.loadbytes m b ofs (Zlength ip_bs + 1)%Z = *)
  (*     Some (inj_bytes (snoc ip_bs Byte.zero)). *)
  (* Proof. *)
  (*   ss. unfold encode_int in *. ss. *)
  (*   repeat rewrite rev_if_be_single in *. ss. *)
  (*   unfold app in LBS. *)
  (*   repeat (rewrite Int.unsigned_repr in LBS *)
  (*            by eapply ubyte_in_uint_range). *)
  (*   repeat rewrite Byte.repr_unsigned in LBS. *)

  (*   pose (k:= (16 - (Zlength ip_bs + 1))%Z). *)
  (*   assert (k >= 0)%Z. *)
  (*   { subst k. rewrite Zlength_correct. nia. } *)

  (*   replace 16%Z with (Zlength ip_bs + 1 + k)%Z in LBS. *)
  (*   2: { subst k. nia. } *)
  (*   apply Mem.loadbytes_split in LBS; ss. *)
  (*   2: { rewrite Zlength_correct. nia. } *)

  (*   des. rewrite LBS. *)
  (*   apply Mem.loadbytes_length in LBS. *)

  (*   unfold snoc. unfold inj_bytes. *)
  (*   rewrite map_app. *)
  (*   f_equal. *)
  (*   eapply (ip_bytes_aux ip_bs 16). *)
  (*   { ss. rewrite LBS1. eauto. } *)
  (*   { rewrite LBS. *)
  (*     rewrite Zlength_correct. nia. } *)
  (* Qed. *)

  Lemma init_mem_consts: mem_consts ge m_i tid.
  Proof.
    (* r in glob_init. *)
    econs.
    - i. ss.
      hexploit _init_mem_tid; eauto.
      { instantiate (1:= tid).
        pose proof range_num_tasks.
        range_stac. }
      { apply Genv.find_def_symbol.
        esplits; eauto.
        eapply main_gvar_find_def; eauto.
        sIn. }
      i. des. fold fundef in *. clarify.
    - i. ss.
      hexploit _init_mem_pals_period; eauto.
      { apply Genv.find_def_symbol.
        esplits; eauto.
        eapply main_gvar_find_def; eauto.
        sIn. }
      i. des. fold fundef in *. clarify.
    - i. ss.
      hexploit _init_mem_max_cskew; eauto.
      { apply Genv.find_def_symbol.
        esplits; eauto.
        eapply main_gvar_find_def; eauto.
        sIn. }
      i. des. fold fundef in *. clarify.
    - i. ss.
      hexploit _init_mem_max_nwdelay; eauto.
      { apply Genv.find_def_symbol.
        esplits; eauto.
        eapply main_gvar_find_def; eauto.
        sIn. }
      i. des. fold fundef in *. clarify.
    - i. ss.
      hexploit _init_mem_num_tasks; eauto.
      { apply Genv.find_def_symbol.
        esplits; eauto.
        eapply main_gvar_find_def; eauto.
        sIn. }
      i. des. fold fundef in *. clarify.
    - i. ss.
      hexploit _init_mem_num_mcasts; eauto.
      { apply Genv.find_def_symbol.
        esplits; eauto.
        eapply main_gvar_find_def; eauto.
        sIn. }
      i. des. fold fundef in *. clarify.
    - i. ss.
      hexploit _init_mem_msg_size; eauto.
      { apply Genv.find_def_symbol.
        esplits; eauto.
        eapply main_gvar_find_def; eauto.
        sIn. }
      i. des. fold fundef in *. clarify.
    - i. ss.
      hexploit _init_mem_port; eauto.
      { apply Genv.find_def_symbol.
        esplits; eauto.
        eapply main_gvar_find_def; eauto.
        sIn. }
      i. des. fold fundef in *. clarify.
    - i. ss.
      hexploit _init_mem_ip_addr; eauto.
      { apply Genv.find_def_symbol.
        esplits; eauto.
        eapply main_gvar_find_def; eauto.
        sIn. }
      i. des. fold fundef in *. clarify.
    - i. ss.
      hexploit _init_mem_mcm; eauto.
      { apply Genv.find_def_symbol.
        esplits; eauto.
        eapply main_gvar_find_def; eauto.
        sIn. }
      intros (b_mcm' & FSYMB2 & NBLK & INIT).
      fold fundef in *. clarify.
      eapply INIT; eauto.
  Qed.

  Lemma init_mem_mstore
    : mem_mstore ge m_i
                 false 4%Z (4 + inb_sz)%Z
                 MWITree.init_inbox MWITree.init_inbox.
  Proof.
    ii.
    hexploit _init_mem_mstore; eauto.
    { apply Genv.find_def_symbol.
      esplits; eauto.
      eapply main_gvar_find_def; eauto.
      sIn. }

    i. des. ss.
    fold fundef in *. clarify.
  Qed.

  Lemma init_mem_sbuf
    : mem_sbuf ge m_i 0 0 (List.repeat Byte.zero msg_size).
  Proof.
    ii.
    hexploit _init_mem_send_buf; eauto.
    { apply Genv.find_def_symbol.
      esplits; eauto.
      eapply main_gvar_find_def; eauto.
      sIn. }

    i. des. ss.
    fold fundef in *. clarify.
  Qed.

  Lemma init_mem_sh
    : mem_sh ge m_i (List.repeat false num_tasks).
  Proof.
    ii.
    hexploit _init_mem_send_hist; eauto.
    { apply Genv.find_def_symbol.
      esplits; eauto.
      eapply main_gvar_find_def; eauto.
      sIn. }

    i. des. ss.
    fold fundef in *. clarify.
  Qed.

  Lemma init_mem_txs: mem_txs ge m_i 0.
  Proof.
    ii.
    hexploit _init_mem_txs; eauto.
    { apply Genv.find_def_symbol.
      esplits; eauto.
      eapply main_gvar_find_def; eauto.
      sIn. }

    i. des. ss.
    fold fundef in *. clarify.
  Qed.

  Lemma init_mem_rxs: mem_rxs ge m_i 0.
  Proof.
    ii.
    hexploit _init_mem_rxs; eauto.
    { apply Genv.find_def_symbol.
      esplits; eauto.
      eapply main_gvar_find_def; eauto.
      sIn. }

    i. des. ss.
    fold fundef in *. clarify.
  Qed.

End INIT_MEM_INVERSION.


Require Import Coq.Program.Equality.
Require Import Language Notations Auxiliaries Subtyping Automations.
Require Import Strings.String.

Set Printing Parentheses.

Lemma tred_ord_toplike : forall (e e' : trm) (A : typ),
    ordinary A -> toplike A -> typedred e A e' -> e' = (trm_anno (trm_nat 1) A).
Proof.
  intros e e' A H_ord H_top H_tred.
  dependent induction H_tred; subst; eauto.
  - inversion H_top.
  - inversion H_top. contradiction.
  - inversion H_ord.
Qed.

Lemma tred_toplike :
  forall (A : typ),
    toplike A ->
    forall e1 e2 e1' e2' : trm, typedred e1 A e1' -> typedred e2 A e2' -> e1' = e2'.
Proof.
  intros A Htop.
  dependent induction Htop; intros e1 e2 e1' e2' H_tred1 H_tred2.
  - eapply tred_ord_toplike in H_tred1. eapply tred_ord_toplike in H_tred2.
    rewrite H_tred1. rewrite H_tred2. reflexivity.
    constructor. constructor. constructor. constructor.
  - inversion H_tred1; subst; eauto 3.
    + inversion H0.
    + inversion H0.
    + inversion H0.
    + inversion H_tred2; subst; eauto 3.
      * inversion H0.
      * inversion H0.
      * inversion H0.
      * assert (Heq1: v1 = v0).
        eapply IHHtop1; eauto 3.
        assert (Heq2: v2 = v3).
        eapply IHHtop2; eauto 3.
        rewrite Heq1. rewrite Heq2. reflexivity.
  - assert (HAB: toplike (typ_arrow A B)).
    constructor. assumption.
    eapply tred_ord_toplike in H_tred2; eauto.
    eapply tred_ord_toplike in H_tred1; eauto.
    rewrite H_tred1. rewrite H_tred2. reflexivity.
Qed.

Lemma tred_sub :
  forall (A B : typ) (v1 v2 : trm),
    value v1 -> typedred v1 A v2 ->
    typing nil nil infer_mode v1 B ->
    sub B A.
Proof.
  intros A B v1 v2 Hval Hred Htyp.
  generalize dependent B.
  induction Hred; eauto.
  - intros B Htyp.
    inversion Htyp; subst.
    inversion H3; subst. constructor.
  - intros B Htyp.
    eapply toplike_sub in H.
    eapply sub_transitivity; eauto 3.
  - intros B0 Htyp.
    inversion Hval; subst; clear Hval.
    inversion Htyp; subst; clear Htyp.
    inversion H7; subst; clear H7.
    + eapply sub_arrow; eauto 3.
    (* + dependent destruction H2. eapply toplike_sub_toplike in H2; eauto. contradiction. *)
  - intros B0 Htyp.
    inversion Hval; subst; clear Hval.
    inversion Htyp; subst; clear Htyp.
    + apply sub_and_l.
      eapply IHHred; eauto 3.
    + apply sub_and_l.
      eapply IHHred; eauto 3.
  - intros B0 Htyp.
    inversion Hval; subst; clear Hval.
    inversion Htyp; subst; clear Htyp.
    + apply sub_and_r.
      eapply IHHred; eauto 3.
    + apply sub_and_r.
      eapply IHHred; eauto 3.
Qed.

Lemma disjoint_value_consistent :
  forall (A B : typ) (v1 v2 : trm),
    disjoint_spec A B -> value v1 -> value v2 ->
    typing nil nil infer_mode v1 A ->
    typing nil nil infer_mode v2 B ->
    consistency_spec v1 v2.
Proof.
  intros A B v1 v2 Hdis Hv1 Hv2 Htyp1 Htyp2.
  unfold consistency_spec.
  intros A0 e1' e2'. intros Hred1 Hred2.
  assert (Hsub1: sub A A0).
  eapply tred_sub. apply Hv1. apply Hred1. apply Htyp1.
  assert (Hsub2: sub B A0).
  eapply tred_sub. apply Hv2. apply Hred2. apply Htyp2.
  assert (Htop : toplike A0).
  unfold disjoint_spec in Hdis.
  apply Hdis. assumption. assumption.
  eapply tred_toplike. apply Htop. apply Hred1. apply Hred2.
Qed.

Lemma tred_determinism :
  forall (v v1 v2 : trm) (A : typ),
    value v -> (exists B, typing nil nil infer_mode v B) ->
    typedred v A v1 -> typedred v A v2 -> v1 = v2.
Proof.
  intros v v1 v2 A Hval Htyp Hred1.
  generalize dependent v2.
  induction Hred1.
  - intros v2 Hred2.
    inversion Hred2; subst.
    + reflexivity.
    + inversion H.
  - intros v2 Hred2.
    inversion Hred2; subst; clear Hred2; eauto.
    + inversion H.
    + inversion H. contradiction.
    + symmetry. eapply tred_ord_toplike; eauto.
    + symmetry. eapply tred_ord_toplike; eauto.
    + inversion H0.
  - intros v2 Hred2.
    inversion Hred2; subst; clear Hred2.
    + inversion H2. contradiction.
    + reflexivity.
  - intros v0 Hred2.
    inversion Hred2; subst; eauto.
    + eapply tred_ord_toplike; eauto 3.
    + eapply IHHred1; eauto.
      * inversion Hval; assumption.
      * destruct Htyp. inversion H0; subst.
        exists A0. assumption.
        exists A0. assumption.
    + destruct Htyp.
      inversion H0; subst.
      * inversion Hval; subst; clear Hval.
        assert (Hcons: consistency_spec v1 v2).
        eapply disjoint_value_consistent; eauto 3.
        eapply Hcons; eauto 3.
      * eapply H11; eauto 3.
    + inversion H.
  - intros v0 Hred2.
    inversion Hred2; subst; eauto.
    + eapply tred_ord_toplike; eauto 3.
    + destruct Htyp.
      inversion H0; subst; eauto.
      * inversion Hval; subst; clear Hval.
        assert(Hcons: consistency_spec v1 v2).
        eapply disjoint_value_consistent; eauto 3.
        unfold consistency_spec in Hcons.
        symmetry. eapply Hcons; eauto 3.
      * unfold consistency_spec in H10.
        symmetry. eapply H11; eauto.
    + inversion Hval; subst; clear Hval.
      eapply IHHred1.
      * assumption.
      * destruct Htyp. inversion H0; subst.
        exists B. assumption.
        exists B. assumption.
      * assumption.
    + inversion H.
  - intros v0 Hred2.
    inversion Hred2; subst; clear Hred2.
    + inversion H0.
    + inversion H0.
    + inversion H0.
    + assert (Heq1: v1 = v3).
      eapply IHHred1_1; eauto 3.
      assert (Heq2: v2 = v4).
      eapply IHHred1_2; eauto 3.
      rewrite Heq1. rewrite Heq2. reflexivity.
Qed.

Lemma tred_value :
  forall (v v' : trm) (A : typ),
    value v -> typedred v A v' -> value v'.
Proof.
  intros v v' A Hval Hred.
  induction Hred; eauto.
  + apply IHHred. inversion Hval; eauto.
  + apply IHHred. inversion Hval; eauto.
Qed.

Lemma tred_transitivity : forall (v1 v2 v3 : trm) (A B : typ),
    value v1 -> typedred v1 A v2 -> typedred v2 B v3 -> typedred v1 B v3.
Proof.
  intros v1 v2 v3 A B Hval Hred1 Hred2.
  generalize dependent v3.
  generalize dependent B.
  dependent induction Hred1; eauto.
  - intros B v3 Hred2. dependent induction Hred2; eauto.
  - intros B0 v3 Hred2. dependent induction Hred2; eauto.
    + constructor. assumption.
      eapply sub_transitivity; eauto.
      eapply sub_transitivity; eauto.
  - intros B v3 Hred2.
    inversion Hval; subst; clear Hval.
    induction Hred2; eauto.
  - intros B v3 Hred2. inversion Hval; subst; clear Hval.
    induction Hred2; eauto.
  - intros B0 v0 Hred2.
    generalize dependent v0.
    induction B0; intros v0 Hred2; eauto.
    + inversion Hred2; subst; clear Hred2; eauto.
    + inversion Hred2; subst; clear Hred2; eauto.
    + inversion Hred2; subst; clear Hred2; eauto.
    + inversion Hred2; subst; clear Hred2; eauto.
Qed.

Lemma tred_consistency :
  forall (v v1 v2 : trm) (A B C : typ),
    value v -> typing nil nil infer_mode v C ->
    typedred v A v1 ->
    typedred v B v2 ->
    consistency_spec v1 v2.
Proof.
  intros v v1 v2 A B C Hval Htyp Hred1 Hred2.
  unfold consistency_spec.
  intros D v1' v2' Hred1' Hred2'.
  assert (Htrans1: typedred v D v1').
  eapply tred_transitivity. apply Hval. apply Hred1. apply Hred1'.
  assert (Htrans2: typedred v D v2').
  eapply tred_transitivity. apply Hval. apply Hred2. apply Hred2'.
  eapply tred_determinism; eauto 3.
Qed.

Lemma typing_merge_inversion:
  forall (v1 v2 : trm),
    (exists (A : typ), typing nil nil infer_mode (trm_merge v1 v2) A) ->
    (exists (B : typ), typing nil nil infer_mode v1 B) /\
    (exists (C : typ), typing nil nil infer_mode v2 C).
Proof.
  intros v1 v2 Htyp.
  destruct Htyp.
  inversion H; subst.
  - split. eauto. eauto.
  - split. eauto. eauto.
Qed.

Lemma ptype_determinsm :
  forall (e : trm) (A B : typ),
    ptype e A -> ptype e B -> A = B.
Proof.
  intros e A B Hp1 Hp2.
  generalize dependent B.
  dependent induction Hp1.
  - intros. inversion Hp2. reflexivity.
  - intros. inversion Hp2. reflexivity.
  - intros. inversion Hp2; subst.
    assert (A = A0).
    eapply IHHp1_1; eauto.
    assert (B = B1).
    eapply IHHp1_2; eauto.
    rewrite H. rewrite H0. reflexivity.
Qed.

Lemma appsub_determinism :
  forall (A : typ) (B1 B2 : typ) (S : arg),
    appsub S A B1 ->
    appsub S A B2 ->
    B1 = B2.
Proof.
  intros A B1 B2 S Has1 Has2.
  generalize dependent B2.
  dependent induction Has1; intros.
  - dependent destruction Has2.
    + reflexivity.
  - dependent destruction Has2.
    + assert (Heq: D = D0).
      eapply IHHas1; eauto.
      rewrite Heq. reflexivity.
  - dependent destruction Has2.
    + eapply IHHas1; eauto.
    + admit.
  - dependent destruction Has2.
    + admit.
    + eapply IHHas1; eauto.
Admitted.

Lemma ptype_merge_same :
  forall (v1 v2 : trm) (A : typ),
    value v1 -> value v2 -> ptype (trm_merge v1 v2) (typ_and A A) ->
    v1 = v2.
Proof.
Admitted.

Lemma papp_determinism :
  forall (v vl e1 e2 : trm),
    value v -> value vl ->
    (exists (B : typ), typing nil nil infer_mode vl B) ->
    papp v vl e1 -> papp v vl e2 -> e1 = e2.
Proof.
 intros v vl e1 e2 Hrv Hv Htyp Hp1 Hp2.
  generalize dependent e2.
  dependent induction Hp1.
  - intros. inversion Hp2; subst.
    + assert (A = A0). eapply ptype_determinsm; eauto.
      rewrite H3. reflexivity.
    + dependent destruction H. dependent destruction H0. contradiction.
    + assert (Heq: A = C). eapply ptype_determinsm; eauto. subst.
      contradiction.
    + assert (Heq: A = C). eapply ptype_determinsm; eauto. subst.
      contradiction.
  - intros. dependent destruction Hp2.
    + dependent destruction H1. dependent destruction H2. contradiction.
    + assert (v' = v'0). eapply tred_determinism; eauto.
      rewrite H3; eauto.
  - intros. apply IHHp1; eauto.
    + dependent destruction Hrv. assumption.
    + dependent destruction Hp2; eauto.
      * assert (Heq: A0 = C). eapply ptype_determinsm; eauto. subst.
        contradiction.
      * assert (B = B0). eapply ptype_determinsm; eauto. subst.
        assert (C = C0). eapply ptype_determinsm; eauto. subst.
        assert (A = A0). eapply appsub_determinism; eauto. subst.
        dependent destruction H6.
        assert (A = B).
        assert (A = A0). eapply ptype_determinsm; eauto. subst.
        assert (B = A0). eapply ptype_determinsm; eauto. subst.
        reflexivity. subst.
        dependent destruction Hrv.
        assert (v1 = v2). eapply ptype_merge_same; eauto. subst. eauto.
  - intros. apply IHHp1; eauto.
    + dependent destruction Hrv. assumption.
    + dependent destruction Hp2; eauto.
      * assert (Heq: A0 = C). eapply ptype_determinsm; eauto. subst.
        contradiction.
      * assert (B = B0). eapply ptype_determinsm; eauto. subst.
        assert (C = C0). eapply ptype_determinsm; eauto. subst.
        assert (A = A0). eapply appsub_determinism; eauto. subst.
        dependent destruction H6.
        assert (A = B).
        assert (A = A0). eapply ptype_determinsm; eauto. subst.
        assert (B = A0). eapply ptype_determinsm; eauto. subst.
        reflexivity. subst.
        dependent destruction Hrv.
        assert (v1 = v2). eapply ptype_merge_same; eauto. subst. eauto.
Qed.

Lemma value_cannot_step_further :
  forall (v : trm),
    value v -> forall (e : trm), not (step v e).
Proof.
  intros v Hval.
  induction v.
  - inversion Hval.
  - inversion Hval.
  - inversion Hval.
  - unfold not. intros. inversion H.
  - inversion Hval.
  - inversion Hval; subst.
    intros. unfold not. intros.
    inversion H; subst.
    + eapply IHv1; eauto 3.
    + eapply IHv2; eauto 3.
  - inversion Hval; subst; clear Hval.
    induction H0.
    + intros. unfold not. intros.
      inversion H; subst.
      * inversion H2.
      * apply H2. constructor. constructor.
    + intros. unfold not. intros.
      inversion H; subst.
      * inversion H2.
      * apply H2. constructor. constructor.
Qed.

Lemma app_check_inversion :
  forall (v vl : trm) (A : typ),
    value v -> value vl -> typing nil nil check_mode (trm_app v vl) A ->
    exists (B : typ), typing nil nil infer_mode vl B.
Proof.
  intros r vl A Hrv Hv Hchk.
  dependent destruction Hchk.
  - inversion H0.
  - exists A. auto.
  - dependent destruction Hchk.
    exists A0. eauto.
Qed.

(* aux lemma for anno_check_to_infer *)
Lemma value_with_anno_is_not_value :
  forall (v : trm) (A : typ),
    value v -> not (value (trm_anno v A)).
Proof.
  intros v A Hv.
  unfold not. intro.
  dependent destruction H.
  dependent induction H.
  - inversion Hv.
  - inversion Hv.
Qed.

(* this case have conflict with typing rule: any value can be checked by lemma *)
(* current workaround is add a premise not-toplike *)
Lemma anno_check_to_infer :
  forall (v : trm) (A B : typ),
    value v -> typing nil nil check_mode (trm_anno v A) B ->
    (exists (C : typ), typing nil nil infer_mode v C).
Proof.
  intros v A B Hv Htyp.
  dependent destruction Htyp.
  inversion H0.
  dependent destruction Htyp.
  dependent destruction Htyp.
  - dependent destruction H1; try solve [inversion Hv].
  - inversion Hv.
  - exists B0; eauto.
Qed.

(* aux lemma for step_determinism *)
Lemma lambda_typing1 :
  forall (e : trm) (A B : typ),
    typing nil (cons A nil) infer_mode e B ->
    (exists C, typing nil nil check_mode e C).
Proof.
  intros e A B Htyp.
  dependent induction Htyp.
  - simpl in *.
    exists (typ_arrow A0 B). eapply typing_sub.
    assert (Habs: typing nil nil infer_mode (trm_abs A0 e) (typ_arrow A0 B)).
    eapply typing_abs1; eauto. eapply Habs. eapply sub_reflexivity.
  - dependent destruction H.
    + dependent destruction H0.
      exists (typ_arrow A0 A1). eapply typing_sub; eauto.
      eapply sub_reflexivity.
    + clear IHHtyp. exists (typ_and A0 B). eapply typing_sub; eauto.
      eapply sub_reflexivity.
    + clear IHHtyp. exists (typ_and A0 B). eapply typing_sub; eauto.
      eapply sub_reflexivity.
  - exists B. eapply typing_app2.
    + eapply Htyp1.
    + admit.
  - clear IHHtyp1 IHHtyp2.
    exists B. eapply typing_sub; eauto.
Admitted.

Lemma step_determinism :
  forall (e e1 e2 : trm) (A : typ),
    typing nil nil check_mode e A ->
    step e e1 -> step e e2 -> e1 = e2.
Proof.
  intros e e1 e2 A Htyp Hred1.
  generalize dependent e2.
  generalize dependent A.
  induction Hred1.
  - intros A Htyp e2 Hred2.
    inversion Hred2; subst.
    reflexivity.
  - intros A Htyp e2 Hred2.
    inversion Hred2; subst. (* papp and 2 congruence rules *)
    + eapply app_check_inversion in Htyp; eauto.
      apply papp_determinism with (v:=v) (vl:=vl); eauto.
    + eapply value_cannot_step_further in H5. inversion H5. auto.
    + eapply value_cannot_step_further in H6. inversion H6. auto.
  - intros A0 Htyp e2 Hred2.
    dependent destruction Hred2.
    + eapply tred_determinism; eauto 3.
      eapply anno_check_to_infer in Htyp; eauto.
    + eapply value_cannot_step_further in Hred2; eauto. contradiction.
  - intros A0 Htyp e2 Hred2.
    dependent destruction Hred2.
    + eapply value_cannot_step_further in Hred1. contradiction.
      auto.
    + assert (Heq: e' = e'0).
      dependent destruction Htyp.
      * inversion H1.
      * dependent destruction Htyp.
        eapply IHHred1; eauto.
      * rewrite Heq. reflexivity.
  - intros A Htyp e0 Hred2.
    dependent destruction Hred2.
    + eapply value_cannot_step_further in Hred1; eauto. contradiction.
    + assert (Heq: e1' = e1'0).
      dependent destruction Htyp.
      * inversion H0.
      * eapply IHHred1; eauto 3.
      * dependent destruction Htyp.
        assert (exists C, typing nil nil check_mode e1 C).
        eapply lambda_typing1; eauto 3.
        destruct H0.
        eapply IHHred1; eauto 3.
      * rewrite Heq; eauto.
    + eapply value_cannot_step_further in Hred1. contradiction. assumption.
  - intros A Htyp e0 Hred2.
    dependent destruction Hred2.
    + eapply value_cannot_step_further in Hred1. contradiction. assumption.
    + eapply value_cannot_step_further in Hred2. contradiction. assumption.
    + assert (Heq: e2' = e2'0).
      dependent destruction Htyp.
      * inversion H1.
      * eapply IHHred1; eauto 3.
      * dependent destruction Htyp.
        eapply IHHred1; eauto 3.
      * rewrite Heq. reflexivity.
  - intros A Htyp e0 Hred2.
    dependent destruction Hred2.
    + assert (Heq: e1' = e1'0).
      dependent destruction Htyp.
      inversion H0.
      dependent destruction Htyp.
      * eapply IHHred1; eauto.
      * eapply IHHred1; eauto.
      * rewrite Heq. reflexivity.
    + eapply value_cannot_step_further in Hred1. contradiction. assumption.
  - intros A Htyp e0 Hred2.
    dependent destruction Hred2.
    + eapply value_cannot_step_further in Hred2.
      contradiction. assumption.
    + assert (Heq: e2' = e2'0).
      dependent destruction Htyp.
      inversion H1.
      dependent destruction Htyp.
      * eapply IHHred1; eauto.
      * eapply IHHred1; eauto.
      * rewrite Heq. reflexivity.
Qed.


Require Import
        Coq.Strings.String
        Coq.Vectors.Vector.

Require Import
        Fiat.Computation
        Fiat.BinEncoders.Env.Common.Specs
        Fiat.BinEncoders.Env.Common.WordFacts
        Fiat.BinEncoders.Env.Common.ComposeIf
        Fiat.BinEncoders.Env.Common.ComposeOpt
        Fiat.BinEncoders.Env.Automation.Solver
        Fiat.BinEncoders.Env.BinLib.AlignedByteString
        Fiat.BinEncoders.Env.BinLib.AlignWord
        Fiat.BinEncoders.Env.BinLib.AlignedDecoders
        Fiat.BinEncoders.Env.Lib2.WordOpt
        Fiat.BinEncoders.Env.Lib2.NatOpt
        Fiat.BinEncoders.Env.Lib2.FixListOpt.

Instance ByteStringQueueTransformer : Transformer ByteString := ByteStringQueueTransformer.

Definition simple_record := ((word 16) * list (word 8))%type.

Definition Simple_Format_Spec
           (p : simple_record) :=
        encode_nat_Spec 8 (|snd p|)
  ThenC encode_word_Spec (fst p)
  ThenC encode_list_Spec encode_word_Spec (snd p)
  DoneC.

Definition Simply_OK (p : simple_record) :=
  ((|snd p|) < pow2 8)%nat.

Arguments split1' : simpl never.
Arguments split2' : simpl never.
Arguments weq : simpl never.
Arguments natToWord : simpl never.
Arguments Guarded_Vector_split : simpl never.
Arguments Core.append_word : simpl never.

Definition refine_simple_encode
  : { b : _ & forall (p : simple_record)
                     (p_OK : Simply_OK p),
          refine (Simple_Format_Spec p ())
                 (ret (b p)) }.
Proof.
  unfold Simple_Format_Spec.
  eexists; intros.
  eapply AlignedEncodeChar; eauto.
  eapply AlignedEncode2Char; eauto.
  etransitivity.
  apply refine_under_bind_both.
  eapply optimize_align_encode_list.
  etransitivity.
  eapply aligned_encode_char_eq.
  instantiate (1 := fun a ce => (existT _ _ _, _)); simpl.
  reflexivity.
  intros; unfold Bind2; simplify with monad laws; higher_order_reflexivity.
  simpl.
  match goal with
    |- context [let (v, c) := ?z in ret (@?b v c)] =>
    rewrite (zeta_inside_ret z _)
  end.
  simplify with monad laws; simpl.
  rewrite zeta_to_fst; simpl.
  replace ByteString_id
  with (build_aligned_ByteString (Vector.nil _)).
  erewrite <- build_aligned_ByteString_append.
  reflexivity.
  eapply ByteString_f_equal;
    instantiate (1 := eq_refl _); reflexivity.
Defined.

Definition byte_aligned_simple_encoder
             (r : simple_record)
  := Eval simpl in (projT1 refine_simple_encode r).

Import Vectors.VectorDef.VectorNotations.
Print byte_aligned_simple_encoder.

Definition Simple_Format_decoder
  : CorrectDecoderFor Simply_OK Simple_Format_Spec.
Proof.
  start_synthesizing_decoder.
  normalize_compose transformer.
  repeat decode_step idtac.
  intros; eauto using FixedList_predicate_rest_True.
  synthesize_cache_invariant.
  cbv beta; optimize_decoder_impl.
Defined.

Definition SimpleDecoderImpl
    := Eval simpl in (projT1 Simple_Format_decoder).

  Ltac rewrite_DecodeOpt2_fmap :=
    set_refine_evar;
    progress rewrite ?BindOpt_map, ?DecodeOpt2_fmap_if,
    ?DecodeOpt2_fmap_if_bool;
    subst_refine_evar.

Definition ByteAligned_SimpleDecoderImpl {A}
           (f : _ -> A)
           n
  : {impl : _ & forall (v : Vector.t _ (3 + n)),
         f (fst SimpleDecoderImpl (build_aligned_ByteString v) ()) =
         impl v () }.
Proof.
  eexists _; intros.
  etransitivity.
  set_refine_evar; simpl.
  unfold DecodeBindOpt2 at 1; rewrite_DecodeOpt2_fmap.
  rewrite (@AlignedDecodeNat NoCache.test_cache).
  subst_refine_evar; apply rewrite_under_LetIn; intros; set_refine_evar.
  unfold DecodeBindOpt2 at 1; rewrite_DecodeOpt2_fmap.
  rewrite (@AlignedDecode2Char NoCache.test_cache).
  subst_refine_evar; apply rewrite_under_LetIn; intros; set_refine_evar.
  unfold DecodeBindOpt2 at 1; rewrite_DecodeOpt2_fmap.
  erewrite optimize_align_decode_list.
  rewrite Ifopt_Ifopt; simpl.
  etransitivity.
  eapply optimize_under_if_opt; simpl; intros.
  higher_order_reflexivity.
  reflexivity.
  Focus 2.
  clear H; intros.
  etransitivity.
  match goal with
    |- ?b = _ =>
    let b' := (eval pattern (build_aligned_ByteString v0) in b) in
    let b' := match b' with ?f _ => f end in
      eapply (@optimize_Guarded_Decode n0 _ 1 b')
  end.
  destruct n0 as [ | [ | ?] ]; intros; try omega.
  apply (@decode_word_aligned_ByteString_overflow NoCache.test_cache) with (sz := 1); auto.
  destruct n0 as [ | ?]; intros; try omega.
  higher_order_reflexivity.
  instantiate (1 := fun n1 v1 (cd0 : CacheDecode) =>
                      If NPeano.leb 1 n1 Then (Some ((Vector.hd (Guarded_Vector_split 1 n1 v1), @existT _ (Vector.t _) _ (Vector.tl (Guarded_Vector_split 1 n1 v1))), cd0)) Else None).
  simpl; find_if_inside; simpl; try reflexivity.
  pattern n0, v0; apply Vector.caseS; simpl; intros.
  unfold decode_word, WordOpt.decode_word.
  rewrite aligned_decode_char_eq; reflexivity.
  subst_refine_evar; higher_order_reflexivity.
  higher_order_reflexivity.
Defined.

Definition ByteAligned_SimpleDecoderImpl' n :=
  Eval simpl in (projT1 (ByteAligned_SimpleDecoderImpl id n)).

Print ByteAligned_SimpleDecoderImpl'.


Require Export MinBFTass_tknows.
Require Export MinBFTass_knew.
Require Export MinBFTass_diss.
Require Export ComponentAxiom.

Section MinBFTass_tlearn.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc                 : DTimeContext        }.
  Context { minbft_context      : MinBFT_context      }.
  Context { m_initial_keys      : MinBFT_initial_keys }.
  Context { u_initial_keys      : USIG_initial_keys   }.
  Context { usig_hash           : USIG_hash           }.
  Context { minbft_auth         : MinBFT_auth         }.

  Lemma ASSUMPTION_trusted_learns_if_gen_true :
    forall (eo : EventOrdering),
      AXIOM_authenticated_messages_were_sent_or_byz eo MinBFTsys
      -> assume_eo eo (KE_ALL_TRUST ASSUMPTION_trusted_learns_if_gen).
  Proof.
    introv sendbyz; introv.
    rewrite <- sequent_true_iff_interpret.
    apply DERIVED_RULE_implies_all_trusted_learns_if_gen2_true; simseqs j;
      apply sequent_true_iff_interpret; eauto 3 with minbft;
      try (apply ASSUMPTION_in_knows_implies_trusted_knows_true);
      try (apply ASSUMPTION_diss_correct_implies_knows_true);
      try (apply ASSUMPTION_all_knew_or_learns_or_gen_true).

    { apply ASSUMPTION_authenticated_messages_were_sent_or_byz_true; simpl; auto; tcsp;
        try (complete (introv h q; destruct a as [a x], a; simpl in *; ginv; simpl in *; tcsp; eauto));
        try (complete (introv h q; destruct m; simpl in *; tcsp; repndors; subst; tcsp;
                       try (destruct p as [p a], p, a);
                       try (destruct c as [c a], c, a);
                       simpl in *; repndors; subst; simpl in *; tcsp)). }
  Qed.

End MinBFTass_tlearn.

Hint Resolve ASSUMPTION_trusted_learns_if_gen_true : minbft.


Require Export MicroBFTprops2.
Require Export ComponentAxiom.

Section MicroBFTass_tlearn.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc                 : DTimeContext          }.
  Context { microbft_context    : MicroBFT_context      }.
  Context { m_initial_keys      : MicroBFT_initial_keys }.
  Context { u_initial_keys      : USIG_initial_keys     }.
  Context { usig_hash           : USIG_hash             }.
  Context { microbft_auth       : MicroBFT_auth         }.

  Opaque KE_TOWNS.
  Opaque KE_TGENS.

  Lemma ASSUMPTION_trusted_learns_if_gen_true :
    forall (eo : EventOrdering),
      AXIOM_authenticated_messages_were_sent_or_byz eo MicroBFTsys
      -> assume_eo eo (KE_ALL_TRUST ASSUMPTION_trusted_learns_if_gen).
  Proof.
    introv sendbyz; introv lrn.
    destruct e as [e exe].

    simpl in *; exrepnd; GC.
    unfold learns_data in *; exrepnd; GC.

    pose proof (sendbyz e a (const_opTrust lrn3)) as sendbyz.
    simpl in *.
    repeat (autodimp sendbyz hyp).
    exrepnd; repndors; exrepnd; ginv;[|].

    {
      autodimp sendbyz5 hyp; eauto 3 with microbft.

      assert (exists k, loc e' = MicroBFTheader.node2name k) as eqloc'.
      { destruct a as [a tok], a, m; simpl in *; tcsp; ginv;
          try (complete (inversion sendbyz4; eauto)). }
      exrepnd.

      unfold M_output_sys_on_event in sendbyz5; simpl in *.
      rewrite eqloc'0 in *; simpl in *.
      apply M_output_ls_on_event_as_run in sendbyz5; exrepnd.
      applydup M_run_ls_before_event_ls_is_microbft in sendbyz5; exrepnd; subst; simpl in *.

      unfold M_output_ls_on_this_one_event in sendbyz6.
      remember (trigger_op e') as trig; symmetry in Heqtrig.
      destruct trig; simpl in *; tcsp;[].

      (* XXXXXXXXXXX *)
      unfold M_run_ls_on_input_out in *.
      unfold M_run_ls_on_input in *.
      autorewrite with comp microbft in *.
      Time microbft_dest_msg Case; [|].

      { Case "Request".

        inversion sendbyz6; subst; simpl in *; clear sendbyz6.
        repeat (repndors; subst; tcsp; simpl in *; ginv);[].

        assert (ex_node_e e') as exe' by (eexists; allrw; simpl; eauto).

        exists (MkEventN e' exe'); dands;
          allrw interp_owns; simpl; eauto 3 with minbft;
            try (complete (unfold data_is_owned_by; simpl; unfold ui2rep; simpl; eauto));[ | unfold data_is_owned_by; smash_microbft].

        unfold disseminate_data; simpl.
        unfold M_byz_output_sys_on_event; simpl.
        allrw; simpl.
        rewrite M_byz_output_ls_on_event_as_run.
        applydup @M_run_ls_before_event_M_byz_run_ls_before_event in sendbyz5 as byz.
        applydup trigger_op_Some_implies_trigger_message in Heqtrig as trig'.
        unfold M_byz_output_ls_on_this_one_event; simpl.
        unfold M_byz_run_ls_on_one_event; simpl.
        repeat (allrw; simpl).
        unfold data_is_in_out, event2out; rewrite trig'; simpl.
        unfold M_run_ls_on_input; simpl.
        autorewrite with comp microbft.
        repeat unfold_handler_concl.
        smash_microbft.
        eexists; dands; try reflexivity; dands; tcsp.
      }

      {
        Case "Commit".

        repeat (simpl in *; try autorewrite with comp minbft in *; smash_microbft2);
          try (complete (inversion sendbyz6; subst; simpl in *; tcsp)).
      }
    }

    {
      ginv.
      assert (ex_node_e e') as exe' by (eexists; allrw; simpl; eauto).
      exists (MkEventN e' exe'); simpl; allrw interp_towns; dands; eauto 3 with minbft;
        try (complete (unfold data_is_owned_by; simpl; unfold ui2rep; simpl; eauto));[].

      unfold M_byz_output_sys_on_event in *; simpl in *.
      rewrite sendbyz7 in *; simpl in *.

      assert (MicroBFTsys (MicroBFTheader.node2name (ui2rep t)) = MicroBFTlocalSys (ui2rep t)) as temp by auto.
      rewrite temp in *.

      unfold disseminate_data.
      unfold M_byz_output_sys_on_event; simpl.
      allrw.
      exists o; dands; auto.
      clear sendbyz4.

      revert dependent o.
      unfold is_trusted_event in *.
      unfold data_is_in_out, trusted_is_in_out, event2out; simpl in *; rewrite p; simpl in *.
      introv xx; subst; simpl in *.
      allrw; simpl; tcsp.
    }
  Qed.
  Hint Resolve ASSUMPTION_trusted_learns_if_gen_true : microbft.

End MicroBFTass_tlearn.

Hint Resolve ASSUMPTION_trusted_learns_if_gen_true : microbft.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition data_create_unknown1_spec0 (g_rd: Pointer) (data_addr: Z64) (map_addr: Z64) (g_data: Pointer) (adt: RData) : option (RData * Z64) :=
    match g_rd, data_addr, map_addr, g_data with
    | (_g_rd_base, _g_rd_ofst), VZ64 _data_addr, VZ64 _map_addr, (_g_data_base, _g_data_ofst) =>
      rely is_int64 _data_addr;
      rely is_int64 _map_addr;
      when' _t'1, adt == data_create_unknown_spec (_g_rd_base, _g_rd_ofst) (VZ64 _data_addr) (VZ64 _map_addr) (_g_data_base, _g_data_ofst) adt;
      rely is_int64 _t'1;
      Some (adt, (VZ64 _t'1))
     end
    .

End SpecLow.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  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 file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Whole-program behaviors *)

(* Adapted to our customSmallstep library *)

Require Import Classical.
Require Import ClassicalEpsilon.
Require Import Coqlib.
Require Import Events.
Require Import Globalenvs.
Require Import Integers.
Require Import customSmallstep.

Set Implicit Arguments.

(** * Behaviors for program executions *)

(** The four possible outcomes for the execution of a program:
- Termination, with a finite trace of observable events
  and an integer value that stands for the process exit code
  (the return value of the main function).
- Divergence with a finite trace of observable events.
  (At some point, the program runs forever without doing any I/O.)
- Reactive divergence with an infinite trace of observable events.
  (The program performs infinitely many I/O operations separated
   by finite amounts of internal computations.)
- Going wrong, with a finite trace of observable events
  performed before the program gets stuck.
*)

Inductive program_behavior: Type :=
  | Terminates: trace -> int -> program_behavior
  | Diverges: trace -> program_behavior
  | Reacts: traceinf -> program_behavior
  | Goes_wrong: trace -> program_behavior.

(** Operations and relations on behaviors *)

Definition not_wrong (beh: program_behavior) : Prop :=
  match beh with
  | Terminates _ _ => True
  | Diverges _ => True
  | Reacts _ => True
  | Goes_wrong _ => False
  end.

Definition behavior_app (t: trace) (beh: program_behavior): program_behavior :=
  match beh with
  | Terminates t1 r => Terminates (t ** t1) r
  | Diverges t1 => Diverges (t ** t1)
  | Reacts T => Reacts (t *** T)
  | Goes_wrong t1 => Goes_wrong (t ** t1)
  end.

Lemma behavior_app_assoc:
  forall t1 t2 beh,
  behavior_app (t1 ** t2) beh = behavior_app t1 (behavior_app t2 beh).
Proof.
  intros. destruct beh; simpl; f_equal; traceEq.
Qed.

Lemma behavior_app_E0:
  forall beh, behavior_app E0 beh = beh.
Proof.
  destruct beh; auto.
Qed.

Definition behavior_prefix (t: trace) (beh: program_behavior) : Prop :=
  exists beh', beh = behavior_app t beh'.

Definition behavior_improves (beh1 beh2: program_behavior) : Prop :=
  beh1 = beh2 \/ exists t, beh1 = Goes_wrong t /\ behavior_prefix t beh2.

Lemma behavior_improves_refl:
  forall beh, behavior_improves beh beh.
Proof.
  intros; red; auto.
Qed.

Lemma behavior_improves_trans:
  forall beh1 beh2 beh3,
  behavior_improves beh1 beh2 -> behavior_improves beh2 beh3 ->
  behavior_improves beh1 beh3.
Proof.
  intros. red. destruct H; destruct H0; subst; auto.
  destruct H as [t1 [EQ1 [beh2' EQ1']]].
  destruct H0 as [t2 [EQ2 [beh3' EQ2']]].
  subst. destruct beh2'; simpl in EQ2; try discriminate. inv EQ2.
  right. exists t1; split; auto. exists (behavior_app t beh3'). apply behavior_app_assoc.
Qed.

Lemma behavior_improves_bot:
  forall beh, behavior_improves (Goes_wrong E0) beh.
Proof.
  intros. right. exists E0; split; auto. exists beh. rewrite behavior_app_E0; auto.
Qed.

Lemma behavior_improves_app:
  forall t beh1 beh2,
  behavior_improves beh1 beh2 ->
  behavior_improves (behavior_app t beh1) (behavior_app t beh2).
Proof.
  intros. red; destruct H. left; congruence.
  destruct H as [t' [A [beh' B]]]. subst.
  right; exists (t ** t'); split; auto. exists beh'. rewrite behavior_app_assoc; auto.
Qed.

(** Associating behaviors to programs. *)

Section PROGRAM_BEHAVIORS.

Variable L: semantics.

Inductive state_behaves (s: state L): program_behavior -> Prop :=
  | state_terminates: forall t s' r,
      Star L s t s' ->
      final_state L s' r ->
      state_behaves s (Terminates t r)
  | state_diverges: forall t s',
      Star L s t s' -> Forever_silent L s' ->
      state_behaves s (Diverges t)
  | state_reacts: forall T,
      Forever_reactive L s T ->
      state_behaves s (Reacts T)
  | state_goes_wrong: forall t s',
      Star L s t s' ->
      Nostep L s' ->
      (forall r, ~final_state L s' r) ->
      state_behaves s (Goes_wrong t).

Inductive program_behaves: program_behavior -> Prop :=
  | program_runs: forall s beh,
      initial_state L s -> state_behaves s beh ->
      program_behaves beh
  | program_goes_initially_wrong:
      (forall s, ~initial_state L s) ->
      program_behaves (Goes_wrong E0).

Lemma state_behaves_app:
  forall s1 t s2 beh,
  Star L s1 t s2 -> state_behaves s2 beh -> state_behaves s1 (behavior_app t beh).
Proof.
  intros. inv H0; simpl; econstructor; eauto; try (eapply star_trans; eauto).
  eapply star_forever_reactive; eauto.
Qed.

(** * Existence of behaviors *)

(** We now show that any program admits at least one behavior.
  The proof requires classical logic: the axiom of excluded middle
  and an axiom of description. *)

(** The most difficult part of the proof is to show the existence
  of an infinite trace in the case of reactive divergence. *)

Section TRACEINF_REACTS.

Variable s0: state L.

Hypothesis reacts:
  forall s1 t1, Star L s0 t1 s1 ->
  exists s2, exists t2, Star L s1 t2 s2 /\ t2 <> E0.

Lemma reacts':
  forall s1 t1, Star L s0 t1 s1 ->
  { s2 : state L & { t2 : trace | Star L s1 t2 s2 /\ t2 <> E0 } }.
Proof.
  intros.
  destruct (constructive_indefinite_description _ (reacts H)) as [s2 A].
  destruct (constructive_indefinite_description _ A) as [t2 [B C]].
  exists s2; exists t2; auto.
Qed.

CoFixpoint build_traceinf' (s1: state L) (t1: trace) (ST: Star L s0 t1 s1) : traceinf' :=
  match reacts' ST with
  | existT _ s2 (exist _ t2 (conj A B)) =>
      Econsinf' t2
                (build_traceinf' (star_trans ST A (refl_equal _)))
                B
  end.

Lemma reacts_forever_reactive_rec:
  forall s1 t1 (ST: Star L s0 t1 s1),
  Forever_reactive L s1 (traceinf_of_traceinf' (build_traceinf' ST)).
Proof.
  cofix COINDHYP; intros.
  rewrite (unroll_traceinf' (build_traceinf' ST)). simpl.
  destruct (reacts' ST) as [s2 [t2 [A B]]].
  rewrite traceinf_traceinf'_app.
  econstructor. eexact A. auto. apply COINDHYP.
Qed.

Lemma reacts_forever_reactive:
  exists T, Forever_reactive L s0 T.
Proof.
  exists (traceinf_of_traceinf' (build_traceinf' (star_refl (step L) (globalenv L) s0))).
  apply reacts_forever_reactive_rec.
Qed.

End TRACEINF_REACTS.

Lemma diverges_forever_silent:
  forall s0,
  (forall s1 t1, Star L s0 t1 s1 -> exists s2, Step L s1 E0 s2) ->
  Forever_silent L s0.
Proof.
  cofix COINDHYP; intros.
  destruct (H s0 E0) as [s1 ST]. constructor.
  econstructor. eexact ST. apply COINDHYP.
  intros. eapply H. eapply star_left; eauto.
Qed.

Lemma state_behaves_exists:
  forall s, exists beh, state_behaves s beh.
Proof.
  intros s0.
  destruct (classic (forall s1 t1, Star L s0 t1 s1 -> exists s2, exists t2, Step L s1 t2 s2)).
(* 1 Divergence (silent or reactive) *)
  destruct (classic (exists s1, exists t1, Star L s0 t1 s1 /\
                       (forall s2 t2, Star L s1 t2 s2 ->
                        exists s3, Step L s2 E0 s3))).
(* 1.1 Silent divergence *)
  destruct H0 as [s1 [t1 [A B]]].
  exists (Diverges t1); econstructor; eauto.
  apply diverges_forever_silent; auto.
(* 1.2 Reactive divergence *)
  destruct (@reacts_forever_reactive s0) as [T FR].
  intros.
  generalize (not_ex_all_not _ _ H0 s1). intro A; clear H0.
  generalize (not_ex_all_not _ _ A t1). intro B; clear A.
  destruct (not_and_or _ _ B). contradiction.
  destruct (not_all_ex_not _ _ H0) as [s2 C]; clear H0.
  destruct (not_all_ex_not _ _ C) as [t2 D]; clear C.
  destruct (imply_to_and _ _ D) as [E F]; clear D.
  destruct (H s2 (t1 ** t2)) as [s3 [t3 G]]. eapply star_trans; eauto.
  exists s3; exists (t2 ** t3); split.
  eapply star_right; eauto.
  red; intros. destruct (app_eq_nil t2 t3 H0). subst. elim F. exists s3; auto.
  exists (Reacts T); econstructor; eauto.
(* 2 Termination (normal or by going wrong) *)
  destruct (not_all_ex_not _ _ H) as [s1 A]; clear H.
  destruct (not_all_ex_not _ _ A) as [t1 B]; clear A.
  destruct (imply_to_and _ _ B) as [C D]; clear B.
  destruct (classic (exists r, final_state L s1 r)) as [[r FINAL] | NOTFINAL].
(* 2.1 Normal termination *)
  exists (Terminates t1 r); econstructor; eauto.
(* 2.2 Going wrong *)
  exists (Goes_wrong t1); econstructor; eauto. red. intros.
  generalize (not_ex_all_not _ _ D s'); intros.
  generalize (not_ex_all_not _ _ H t); intros.
  auto.
Qed.

Theorem program_behaves_exists:
  exists beh, program_behaves beh.
Proof.
  destruct (classic (exists s, initial_state L s)) as [[s0 INIT] | NOTINIT].
(* 1. Initial state is defined. *)
  destruct (state_behaves_exists s0) as [beh SB].
  exists beh; econstructor; eauto.
(* 2. Initial state is undefined *)
  exists (Goes_wrong E0). apply program_goes_initially_wrong.
  intros. eapply not_ex_all_not; eauto.
Qed.

End PROGRAM_BEHAVIORS.

(** * Forward simulations and program behaviors *)

Section FORWARD_SIMULATIONS.

Variable L1: semantics.
Variable L2: semantics.
Variable S: forward_simulation L1 L2.

Lemma forward_simulation_state_behaves:
  forall i s1 s2 beh1,
  S i s1 s2 -> state_behaves L1 s1 beh1 ->
  exists beh2, state_behaves L2 s2 beh2 /\ behavior_improves beh1 beh2.
Proof.
  intros. inv H0.
(* termination *)
  exploit simulation_star; eauto. intros [i' [s2' [A B]]].
  exists (Terminates t r); split.
  econstructor; eauto. eapply fsim_match_final_states; eauto.
  apply behavior_improves_refl.
(* silent divergence *)
  exploit simulation_star; eauto. intros [i' [s2' [A B]]].
  exists (Diverges t); split.
  econstructor; eauto. eapply simulation_forever_silent; eauto.
  apply behavior_improves_refl.
(* reactive divergence *)
  exists (Reacts T); split.
  econstructor. eapply simulation_forever_reactive; eauto.
  apply behavior_improves_refl.
(* going wrong *)
  exploit simulation_star; eauto. intros [i' [s2' [A B]]].
  destruct (state_behaves_exists L2 s2') as [beh' SB].
  exists (behavior_app t beh'); split.
  eapply state_behaves_app; eauto.
  replace (Goes_wrong t) with (behavior_app t (Goes_wrong E0)).
  apply behavior_improves_app. apply behavior_improves_bot.
  simpl. decEq. traceEq.
Qed.

Theorem forward_simulation_behavior_improves:
  forall beh1, program_behaves L1 beh1 ->
  exists beh2, program_behaves L2 beh2 /\ behavior_improves beh1 beh2.
Proof.
  intros. inv H.
(* initial state defined *)
  exploit (fsim_match_initial_states S); eauto. intros [i [s' [INIT MATCH]]].
  exploit forward_simulation_state_behaves; eauto. intros [beh2 [A B]].
  exists beh2; split; auto. econstructor; eauto.
(* initial state undefined *)
  destruct (classic (exists s', initial_state L2 s')).
  destruct H as [s' INIT].
  destruct (state_behaves_exists L2 s') as [beh' SB].
  exists beh'; split. econstructor; eauto. apply behavior_improves_bot.
  exists (Goes_wrong E0); split.
  apply program_goes_initially_wrong.
  intros; red; intros. elim H; exists s; auto.
  apply behavior_improves_refl.
Qed.

Corollary forward_simulation_same_safe_behavior:
  forall beh,
  program_behaves L1 beh -> not_wrong beh ->
  program_behaves L2 beh.
Proof.
  intros. exploit forward_simulation_behavior_improves; eauto.
  intros [beh' [A B]]. destruct B.
  congruence.
  destruct H1 as [t [C D]]. subst. contradiction.
Qed.

End FORWARD_SIMULATIONS.

(** * Backward simulations and program behaviors *)

Section BACKWARD_SIMULATIONS.

Variable L1: semantics.
Variable L2: semantics.
Variable S: backward_simulation L1 L2.

Definition safe_along_behavior (s: state L1) (b: program_behavior) : Prop :=
  forall t1 s' b2, Star L1 s t1 s' -> b = behavior_app t1 b2 ->
     (exists r, final_state L1 s' r)
  \/ (exists t2, exists s'', Step L1 s' t2 s'').

Remark safe_along_safe:
  forall s b, safe_along_behavior s b -> safe L1 s.
Proof.
  intros; red; intros. eapply H; eauto. symmetry; apply behavior_app_E0.
Qed.

Remark star_safe_along:
  forall s b t1 s' b2,
  safe_along_behavior s b ->
  Star L1 s t1 s' -> b = behavior_app t1 b2 ->
  safe_along_behavior s' b2.
Proof.
  intros; red; intros. eapply H. eapply star_trans; eauto.
  subst. rewrite behavior_app_assoc. eauto.
Qed.

Remark not_safe_along_behavior:
  forall s b,
  ~ safe_along_behavior s b ->
  exists t, exists s',
     behavior_prefix t b
  /\ Star L1 s t s'
  /\ Nostep L1 s'
  /\ (forall r, ~(final_state L1 s' r)).
Proof.
  intros.
  destruct (not_all_ex_not _ _ H) as [t1 A]; clear H.
  destruct (not_all_ex_not _ _ A) as [s' B]; clear A.
  destruct (not_all_ex_not _ _ B) as [b2 C]; clear B.
  destruct (imply_to_and _ _ C) as [D E]; clear C.
  destruct (imply_to_and _ _ E) as [F G]; clear E.
  destruct (not_or_and _ _ G) as [P Q]; clear G.
  exists t1; exists s'.
  split. exists b2; auto.
  split. auto.
  split. red; intros; red; intros. elim Q. exists t; exists s'0; auto.
  intros; red; intros. elim P. exists r; auto.
Qed.

Lemma backward_simulation_star:
  forall s2 t s2', Star L2 s2 t s2' ->
  forall i s1 b, S i s1 s2 -> safe_along_behavior s1 (behavior_app t b) ->
  exists i', exists s1', Star L1 s1 t s1' /\ S i' s1' s2'.
Proof.
  induction 1; intros.
  exists i; exists s1; split; auto. apply star_refl.
  exploit (bsim_simulation S); eauto. eapply safe_along_safe; eauto.
  intros [i' [s1' [A B]]].
  assert (Star L1 s0 t1 s1'). intuition. apply plus_star; auto.
  exploit IHstar; eauto. eapply star_safe_along; eauto.
  subst t; apply behavior_app_assoc.
  intros [i'' [s2'' [C D]]].
  exists i''; exists s2''; split; auto. eapply star_trans; eauto.
Qed.

Lemma backward_simulation_forever_silent:
  forall i s1 s2,
  Forever_silent L2 s2 -> S i s1 s2 -> safe L1 s1 ->
  Forever_silent L1 s1.
Proof.
  assert (forall i s1 s2,
         Forever_silent L2 s2 -> S i s1 s2 -> safe L1 s1 ->
         forever_silent_N (step L1) (bsim_order S) (globalenv L1) i s1).
    cofix COINDHYP; intros.
    inv H.  destruct (bsim_simulation S _ _ _ H2 _ H0 H1) as [i' [s2' [A B]]].
    destruct A as [C | [C D]].
    eapply forever_silent_N_plus; eauto. eapply COINDHYP; eauto.
      eapply star_safe; eauto. apply plus_star; auto.
    eapply forever_silent_N_star; eauto. eapply COINDHYP; eauto.
      eapply star_safe; eauto.
  intros. eapply forever_silent_N_forever; eauto. apply bsim_order_wf.
Qed.

Lemma backward_simulation_forever_reactive:
  forall i s1 s2 T,
  Forever_reactive L2 s2 T -> S i s1 s2 -> safe_along_behavior s1 (Reacts T) ->
  Forever_reactive L1 s1 T.
Proof.
  cofix COINDHYP; intros. inv H.
  destruct (backward_simulation_star H2 _ (Reacts T0) H0) as [i' [s1' [A B]]]; eauto.
  econstructor; eauto. eapply COINDHYP; eauto. eapply star_safe_along; eauto.
Qed.

Lemma backward_simulation_state_behaves:
  forall i s1 s2 beh2,
  S i s1 s2 -> state_behaves L2 s2 beh2 ->
  exists beh1, state_behaves L1 s1 beh1 /\ behavior_improves beh1 beh2.
Proof.
  intros. destruct (classic (safe_along_behavior s1 beh2)).
(* 1. Safe along *)
  exists beh2; split; [idtac|apply behavior_improves_refl].
  inv H0.
(* termination *)
  assert (Terminates t r = behavior_app t (Terminates E0 r)).
    simpl. rewrite E0_right; auto.
  rewrite H0 in H1.
  exploit backward_simulation_star; eauto.
  intros [i' [s1' [A B]]].
  exploit (bsim_match_final_states S); eauto.
    eapply safe_along_safe. eapply star_safe_along; eauto.
  intros [s1'' [C D]].
  econstructor. eapply star_trans; eauto. traceEq. auto.
(* silent divergence *)
  assert (Diverges t = behavior_app t (Diverges E0)).
    simpl. rewrite E0_right; auto.
  rewrite H0 in H1.
  exploit backward_simulation_star; eauto.
  intros [i' [s1' [A B]]].
  econstructor. eauto. eapply backward_simulation_forever_silent; eauto.
  eapply safe_along_safe. eapply star_safe_along; eauto.
(* reactive divergence *)
  econstructor. eapply backward_simulation_forever_reactive; eauto.
(* goes wrong *)
  assert (Goes_wrong t = behavior_app t (Goes_wrong E0)).
    simpl. rewrite E0_right; auto.
  rewrite H0 in H1.
  exploit backward_simulation_star; eauto.
  intros [i' [s1' [A B]]].
  exploit (bsim_progress S); eauto. eapply safe_along_safe. eapply star_safe_along; eauto.
  intros [[r FIN] | [t' [s2' STEP2]]].
  elim (H4 _ FIN).
  elim (H3 _ _ STEP2).

(* 2. Not safe along *)
  exploit not_safe_along_behavior; eauto.
  intros [t [s1' [PREF [STEPS [NOSTEP NOFIN]]]]].
  exists (Goes_wrong t); split.
  econstructor; eauto.
  right. exists t; auto.
Qed.

Theorem backward_simulation_behavior_improves:
  forall beh2, program_behaves L2 beh2 ->
  exists beh1, program_behaves L1 beh1 /\ behavior_improves beh1 beh2.
Proof.
  intros. inv H.
(* L2's initial state is defined. *)
  destruct (classic (exists s1, initial_state L1 s1)) as [[s1 INIT] | NOINIT].
(* L1's initial state is defined too. *)
  exploit (bsim_match_initial_states S); eauto. intros [i [s1' [INIT1' MATCH]]].
  exploit backward_simulation_state_behaves; eauto. intros [beh1 [A B]].
  exists beh1; split; auto. econstructor; eauto.
(* L1 has no initial state *)
  exists (Goes_wrong E0); split.
  apply program_goes_initially_wrong.
  intros; red; intros. elim NOINIT; exists s0; auto.
  apply behavior_improves_bot.
(* L2 has no initial state *)
  exists (Goes_wrong E0); split.
  apply program_goes_initially_wrong.
  intros; red; intros.
  exploit (bsim_initial_states_exist S); eauto. intros [s2 INIT2].
  elim (H0 s2); auto.
  apply behavior_improves_refl.
Qed.

Corollary backward_simulation_same_safe_behavior:
  (forall beh, program_behaves L1 beh -> not_wrong beh) ->
  (forall beh, program_behaves L2 beh -> program_behaves L1 beh).
Proof.
  intros. exploit backward_simulation_behavior_improves; eauto.
  intros [beh' [A B]]. destruct B.
  congruence.
  destruct H1 as [t [C D]]. subst. elim (H (Goes_wrong t)). auto.
Qed.

End BACKWARD_SIMULATIONS.

(** * Program behaviors for the "atomic" construction *)

Section ATOMIC.

Variable L: semantics.
Hypothesis Lwb: well_behaved_traces L.

Remark atomic_finish: forall s t, output_trace t -> Star (atomic L) (t, s) t (E0, s).
Proof.
  induction t; intros.
  apply star_refl.
  simpl in H; destruct H. eapply star_left; eauto.
  simpl. apply atomic_step_continue; auto. simpl; auto. auto.
Qed.

Lemma step_atomic_plus:
  forall s1 t s2, Step L s1 t s2 -> SPlus (atomic L) (E0,s1) t (E0,s2).
Proof.
  intros.  destruct t.
  apply plus_one. simpl; apply atomic_step_silent; auto.
  exploit Lwb; eauto. simpl; intros.
  eapply plus_left. eapply atomic_step_start; eauto. eapply atomic_finish; eauto. auto.
Qed.

Lemma star_atomic_star:
  forall s1 t s2, Star L s1 t s2 -> Star (atomic L) (E0,s1) t (E0,s2).
Proof.
  induction 1. apply star_refl. eapply star_trans with (s2 := (E0,s2)).
  apply plus_star. eapply step_atomic_plus; eauto. eauto. auto.
Qed.

Lemma atomic_forward_simulation: forward_simulation L (atomic L).
Proof.
  set (ms := fun (s: state L) (ts: state (atomic L)) => ts = (E0,s)).
  apply forward_simulation_plus with ms; intros.
  auto.
  exists (E0,s1); split. simpl; auto. red; auto.
  red in H. subst s2. simpl; auto.
  red in H0. subst s2. exists (E0,s1'); split.
  apply step_atomic_plus; auto. red; auto.
Qed.

Lemma atomic_star_star_gen:
  forall ts1 t ts2, Star (atomic L) ts1 t ts2 ->
  exists t', Star L (snd ts1) t' (snd ts2) /\ fst ts1 ** t' = t ** fst ts2.
Proof.
  induction 1.
  exists E0; split. apply star_refl. traceEq.
  destruct IHstar as [t' [A B]].
  simpl in H; inv H; simpl in *.
  exists t'; split. eapply star_left; eauto. auto.
  exists (ev :: t0 ** t'); split. eapply star_left; eauto. rewrite B; auto.
  exists t'; split. auto. rewrite B; auto.
Qed.

Lemma atomic_star_star:
  forall s1 t s2, Star (atomic L) (E0,s1) t (E0,s2) -> Star L s1 t s2.
Proof.
  intros. exploit atomic_star_star_gen; eauto. intros [t' [A B]].
  simpl in *. replace t with t'. auto. subst; traceEq.
Qed.

Lemma atomic_forever_silent_forever_silent:
  forall s, Forever_silent (atomic L) s -> Forever_silent L (snd s).
Proof.
  cofix COINDHYP; intros. inv H. inv H0.
  apply forever_silent_intro with (snd (E0, s')). auto. apply COINDHYP; auto.
Qed.

Remark star_atomic_output_trace:
  forall s t t' s',
  Star (atomic L) (E0, s) t (t', s') -> output_trace t'.
Proof.
  assert (forall ts1 t ts2, Star (atomic L) ts1 t ts2 ->
          output_trace (fst ts1) -> output_trace (fst ts2)).
  induction 1; intros. auto. inv H; simpl in *.
  apply IHstar. auto.
  apply IHstar. exploit Lwb; eauto.
  destruct H2. apply IHstar. auto.
  intros. change t' with (fst (t',s')). eapply H; eauto. simpl; auto.
Qed.

Lemma atomic_forever_reactive_forever_reactive:
  forall s T, Forever_reactive (atomic L) (E0,s) T -> Forever_reactive L s T.
Proof.
  assert (forall t s T, Forever_reactive (atomic L) (t,s) T ->
          exists T', Forever_reactive (atomic L) (E0,s) T' /\ T = t *** T').
  induction t; intros. exists T; auto.
  inv H. inv H0. congruence. simpl in H; inv H.
  destruct (IHt s (t2***T0)) as [T' [A B]]. eapply star_forever_reactive; eauto.
  exists T'; split; auto. simpl. congruence.

  cofix COINDHYP; intros. inv H0. destruct s2 as [t2 s2].
  destruct (H _ _ _ H3) as [T' [A B]].
  assert (Star (atomic L) (E0, s) (t**t2) (E0, s2)).
    eapply star_trans. eauto. apply atomic_finish. eapply star_atomic_output_trace; eauto. auto.
  replace (t *** T0) with ((t ** t2) *** T'). apply forever_reactive_intro with s2.
  apply atomic_star_star; auto. destruct t; simpl in *; unfold E0 in *; congruence.
  apply COINDHYP. auto.
  subst T0; traceEq.
Qed.

Theorem atomic_behaviors:
  forall beh, program_behaves L beh <-> program_behaves (atomic L) beh.
Proof.
  intros; split; intros.
  (* L -> atomic L *)
  exploit forward_simulation_behavior_improves. eapply atomic_forward_simulation. eauto.
  intros [beh2 [A B]]. red in B. destruct B as [EQ | [t [C D]]].
  congruence.
  subst beh. inv H. inv H1.
  apply program_runs with (E0,s). simpl; auto.
  apply state_goes_wrong with (E0,s'). apply star_atomic_star; auto.
  red; intros; red; intros. inv H. eelim H3; eauto. eelim H3; eauto.
  intros; red; intros. simpl in H. destruct H. eelim H4; eauto.
  apply program_goes_initially_wrong.
  intros; red; intros. simpl in H; destruct H. eelim H1; eauto.
  (* atomic L -> L *)
  inv H.
  (* initial state defined *)
  destruct s as [t s]. simpl in H0. destruct H0; subst t.
  apply program_runs with s; auto.
  inv H1.
  (* termination *)
  destruct s' as [t' s']. simpl in H2; destruct H2; subst t'.
  econstructor. eapply atomic_star_star; eauto. auto.
  (* silent divergence *)
  destruct s' as [t' s'].
  assert (t' = E0). inv H2. inv H1; auto. subst t'.
  econstructor. eapply atomic_star_star; eauto.
  change s' with (snd (E0,s')). apply atomic_forever_silent_forever_silent. auto.
  (* reactive divergence *)
  econstructor. apply atomic_forever_reactive_forever_reactive. auto.
  (* going wrong *)
  destruct s' as [t' s'].
  assert (t' = E0).
    destruct t'; auto. eelim H2. simpl. apply atomic_step_continue.
    eapply star_atomic_output_trace; eauto.
  subst t'. econstructor. apply atomic_star_star; eauto.
  red; intros; red; intros. destruct t0.
  elim (H2 E0 (E0,s'0)). constructor; auto.
  elim (H2 (e::nil) (t0,s'0)). constructor; auto.
  intros; red; intros. elim (H3 r). simpl; auto.
  (* initial state undefined *)
  apply program_goes_initially_wrong.
  intros; red; intros. elim (H0 (E0,s)); simpl; auto.
Qed.

End ATOMIC.

(** * Additional results about infinite reduction sequences *)

(** We now show that any infinite sequence of reductions is either of
  the "reactive" kind or of the "silent" kind (after a finite number
  of non-silent transitions).  The proof necessitates the axiom of
  excluded middle.  This result is used below to relate
  the coinductive big-step semantics for divergence with the
  small-step notions of divergence. *)

Unset Implicit Arguments.

Section INF_SEQ_DECOMP.

Variable genv: Type.
Variable state: Type.
Variable step: genv -> state -> trace -> state -> Prop.

Variable ge: genv.

Inductive tstate: Type :=
  ST: forall (s: state) (T: traceinf), forever step ge s T -> tstate.

Definition state_of_tstate (S: tstate): state :=
  match S with ST s T F => s end.
Definition traceinf_of_tstate (S: tstate) : traceinf :=
  match S with ST s T F => T end.

Inductive tstep: trace -> tstate -> tstate -> Prop :=
  | tstep_intro: forall s1 t T s2 S F,
      tstep t (ST s1 (t *** T) (@forever_intro genv state step ge s1 t s2 T S F))
              (ST s2 T F).

Inductive tsteps: tstate -> tstate -> Prop :=
  | tsteps_refl: forall S, tsteps S S
  | tsteps_left: forall t S1 S2 S3, tstep t S1 S2 -> tsteps S2 S3 -> tsteps S1 S3.

Remark tsteps_trans:
  forall S1 S2, tsteps S1 S2 -> forall S3, tsteps S2 S3 -> tsteps S1 S3.
Proof.
  induction 1; intros. auto. econstructor; eauto.
Qed.

Let treactive (S: tstate) : Prop :=
  forall S1,
  tsteps S S1 ->
  exists S2, exists S3, exists t, tsteps S1 S2 /\ tstep t S2 S3 /\ t <> E0.

Let tsilent (S: tstate) : Prop :=
  forall S1 t S2, tsteps S S1 -> tstep t S1 S2 -> t = E0.

Lemma treactive_or_tsilent:
  forall S, treactive S \/ (exists S', tsteps S S' /\ tsilent S').
Proof.
  intros. destruct (classic (exists S', tsteps S S' /\ tsilent S')).
  auto.
  left. red; intros.
  generalize (not_ex_all_not _ _ H S1). intros.
  destruct (not_and_or _ _ H1). contradiction.
  unfold tsilent in H2.
  generalize (not_all_ex_not _ _ H2). intros [S2 A].
  generalize (not_all_ex_not _ _ A). intros [t B].
  generalize (not_all_ex_not _ _ B). intros [S3 C].
  generalize (imply_to_and _ _ C). intros [D F].
  generalize (imply_to_and _ _ F). intros [G J].
  exists S2; exists S3; exists t. auto.
Qed.

Lemma tsteps_star:
  forall S1 S2, tsteps S1 S2 ->
  exists t, star step ge (state_of_tstate S1) t (state_of_tstate S2)
         /\ traceinf_of_tstate S1 = t *** traceinf_of_tstate S2.
Proof.
  induction 1.
  exists E0; split. apply star_refl. auto.
  inv H. destruct IHtsteps as [t' [A B]].
  exists (t ** t'); split.
  simpl; eapply star_left; eauto.
  simpl in *. subst T. traceEq.
Qed.

Lemma tsilent_forever_silent:
  forall S,
  tsilent S -> forever_silent step ge (state_of_tstate S).
Proof.
  cofix COINDHYP; intro S. case S. intros until f. simpl. case f. intros.
  assert (tstep t (ST s1 (t *** T0) (forever_intro s1 t s0 f0))
                  (ST s2 T0 f0)).
    constructor.
  assert (t = E0).
    red in H. eapply H; eauto. apply tsteps_refl.
  apply forever_silent_intro with (state_of_tstate (ST s2 T0 f0)).
  rewrite <- H1. assumption.
  apply COINDHYP.
  red; intros. eapply H. eapply tsteps_left; eauto. eauto.
Qed.

Lemma treactive_forever_reactive:
  forall S,
  treactive S -> forever_reactive step ge (state_of_tstate S) (traceinf_of_tstate S).
Proof.
  cofix COINDHYP; intros.
  destruct (H S) as [S1 [S2 [t [A [B C]]]]]. apply tsteps_refl.
  destruct (tsteps_star _ _ A) as [t' [P Q]].
  inv B. simpl in *. rewrite Q. rewrite <- Eappinf_assoc.
  apply forever_reactive_intro with s2.
  eapply star_right; eauto.
  red; intros. destruct (Eapp_E0_inv _ _ H0). contradiction.
  change (forever_reactive step ge (state_of_tstate (ST s2 T F)) (traceinf_of_tstate (ST s2 T F))).
  apply COINDHYP.
  red; intros. apply H.
  eapply tsteps_trans. eauto.
  eapply tsteps_left. constructor. eauto.
Qed.

Theorem forever_silent_or_reactive:
  forall s T,
  forever step ge s T ->
  forever_reactive step ge s T \/
  exists t, exists s', exists T',
  star step ge s t s' /\ forever_silent step ge s' /\ T = t *** T'.
Proof.
  intros.
  destruct (treactive_or_tsilent (ST s T H)).
  left.
  change (forever_reactive step ge (state_of_tstate (ST s T H)) (traceinf_of_tstate (ST s T H))).
  apply treactive_forever_reactive. auto.
  destruct H0 as [S' [A B]].
  exploit tsteps_star; eauto. intros [t [C D]]. simpl in *.
  right. exists t; exists (state_of_tstate S'); exists (traceinf_of_tstate S').
  split. auto.
  split. apply tsilent_forever_silent. auto.
  auto.
Qed.

End INF_SEQ_DECOMP.

Set Implicit Arguments.

(** * Big-step semantics and program behaviors *)

Section BIGSTEP_BEHAVIORS.

Variable B: bigstep_semantics.
Variable L: semantics.
Hypothesis sound: bigstep_sound B L.

Lemma behavior_bigstep_terminates:
  forall t r,
  bigstep_terminates B t r -> program_behaves L (Terminates t r).
Proof.
  intros. exploit (bigstep_terminates_sound sound); eauto.
  intros [s1 [s2 [P [Q R]]]].
  econstructor; eauto. econstructor; eauto.
Qed.

Lemma behavior_bigstep_diverges:
  forall T,
  bigstep_diverges B T ->
  program_behaves L (Reacts T)
  \/ exists t, program_behaves L (Diverges t) /\ traceinf_prefix t T.
Proof.
  intros. exploit (bigstep_diverges_sound sound); eauto. intros [s1 [P Q]].
  exploit forever_silent_or_reactive; eauto. intros [X | [t [s' [T' [X [Y Z]]]]]].
  left. econstructor; eauto. constructor; auto.
  right. exists t; split. econstructor; eauto. econstructor; eauto. exists T'; auto.
Qed.

End BIGSTEP_BEHAVIORS.