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

Require Import Reals.
Require Export pi_ineq.

(* Some usefull constants *)
Definition g : R := (322 / 10)%R.
Definition ConflictRange : R := 200%R.
Definition MinSpeed : R := 201%R.
Definition MaxSpeed : R := 880%R.
Definition MaxBank : R := (61 / 100)%R.

(**********)
Record TypeSpeed : Type := mkTypeSpeed
  {v :> R; v_cond1 : (MinSpeed <= v)%R; v_cond2 : (v <= MaxSpeed)%R}.

Definition tan_lb_MaxBank : R := (6 / 10)%R.
Definition tan_ub_MaxBank : R := (7 / 10)%R.

(**********)
Lemma tanBank_def :
 forall x : R, (- MaxBank <= x)%R -> (x <= MaxBank)%R -> cos x <> 0%R.
intros; cut (MaxBank < PI / 2)%R.
intro H1; generalize (Ropp_lt_gt_contravar MaxBank (PI / 2) H1); intro H2;
 generalize (Rle_lt_trans x MaxBank (PI / 2) H0 H1);
 intro H3; generalize (Rlt_le_trans (- (PI / 2)) (- MaxBank) x H2 H);
 intro H4; generalize (cos_gt_0 x H4 H3); intro H5;
 red in |- *; intro H6; rewrite H6 in H5; elim (Rlt_irrefl 0 H5).
apply Rlt_trans with (PI_lb / 2)%R.
apply Rlt_trans with 1%R.
unfold MaxBank in |- *; unfold Rdiv in |- *; apply Rmult_lt_reg_l with 100%R.
prove_sup.
rewrite Rmult_1_r; rewrite Rmult_comm; rewrite Rmult_assoc;
 rewrite <- Rinv_l_sym.
prove_sup.
discrR.
unfold PI_lb in |- *; apply Rmult_lt_reg_l with 2%R.
prove_sup.
rewrite Rmult_1_r; unfold Rdiv in |- *; rewrite Rmult_comm;
 rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
prove_sup.
discrR.
unfold Rdiv in |- *; apply Rmult_lt_reg_l with 2%R.
prove_sup.
do 2 rewrite (Rmult_comm 2); do 2 rewrite Rmult_assoc; rewrite <- Rinv_l_sym.
do 2 rewrite Rmult_1_r; elim PI_approx; intros; assumption.
discrR.
Qed.

(* Verifiable in MuPAD*)
Axiom tan_MaxBank_approx : (tan_lb_MaxBank < tan MaxBank < tan_ub_MaxBank)%R.

Lemma tan_MaxBank_ub : (tan MaxBank < tan_ub_MaxBank)%R.
generalize tan_MaxBank_approx; intro H; elim H; intros H0 H1; assumption.
Qed.

Lemma tan_MaxBank_lb : (tan_lb_MaxBank < tan MaxBank)%R.
generalize tan_MaxBank_approx; intro H; elim H; intros H0 H1; assumption.
Qed.

(**********)
Lemma tan_MaxBank_pos : (0 < tan MaxBank)%R.
apply Rlt_trans with tan_lb_MaxBank.
unfold tan_lb_MaxBank in |- *; unfold Rdiv in |- *;
 apply Rmult_lt_reg_l with 10%R.
prove_sup.
rewrite Rmult_0_r; rewrite <- Rmult_comm; repeat rewrite Rmult_assoc;
 rewrite <- Rinv_l_sym.
prove_sup.
discrR.
apply tan_MaxBank_lb.
Qed.


(* GENERIC *)

Require Export MinBFTg.
Require Export ComponentSM6.

Section MinBFTsim1.

  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         }.

  Context { ti : TrustedInfo }.

  Lemma wf_procs_MinBFTlocalSysP :
    forall r subs,
      ~In MAINname (get_names subs)
      -> lower_head 1 subs = true
      -> wf_procs subs
      -> wf_procs (MinBFTlocalSysP r subs).
  Proof.
    introv ni.
    unfold wf_procs, no_dup_subs; simpl; allrw andb_true.
    autorewrite with comp.
    dest_cases w; dands; tcsp.
  Qed.
  Hint Resolve wf_procs_MinBFTlocalSysP : minbft.

  Lemma is_proc_n_proc_MAIN_comp :
    forall r, is_proc_n_proc (MAIN_comp r).
  Proof.
    introv; eexists; introv; try reflexivity.
  Qed.
  Hint Resolve is_proc_n_proc_MAIN_comp : minbft.

  Lemma are_procs_n_procs_MinBFTlocalSysP :
    forall r subs,
      are_procs_n_procs subs
      -> are_procs_n_procs (MinBFTlocalSysP r subs).
  Proof.
    introv aps i; simpl in *; repndors; subst; tcsp; simpl in *; tcsp; eauto 3 with minbft comp.
    apply are_procs_n_procs_incr_n_procs in i; auto.
  Qed.
  Hint Resolve are_procs_n_procs_MinBFTlocalSysP : minbft.

  Lemma similar_sms_at_minbft_replica :
    forall r (p : n_proc 2 _),
      similar_sms p (MAIN_comp r)
      -> exists s, p = MinBFT_replicaSM_new r s.
  Proof.
    introv sim; simpl in *.
    destruct p; simpl in *; tcsp.
    unfold similar_sms_at in sim.
    destruct a as [upd st]; simpl in *; subst; simpl in *.
    exists st; auto.
  Qed.

  Lemma similar_procs_MAIN :
    forall r p,
      similar_procs (MkPProc MAINname (MAIN_comp r)) p
      -> exists s, p = MkPProc MAINname (MinBFT_replicaSM_new r s).
  Proof.
    introv sim.
    inversion sim as [? ? ? ? sims]; clear sim; subst.
    match goal with
    | [ H : context[p1] |- _ ] => rename H into h1
    end.
    match goal with
    | [ H : context[p2] |- _ ] => rename H into h2
    end.
    apply Eqdep.EqdepTheory.inj_pair2 in h1; subst; eauto 3 with comp.
    apply Eqdep.EqdepTheory.inj_pair2 in h1; subst; eauto 3 with comp.
    apply Eqdep.EqdepTheory.inj_pair2 in h2; subst; eauto 3 with comp.
    apply similar_sms_sym in sims.
    apply similar_sms_at_minbft_replica in sims; exrepnd; subst; eauto.
  Qed.

  Lemma similar_subs_MinBFTlocalSysP :
    forall r subs ls,
      similar_subs (MinBFTlocalSysP r subs) ls
      -> exists (s : MAIN_state) (subs' : n_procs _),
        ls = MinBFTlocalSys_newP r s subs'
        /\ similar_subs subs subs'.
  Proof.
    introv sim.
    inversion sim; subst; simpl in *.
    apply similar_procs_MAIN in simp; exrepnd; subst; simpl in *.
    apply similar_subs_incr_n_procs_left_implies in sims; exrepnd; subst.
    exists s j; dands; tcsp.
  Qed.

  (* MOVE to MinBFTsubs *)
  Lemma M_run_ls_before_event_ls_is_minbftP :
    forall {eo   : EventOrdering}
           (e    : Event)
           (r    : Rep)
           (ls   : LocalSystem 2 0)
           (subs : n_procs _),
      ~In MAINname (get_names subs)
      -> lower_head 1 subs = true
      -> wf_procs subs
      -> are_procs_n_procs subs
      -> M_run_ls_before_event (MinBFTlocalSysP r subs) e = Some ls
      ->
      exists (s : MAIN_state) (subs' : n_procs _),
        ls = MinBFTlocalSys_newP r s subs'
        /\ similar_subs subs subs'.
  Proof.
    introv ni low wf aps run.
    applydup M_run_ls_before_event_preserves_subs in run; eauto 3 with minbft.
    repnd.
    apply similar_subs_MinBFTlocalSysP in run3; exrepnd; subst.
    exists s subs'; dands; auto.
  Qed.

End MinBFTsim1.

Hint Resolve wf_procs_MinBFTlocalSysP : minbft.
Hint Resolve is_proc_n_proc_MAIN_comp : minbft.
Hint Resolve are_procs_n_procs_MinBFTlocalSysP : minbft.


Require Import Relations.
Require Import EquivDec.
Require Import Equality.
Require Import List.
Require Import Bool.
Require Import Lia.
Require Import NArith.
Require Import PArith.
Require Import ZArith.
Require Import FMapPositive.
Require Import FSetPositive.
Require Import EquivDec.
From sflib Require Import sflib.

Require Import PromisingArch.lib.Basic.
Require Import PromisingArch.lib.Order.
Require Import PromisingArch.lib.Time.
Require Import PromisingArch.lib.Lang.
Require Import PromisingArch.promising.Promising.

Set Implicit Arguments.

Lemma rtc_state_step_state_exec
      m1 m2
      (WF: Machine.wf m1)
      (STEP: rtc (Machine.step ExecUnit.state_step) m1 m2):
  Machine.state_exec m1 m2.
Proof.
  revert WF. induction STEP.
  { econs; ss. ii. destruct (IdMap.find id (Machine.tpool x)); ss. econs. refl. }
  i. exploit Machine.step_state_step_wf; eauto. i.
  exploit IHSTEP; eauto. intro x0. inv x0.
  destruct x as [tpool1 mem1].
  destruct y as [tpool2 mem2].
  inv H. inversion STEP0. inv STEP1. ss. subst. econs; ss.
  ii. specialize (TPOOL id). revert TPOOL.
  rewrite IdMap.add_spec. condtac; ss. i.
  inversion e0. inv TPOOL. rewrite FIND, <- H2. econs.
  econs; eauto.
Qed.

Lemma state_exec_rtc_state_step
      m1 m2
      (STEP: Machine.state_exec m1 m2):
  exists m2',
    <<EXEC: rtc (Machine.step ExecUnit.state_step) m1 m2'>> /\
    <<EQUIV: Machine.equiv m2 m2'>>.
Proof.
  inv STEP.
  assert (IN: forall tid sl1
                (FIND1: IdMap.find tid m1.(Machine.tpool) = Some sl1),
             exists sl2,
               IdMap.find tid m2.(Machine.tpool) = Some sl2 /\
               rtc (ExecUnit.state_step tid)
                   (ExecUnit.mk (fst sl1) (snd sl1) m1.(Machine.mem))
                   (ExecUnit.mk (fst sl2) (snd sl2) m1.(Machine.mem))).
  { i. specialize (TPOOL tid). rewrite FIND1 in TPOOL. inv TPOOL. esplits; ss. }
  assert (OUT: forall tid
                 (FIND1: IdMap.find tid m1.(Machine.tpool) = None),
             IdMap.find tid m1.(Machine.tpool) = IdMap.find tid m2.(Machine.tpool)).
  { i. specialize (TPOOL tid). rewrite FIND1 in TPOOL. inv TPOOL. ss. }
  assert (P: forall tid sl1
               (FIND1: IdMap.find tid m1.(Machine.tpool) = Some sl1),
             IdMap.find tid m1.(Machine.tpool) = Some sl1).
  { ss. }
  clear TPOOL.
  setoid_rewrite IdMap.elements_spec in IN at 1.
  setoid_rewrite IdMap.elements_spec in OUT at 1.
  setoid_rewrite IdMap.elements_spec in P at 1.
  generalize (IdMap.elements_3w m1.(Machine.tpool)). intro NODUP. revert NODUP.
  revert IN OUT P. generalize (IdMap.elements (m1.(Machine.tpool))). intro ps.
  revert m1 MEM. induction ps; ss.
  { i. esplits; eauto. econs; ss. ii. rewrite OUT; ss. }

  i. destruct a. inv NODUP.
  exploit (IN k).
  { destruct (equiv_dec k k); ss. congr. }
  exploit (P k).
  { destruct (equiv_dec k k); ss. congr. }
  i. des. destruct p. ss.

  cut (exists m2', rtc (Machine.step ExecUnit.state_step)
                 (Machine.mk (IdMap.add k (fst sl2, snd sl2) m1.(Machine.tpool)) m1.(Machine.mem))
                 m2' /\
             Machine.equiv m2 m2').
  { i. des. esplits; [|by eauto]. etrans; [|by eauto].
    eapply Machine.rtc_eu_step_step; [eauto|refl|eauto].
  }
  assert (TID: forall tid sl (FIND: SetoidList.findA (fun id' : IdMap.key => if equiv_dec tid id' then true else false) ps = Some sl), tid <> k).
  { ii. subst. apply H1. revert FIND. clear. induction ps; ss.
    destruct a. destruct (equiv_dec k k0); ss.
    - inv e. i. inv FIND. left. ss.
    - i. right. apply IHps. ss.
  }
  eapply IHps; ss.
  - i. eapply IN. destruct (equiv_dec tid k); ss.
    inv e. exfalso. eapply TID; eauto.
  - i. rewrite IdMap.add_spec. condtac.
    + inversion e. subst. rewrite x1. destruct sl2. ss.
    + eapply OUT. destruct (equiv_dec tid k); ss.
  - i. rewrite IdMap.add_spec. condtac.
    + inversion e. subst. exfalso. eapply TID; eauto.
    + eapply P. destruct (equiv_dec tid k); ss.
Qed.


(** Sharpened ADT for (ab)* *)
Require Import Fiat.Parsers.Grammars.ABStar.
Require Import Fiat.Parsers.Refinement.Tactics.
Require Import Fiat.Parsers.Refinement.SharpenedABStar.

Definition parser : ParserInterface.Parser ab_star_grammar String.string_stringlike.
Proof.
  let b := make_Parser (@ComputationalSplitter _ String.string_stringlike _ _) in
  exact b.
Defined.

Definition ab_star_parser_informative_opaque (str : Coq.Strings.String.string)
  : option (parse_of_item ab_star_grammar str (NonTerminal (Start_symbol ab_star_grammar))).
Proof.
  Time make_parser_informative_opaque (@ComputationalSplitter _ String.string_stringlike _ _). (* 0.82 s *)
Defined.

Goal forall b, ab_star_parser_informative_opaque "" = b.
Proof.
  intro.
  let LHS := match goal with |- ?LHS = _ => LHS end in
  let LHS := (eval hnf in LHS) in
  change (LHS = b).
Abort.

Definition ab_star_parser_informative (str : Coq.Strings.String.string)
  : option (@simple_parse_of_item Ascii.ascii).
Proof.
  Time make_parser_informative (@ComputationalSplitter _ String.string_stringlike _ _). (* 0.124 s *)
Defined.

Goal exists s, ab_star_parser_informative "" = Some s.
Proof.
  eexists.
  compute.
  reflexivity.
Qed.


Require Import ModelProperties.
Require Import AuxiliaryLemmas.

Section chobjscIsSecure.

Lemma ChobjscPSS :
 forall (s t : SFSstate) (u : SUBJECT),
 FuncPre6 s -> SecureState s -> TransFunc u s Chobjsc t -> SecureState t.
intros s t Sub FP6 SS TF; inversion TF.
inversion H.
unfold SecureState in |- *.
BreakSS.
split.
auto.

unfold MACSecureState in |- *; simpl in |- *; intros.
elim (OBJeq_dec o o0).
intro.
rewrite <- a.
cut (fsecmat (secmat s) o = None).
intro.
rewrite H6.
elim (fOSC (objectSC s) o); elim (fOSC (chobjsc_SC s o sc) o);
 elim (fSSC (subjectSC s) u); contradiction || auto.

unfold fsecmat in |- *; auto.

intro.
replace (fOSC (chobjsc_SC s o sc) o0) with (fOSC (objectSC s) o0).
unfold MACSecureState in MAC; apply MAC.

auto.

Qed.

Lemma ChobjscPSP :
 forall (s t : SFSstate) (u : SUBJECT),
 FuncPre6 s -> StarProperty s -> TransFunc u s Chobjsc t -> StarProperty t.
intros s t Sub FP6 SP TF; inversion TF.
inversion H.
unfold StarProperty in |- *; simpl in |- *; intros.
elim (OBJeq_dec o o1); elim (OBJeq_dec o o2); intros EQ2 EQ1.
rewrite <- EQ1; rewrite <- EQ2.
replace (fsecmat (secmat s) o) with (None (A:=ReadersWriters)).
elim (fOSC (objectSC s) o); elim (fOSC (chobjsc_SC s o sc) o);
 contradiction || auto.

symmetry  in |- *; unfold fsecmat in |- *; auto.

auto.
rewrite <- EQ1.
replace (fsecmat (secmat s) o) with (None (A:=ReadersWriters)).
replace (fOSC (chobjsc_SC s o sc) o2) with (fOSC (objectSC s) o2).
elim (fsecmat (secmat s) o2); elim (fOSC (chobjsc_SC s o sc) o);
 elim (fOSC (objectSC s) o); elim (fOSC (objectSC s) o2);
 intros; contradiction || auto.

auto.

symmetry  in |- *; unfold fsecmat in |- *; auto.

rewrite <- EQ2.
replace (fsecmat (secmat s) o) with (None (A:=ReadersWriters)).
replace (fOSC (chobjsc_SC s o sc) o1) with (fOSC (objectSC s) o1).
elim (fsecmat (secmat s) o1); elim (fOSC (chobjsc_SC s o sc) o);
 elim (fOSC (objectSC s) o); elim (fOSC (objectSC s) o1);
 intros; contradiction || auto.

auto.

symmetry  in |- *; unfold fsecmat in |- *; auto.

replace (fOSC (chobjsc_SC s o sc) o2) with (fOSC (objectSC s) o2).
replace (fOSC (chobjsc_SC s o sc) o1) with (fOSC (objectSC s) o1).
unfold StarProperty in SP; apply SP.

auto.

auto.

Qed.

Lemma ChobjscPCP : forall s t : SFSstate, PreservesControlProp s Chobjsc t.
intros; unfold PreservesControlProp in |- *; intros Sub TF; inversion TF;
 unfold ControlProperty in |- *.
inversion H.
split.
intros.
split.
intro.
absurd
 (DACCtrlAttrHaveChanged s
    (mkSFS (groups s) (primaryGrp s) (subjectSC s)
       (AllGrp s) (RootGrp s) (SecAdmGrp s) (chobjsc_SC s o sc)
       (acl s) (secmat s) (files s) (directories s)) o0);
 auto.

auto.

intros.
absurd
 (MACSubCtrlAttrHaveChanged s
    (mkSFS (groups s) (primaryGrp s) (subjectSC s)
       (AllGrp s) (RootGrp s) (SecAdmGrp s) (chobjsc_SC s o sc)
       (acl s) (secmat s) (files s) (directories s)) u0);
 auto.

Qed.

End chobjscIsSecure.

Hint Resolve ChobjscPSS ChobjscPSP ChobjscPCP.


(**************************************************************************)
(*  This file is part of CertrBPF,                                        *)
(*  a formally verified rBPF verifier + interpreter + JIT in Coq.         *)
(*                                                                        *)
(*  Copyright (C) 2022 Inria                                              *)
(*                                                                        *)
(*  This program is free software; you can redistribute it and/or modify  *)
(*  it under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation; either version 2 of the License, or     *)
(*  (at your option) any later version.                                   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful,       *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU General Public License for more details.                          *)
(*                                                                        *)
(**************************************************************************)

From bpf.comm Require Import Regs BinrBPF State Monad.
From bpf.monadicmodel Require Import Opcode rBPFInterpreter.
From Coq Require Import List Lia ZArith.
From compcert Require Import Integers Values Clight Memory.
Import ListNotations.

From bpf.clightlogic Require Import Clightlogic CorrectRel CommonLemma CommonLemmaNat.

From bpf.clight Require Import interpreter.

From bpf.simulation Require Import MatchState InterpreterRel.

(**
Check get_opcode_ins.
get_opcode_ins
     : int64 -> M nat

*)

Section Get_opcode_ins.
  Context {S: special_blocks}.
  (** The program contains our function of interest [fn] *)
  Definition p : Clight.program := prog.

  (* [Args,Res] provides the mapping between the Coq and the C types *)
  (* Definition Args : list CompilableType := [stateCompilableType].*)
  Definition args : list Type := [(int64:Type)].
  Definition res : Type := (nat:Type).

  (* [f] is a Coq Monadic function with the right type *)
  Definition f : arrow_type args (M State.state res) := get_opcode_ins.

  (* [fn] is the Cligth function which has the same behaviour as [f] *)
  Definition fn: Clight.function := f_get_opcode_ins.

  (* [match_arg] relates the Coq arguments and the C arguments *)
  Definition match_arg_list : DList.t (fun x => x -> Inv _) args :=
    (dcons (fun x => StateLess _ (int64_correct x))
                (DList.DNil _)).

  (* [match_res] relates the Coq result and the C result *)
  Definition match_res : res -> Inv State.state := fun x  => StateLess _ (opcode_correct x).

  Instance correct_function_get_opcode_ins : forall a, correct_function _ p args res f fn ModNothing true match_state match_arg_list match_res a.
  Proof.
    correct_function_from_body args.
    correct_body.
    (** how to use correct_* *)
    unfold INV.
    unfold f.
    repeat intro.
    get_invariant _ins.

    unfold eval_inv, int64_correct in c0.
    subst.

    eexists. exists m, Events.E0.
    unfold match_res, opcode_correct, BinrBPF.get_opcode.

    unfold Int64.and.
    change (Int64.unsigned (Int64.repr 255)) with 255%Z.
    assert (Hc_le: (0 <= Z.land (Int64.unsigned c) 255 <= 255)%Z). {
      assert (Heq: (Int64.unsigned c) = Z.of_nat (Z.to_nat(Int64.unsigned c))). {
        rewrite Z2Nat.id.
        reflexivity.
        assert (Hrange: (0 <= Int64.unsigned c < Int64.modulus)%Z) by apply Int64.unsigned_range.
        lia.
      }
      rewrite Heq; clear.
      change 255%Z with (Z.of_nat (Z.to_nat 255%Z)) at 1 2.
      rewrite LemmaNat.land_land.
      split.
      lia.
      assert (H: ((Nat.land (Z.to_nat (Int64.unsigned c)) (Z.to_nat 255)) <= 255)%nat). {
        rewrite Nat.land_comm.
        rewrite LemmaNat.land_bound.
        lia.
      }
      lia.
    }
    rewrite Int64.unsigned_repr; [ | change Int64.max_unsigned with 18446744073709551615%Z; lia].

    rewrite Z2Nat.id; [| lia].

    split; unfold step2.
    -
      forward_star.
      simpl.
      rewrite Int.zero_ext_idem; [| lia].
      rewrite Int.zero_ext_and; [| lia].
      change (two_p 8 - 1)%Z with 255%Z.

      unfold Int64.and.
      change (Int64.unsigned (Int64.repr 255)) with 255%Z.
      rewrite Int64.unsigned_repr; [ | change Int64.max_unsigned with 18446744073709551615%Z; lia].

      unfold Int.and.
      rewrite Int.unsigned_repr; [| change Int.max_unsigned with 4294967295%Z; lia].
      change (Int.unsigned (Int.repr 255)) with 255%Z.
      rewrite <- Z.land_assoc.
      rewrite Z.land_diag.

      unfold step2; forward_star.
    - split.
      + unfold eval_inv.
        split; [reflexivity|].
        lia.
      + split.
        * constructor.
          simpl.
          rewrite Int.zero_ext_and; [| lia].
          change (two_p 8 - 1)%Z with 255%Z.

          unfold Int.and.
          rewrite Int.unsigned_repr; [| change Int.max_unsigned with 4294967295%Z; lia].
          change (Int.unsigned (Int.repr 255)) with 255%Z.
          rewrite <- Z.land_assoc.
          rewrite Z.land_diag.
          reflexivity.
        * split; [auto|].
          apply unmodifies_effect_refl.
  Qed.

End Get_opcode_ins.

Existing Instance correct_function_get_opcode_ins.


Require Import oeuf.Common oeuf.Monads.
Require Import oeuf.Metadata.
Require String.
Require Import oeuf.ListLemmas.
Require Import oeuf.StepLib.
Require Import oeuf.HigherValue.

Require Import Psatz.

Require oeuf.SelfClose.
Require oeuf.Switched1.

Module A := SelfClose.
Module B := Switched1.

Set Default Timeout 15.

Section compile.
Open Scope option_monad.

Definition compile : A.expr -> option B.expr :=
    let fix go e :=
        let fix go_list es :=
            match es with
            | [] => Some []
            | e :: es => @cons _ <$> go e <*> go_list es
            end in
        match e with
        | A.Value v => Some (B.Value v)
        | A.Arg => Some B.Arg
        | A.Self => Some B.Self
        | A.Deref e n => B.Deref <$> go e <*> Some n
        | A.Call f a => B.Call <$> go f <*> go a
        | A.MkConstr tag args => B.MkConstr tag <$> go_list args
        | A.Elim A.Self cases A.Arg =>
                go_list cases >>= fun cases' =>
                let cases'' := map (fun case =>
                    B.Call (B.Call case B.Self) B.Arg) cases' in
                Some (B.Elim B.Self cases'' B.Arg)
        | A.Elim _ _ _ => None
        | A.MkClose f free => B.MkClose f <$> go_list free
        | A.OpaqueOp op args => B.OpaqueOp op <$> go_list args
        end in go.

Definition compile_list : list A.expr -> option (list B.expr) :=
    let go := compile in
    let fix go_list es :=
        match es with
        | [] => Some []
        | e :: es => @cons _ <$> go e <*> go_list es
        end in go_list.

Definition compile_cu (cu : list A.expr * list metadata) :
        option (list B.expr * list metadata) :=
    let '(exprs, metas) := cu in
    compile_list exprs >>= fun exprs' =>
    Some (exprs', metas).

End compile.

Ltac refold_compile :=
    fold compile_list in *.

Inductive I_expr vself varg : A.expr -> B.expr -> Prop :=
| IValue : forall v, I_expr vself varg (A.Value v) (B.Value v)
| IArg : I_expr vself varg A.Arg B.Arg
| ISelf : I_expr vself varg A.Self B.Self
| IDeref : forall ae be n,
        I_expr vself varg ae be ->
        I_expr vself varg (A.Deref ae n) (B.Deref be n)
| ICall : forall af aa bf ba,
        I_expr vself varg af bf ->
        I_expr vself varg aa ba ->
        I_expr vself varg (A.Call af aa) (B.Call bf ba)
| IMkConstr : forall tag aargs bargs,
        Forall2 (I_expr vself varg) aargs bargs ->
        I_expr vself varg (A.MkConstr tag aargs) (B.MkConstr tag bargs)
| IElim : forall aloop acases atarget bloop bcases btarget,
        I_expr vself varg aloop bloop ->
        Forall2 (fun acase bcase => exists bcase0,
            I_expr vself varg acase bcase0 /\
            bcase = B.Call (B.Call bcase0 B.Self) B.Arg) acases bcases ->
        I_expr vself varg atarget btarget ->
        (aloop = A.Self \/ aloop = A.Value vself) ->
        (atarget = A.Arg \/ atarget = A.Value varg) ->
        I_expr vself varg (A.Elim aloop acases atarget) (B.Elim bloop bcases btarget)
| IMkClose : forall fname' aargs bargs,
        Forall2 (I_expr vself varg) aargs bargs ->
        I_expr vself varg (A.MkClose fname' aargs) (B.MkClose fname' bargs)
| IOpaqueOp : forall op aargs bargs,
        Forall2 (I_expr vself varg) aargs bargs ->
        I_expr vself varg (A.OpaqueOp op aargs) (B.OpaqueOp op bargs)

| ICallSelf : forall af bf,
        I_expr vself varg af bf ->
        I_expr vself varg (A.Call af (A.Value vself)) (B.Call bf B.Self)
| ICallArg : forall af bf,
        I_expr vself varg af bf ->
        I_expr vself varg (A.Call af (A.Value varg)) (B.Call bf B.Arg)
.

Inductive I (AE : A.env) (BE : B.env) : A.state -> B.state -> Prop :=
| IRun : forall a s ae ak be bk,
        I_expr s a ae be ->
        (forall v, I AE BE (ak v) (bk v)) ->
        I AE BE (A.Run ae a s ak) (B.Run be a s bk)

| IInElimLoop : forall a s ak bk,
        I AE BE (ak s) (bk s) ->
        I AE BE
            (A.Run A.Self a s ak)
            (B.Run B.Self a s bk)

| IInElimTarget : forall a s ak bk,
        I AE BE (ak a) (bk a) ->
        I AE BE
            (A.Run A.Arg a s ak)
            (B.Run B.Arg a s bk)

| IStop : forall v,
        I AE BE (A.Stop v) (B.Stop v).

Ltac i_ctor := intros; econstructor; simpl; eauto.
Ltac i_lem H := intros; eapply H; simpl; eauto.

Lemma compile_I_expr : forall a b,
    compile a = Some b ->
    forall vs va,
    I_expr vs va a b.
induction a using A.expr_rect_mut with
    (Pl := fun as_ => forall bs,
        compile_list as_ = Some bs ->
        forall vs va,
        Forall2 (I_expr vs va) as_ bs);
intros0 Hcomp; simpl in *; refold_compile; break_bind_option; inject_some; intros.
all: try solve [i_ctor].

do 2 (break_match; try discriminate).
break_bind_option. inject_some. simpl.
i_ctor.
specialize (IHa2 ?? *** vs va).
fwd i_lem Forall2_length.
eapply nth_error_Forall2. { rewrite map_length. auto. }
intros.
fwd i_lem map_nth_error' as HH. destruct HH as (bcase & ? & ?).
fwd i_lem Forall2_nth_error.
eexists. split; eauto.
Qed.

Lemma compile_list_I_expr : forall as_ bs,
    compile_list as_ = Some bs ->
    Forall2 (fun a b => forall vs va, I_expr vs va a b) as_ bs.
induction as_; destruct bs; intros0 Hcomp; simpl in *; refold_compile;
break_bind_option; inject_some.

- constructor.
- i_ctor. i_lem compile_I_expr.
- i_ctor. i_lem compile_I_expr.
Qed.

Ltac B_start HS :=
    match goal with
    | [ |- context [ ?pred ?E ?s _ ] ] =>
            lazymatch pred with
            | B.sstep => idtac
            | B.sstar => idtac
            | B.splus => idtac
            | _ => fail "unrecognized predicate:" pred
            end;
            let S_ := fresh "S" in
            let S0 := fresh "S" in
            set (S0 := s);
            change s with S0;
            assert (HS : B.sstar E S0 S0) by (eapply B.SStarNil)
    end.

Ltac B_step HS :=
    let S_ := fresh "S" in
    let S2 := fresh "S" in
    let HS' := fresh HS "'" in
    let go E s0 s1 Brel solver :=
        rename HS into HS';
        evar (S2 : B.state);
        assert (HS : Brel E s0 S2);
        [ solver; unfold S2
        | clear HS' ] in
    match type of HS with
    | B.sstar ?E ?s0 ?s1 => go E s0 s1 B.splus
            ltac:(eapply sstar_then_splus with (1 := HS');
                  eapply B.SPlusOne)
    | B.splus ?E ?s0 ?s1 => go E s0 s1 B.splus
            ltac:(eapply splus_snoc with (1 := HS'))
    end.

Ltac B_star HS :=
    let S_ := fresh "S" in
    let S2 := fresh "S" in
    let HS' := fresh HS "'" in
    let go E s0 s1 Brel solver :=
        rename HS into HS';
        evar (S2 : B.state);
        assert (HS : Brel E s0 S2);
        [ solver; unfold S2
        | clear HS' ] in
    match type of HS with
    | B.sstar ?E ?s0 ?s1 => go E s0 s1 B.sstar
            ltac:(eapply sstar_then_sstar with (1 := HS'))
    | B.splus ?E ?s0 ?s1 => go E s0 s1 B.splus
            ltac:(eapply splus_then_sstar with (1 := HS'))
    end.

Ltac B_plus HS :=
    let S_ := fresh "S" in
    let S2 := fresh "S" in
    let HS' := fresh HS "'" in
    let go E s0 s1 Brel solver :=
        rename HS into HS';
        evar (S2 : B.state);
        assert (HS : Brel E s0 S2);
        [ solver; unfold S2
        | clear HS' ] in
    match type of HS with
    | B.sstar ?E ?s0 ?s1 => go E s0 s1 B.splus
            ltac:(eapply sstar_then_splus with (1 := HS'))
    | B.splus ?E ?s0 ?s1 => go E s0 s1 B.splus
            ltac:(eapply splus_then_splus with (1 := HS'))
    end.

Lemma I_expr_value : forall vself varg a b,
    I_expr vself varg a b ->
    A.is_value a ->
    B.is_value b.
intros0 II Aval. invc Aval. invc II. constructor.
Qed.
Hint Resolve I_expr_value.

Lemma I_expr_value' : forall vself varg a b,
    I_expr vself varg a b ->
    B.is_value b ->
    A.is_value a.
intros0 II Bval. invc Bval. invc II. constructor.
Qed.
Hint Resolve I_expr_value'.

Lemma I_expr_not_value : forall vself varg a b,
    I_expr vself varg a b ->
    ~ A.is_value a ->
    ~ B.is_value b.
intros0 II Aval. contradict Aval. eauto using I_expr_value'.
Qed.
Hint Resolve I_expr_not_value.

Lemma I_expr_not_value' : forall vself varg a b,
    I_expr vself varg a b ->
    ~ B.is_value b ->
    ~ A.is_value a.
intros0 II Bval. contradict Bval. eauto using I_expr_value.
Qed.
Hint Resolve I_expr_not_value'.

Lemma I_expr_map_value : forall vself varg vs bes,
    Forall2 (I_expr vself varg) (map A.Value vs) bes ->
    bes = map B.Value vs.
induction vs; intros0 II; invc II.
- reflexivity.
- simpl. f_equal.
  + on >I_expr, invc. reflexivity.
  + apply IHvs. eauto.
Qed.

Theorem I_sim : forall AE BE a a' b,
    Forall2 (fun a b => forall vs va, I_expr vs va a b) AE BE ->
    I AE BE a b ->
    A.sstep AE a a' ->
    exists b',
        B.splus BE b b' /\
        I AE BE a' b'.
destruct a as [ae a s ak | v];
intros0 Henv II Astep; inv Astep.
all: invc II.
all: try on (I_expr _ _ _ be), invc.

- (* SArg *)
  eexists. split. eapply B.SPlusOne; i_lem B.SArg.
  auto.

- (* SArg - IInElimTarget *)
  eexists. split. eapply B.SPlusOne; i_lem B.SArg.
  auto.

- (* SSelf *)
  eexists. split. eapply B.SPlusOne; i_lem B.SSelf.
  auto.

- (* SSelf - IInElimLoop *)
  eexists. split. eapply B.SPlusOne; i_lem B.SSelf.
  auto.

- (* SDerefStep *)
  eexists. split. eapply B.SPlusOne; i_lem B.SDerefStep.
  i_ctor. i_ctor. i_ctor. i_ctor.

- (* SDerefinateConstr *)
  on (I_expr _ _ (A.Value _) _), invc.
  eexists. split. eapply B.SPlusOne; i_lem B.SDerefinateConstr.
  eauto.

- (* SDerefinateClose *)
  on (I_expr _ _ (A.Value _) _), invc.
  eexists. split. eapply B.SPlusOne; i_lem B.SDerefinateClose.
  eauto.

- (* SCloseStep *)
  destruct (Forall2_app_inv_l _ _ **) as (? & ? & ? & ? & ?).
  on (Forall2 _ (_ :: _) _), invc.
  rename x into b_vs. rename y into b_e. rename l' into b_es.

  eexists. split. eapply B.SPlusOne; i_lem B.SCloseStep.
  + list_magic_on (vs, (b_vs, tt)).
  + i_ctor. i_ctor. i_ctor.
    i_lem Forall2_app. i_ctor. i_ctor.

- (* SCloseDone *)
  fwd eapply I_expr_map_value; eauto. subst.
  eexists. split. eapply B.SPlusOne; i_lem B.SCloseDone.
  eauto.

- (* SConstrStep *)
  destruct (Forall2_app_inv_l _ _ **) as (? & ? & ? & ? & ?).
  on (Forall2 _ (_ :: _) _), invc.
  rename x into b_vs. rename y into b_e. rename l' into b_es.

  eexists. split. eapply B.SPlusOne; i_lem B.SConstrStep.
  + list_magic_on (vs, (b_vs, tt)).
  + i_ctor. i_ctor. i_ctor.
    i_lem Forall2_app. i_ctor. i_ctor.

- (* SConstrDone *)
  fwd eapply I_expr_map_value; eauto. subst.
  eexists. split. eapply B.SPlusOne; i_lem B.SConstrDone.
  eauto.

- (* SOpaqueOpStep *)
  destruct (Forall2_app_inv_l _ _ **) as (? & ? & ? & ? & ?).
  on (Forall2 _ (_ :: _) _), invc.
  rename x into b_vs. rename y into b_e. rename l' into b_es.

  eexists. split. eapply B.SPlusOne; i_lem B.SOpaqueOpStep.
  + list_magic_on (vs, (b_vs, tt)).
  + i_ctor. i_ctor. i_ctor.
    i_lem Forall2_app. i_ctor. i_ctor.

- (* SOpaqueOpDone *)
  fwd eapply I_expr_map_value; eauto. subst.
  eexists. split. eapply B.SPlusOne; i_lem B.SOpaqueOpDone.
  eauto.

- (* SCallL *)
  eexists. split. eapply B.SPlusOne; i_lem B.SCallL.
  i_ctor. i_ctor. i_ctor. i_ctor.

- (* SCallL - ICallSelf *)
  eexists. split. eapply B.SPlusOne; i_lem B.SCallL.
  i_ctor. i_ctor. i_lem ICallSelf. i_ctor.

- (* SCallL - ICallArg *)
  eexists. split. eapply B.SPlusOne; i_lem B.SCallL.
  i_ctor. i_ctor. i_lem ICallArg. i_ctor.

- (* SCallR *)
  eexists. split. eapply B.SPlusOne; i_lem B.SCallR.
  i_ctor. i_ctor. i_ctor. i_ctor.

- (* SCallR - ICallSelf *)
  on (~ A.is_value (A.Value _)), contradict. i_ctor.

- (* SCallR - ICallArg *)
  on (~ A.is_value (A.Value _)), contradict. i_ctor.

- (* SMakeCall *)
  on (I_expr _ _ (A.Value (Close _ _)) _), invc.
  on (I_expr _ _ (A.Value _) _), invc.
  fwd i_lem Forall2_nth_error_ex as HH. destruct HH as (bbody & ? & ?).

  eexists. split. eapply B.SPlusOne; i_lem B.SMakeCall.
  i_ctor.

- (* SMakeCall - ICallSelf *)
  on (I_expr _ _ (A.Value (Close _ _)) _), invc.
  fwd i_lem Forall2_nth_error_ex as HH. destruct HH as (bbody & ? & ?).

  B_start HS.
  B_step HS. { i_lem B.SCallR. i_ctor. inversion 1. }
  B_step HS. { i_lem B.SSelf. }
  B_step HS. { i_lem B.SMakeCall. }

  eexists. split. exact HS.
  i_ctor.

- (* SMakeCall - ICallArg *)
  on (I_expr _ _ (A.Value (Close _ _)) _), invc.
  fwd i_lem Forall2_nth_error_ex as HH. destruct HH as (bbody & ? & ?).

  B_start HS.
  B_step HS. { i_lem B.SCallR. i_ctor. inversion 1. }
  B_step HS. { i_lem B.SArg. }
  B_step HS. { i_lem B.SMakeCall. }

  eexists. split. exact HS.
  i_ctor.

- (* SElimStepLoop *)
  on (loop = _ \/ _), invc; cycle 1. { on (~ A.is_value _), contradict. i_ctor. }
  on (I_expr _ _ _ bloop), invc.
  eexists. split. eapply B.SPlusOne; i_lem B.SElimStepLoop.
    { inversion 1. }
  i_lem IInElimLoop. i_ctor. i_ctor. i_ctor.

- (* SElimStep *)
  on (target = _ \/ _), invc; cycle 1. { on (~ A.is_value _), contradict. i_ctor. }
  on (I_expr _ _ _ btarget), invc.
  eexists. split. eapply B.SPlusOne; i_lem B.SElimStep.
    { inversion 1. }
  i_lem IInElimTarget. i_ctor. i_ctor. i_ctor.

- (* SEliminate *)
  do 2 (on (_ \/ _), invc); try (discriminate || on >A.is_value, invc).
  on (A.Value _ = A.Value _), invc.
  on (I_expr _ _ _ bloop), invc.
  on (I_expr _ _ _ btarget), invc.

  fwd i_lem Forall2_nth_error_ex as HH.  destruct HH as (bcase & ? & ?).
    on _, fun H => destruct H as (bcase0 & ? & ?).

  eexists. split. eapply B.SPlusOne; i_lem B.SEliminate.
    { i_ctor. }
    { i_ctor. }
  subst bcase. i_ctor. i_lem ICallArg. i_lem ICallSelf.
Qed.

Theorem compile_cu_I_expr : forall A Ameta B Bmeta,
    compile_cu (A, Ameta) = Some (B, Bmeta) ->
    Forall2 (fun a b => forall vs va, I_expr vs va a b) A B.
intros. simpl in *. repeat (break_bind_option || break_match; try discriminate).
inject_some.
i_lem compile_list_I_expr.
Qed.

Theorem compile_cu_meta_eq : forall A Ameta B Bmeta,
    compile_cu (A, Ameta) = Some (B, Bmeta) ->
    Bmeta = Ameta.
intros. simpl in *. repeat (break_bind_option || break_match; try discriminate).
inject_some.
reflexivity.
Qed.

Require Import oeuf.Semantics.

Section Preservation.

    Variable aprog : A.prog_type.
    Variable bprog : B.prog_type.

    Hypothesis Hcomp : compile_cu aprog = Some bprog.

    Theorem fsim : Semantics.forward_simulation (A.semantics aprog) (B.semantics bprog).
    destruct aprog as [A Ameta], bprog as [B Bmeta].
    fwd eapply compile_cu_I_expr; eauto.
    fwd eapply compile_cu_meta_eq; eauto. subst Bmeta.

    eapply Semantics.forward_simulation_plus with
        (match_states := I A B)
        (match_values := @eq value).

    - simpl. intros0 Bcall Hf Ha. invc Bcall. unfold fst, snd in *.
    (*
      fwd eapply compile_cu_public_value with (v := Close fname free); eauto.
      fwd eapply compile_cu_public_value with (v := av2); eauto.
      on (public_value Ameta (Close _ _)), invc.
      fwd i_lem compile_cu_a_length.
      fwd eapply length_nth_error_Some with (xs := Ameta) (ys := A) as HH; eauto.
        destruct HH as [abody Habody].
      fwd i_lem env_ok_nth_error.
        { erewrite map_nth_error; [ | eauto ]. eauto. }
        break_and.
      *)
      fwd i_lem Forall2_nth_error_ex' as HH. destruct HH as (abody & ? & ?).

      eexists. split.
      + i_ctor. i_ctor.
      + i_ctor.

    - simpl. intros0 II Afinal. invc Afinal. invc II.

      eexists. split. 2: reflexivity.
      econstructor; eauto.

    - simpl. eauto.
    - simpl. intros. tauto.

    - intros0 Astep. intros0 II.
      eapply splus_semantics_sim, I_sim; eauto.

    Qed.

End Preservation.