Require Import ListAux.
Lemma customstk3consistent_push0 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((list_order  il_1 u_1 u_0)/\(list_member  il_1 u_1)) -> (list_member  il_1 u_0)).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push1 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((list_order  il_1 u_1 u_0)/\(list_member  il_1 u_1)) -> (list_member  il_0 u_0)).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push2 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_head  il_1 u_0))/\(list_order  il_1 u_1 u_0)/\(list_member  il_1 u_1)) -> (not (u_0 = i_0))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push3 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_head  il_1 u_0))/\(not (list_head  il_1 u_1))/\(list_order  il_1 u_0 u_1)/\(list_order  il_1 u_1 u_0)/\(list_member  il_1 u_1)) -> (not (u_1 = i_0))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push4 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_head  il_1 u_0))/\(not (list_head  il_1 u_1))/\(list_order  il_1 u_0 u_1)/\(list_order  il_1 u_1 u_0)/\(list_member  il_1 u_1)) -> (list_order  il_0 u_1 u_0)).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push5 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_head  il_1 u_0))/\(not (list_head  il_1 u_1))/\(list_head  il_0 u_1)/\(not (u_1 = u_0))/\(list_order  il_1 u_0 u_1)/\(list_order  il_1 u_1 u_0)/\(list_member  il_1 u_1)) -> (not (list_head  il_0 u_0))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push6 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_head  il_1 u_0))/\(list_head  il_0 u_0)/\(not (list_order  il_1 u_0 u_1))/\(list_order  il_1 u_1 u_0)/\(list_member  il_1 u_1)) -> (not (list_member  il_0 u_1))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push7 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_head  il_1 u_0))/\(u_1 = i_0)/\(not (list_head  il_0 i_0))/\(not (list_head  il_0 u_0))/\(not (list_order  il_1 u_0 u_1))/\(list_order  il_1 u_1 u_0)/\(list_member  il_1 u_1)) -> (not (i_0 = u_0))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push8 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_head  il_1 u_0))/\(u_1 = i_0)/\(not (list_head  il_0 i_0))/\(list_member  il_0 i_0)/\(not (list_head  il_0 u_0))/\(not (list_order  il_1 u_0 u_1))/\(list_order  il_1 u_1 u_0)/\(list_member  il_1 u_1)) -> (list_order  il_0 i_0 u_0)).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push9 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_head  il_1 u_0))/\(u_1 = i_0)/\(not (list_head  il_0 i_0))/\(not (list_member  il_0 i_0))/\(not (list_head  il_0 u_0))/\(not (list_order  il_1 u_0 u_1))/\(list_order  il_1 u_1 u_0)/\(list_member  il_1 u_1)) -> (not (list_order  il_0 i_0 u_0))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push10 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_order  il_1 u_1 u_0))/\(list_member  il_1 u_1)) -> (not (list_order  il_0 u_1 u_0))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push11 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((u_1 = i_0)/\(list_member  il_0 u_1)/\(not (list_order  il_1 u_1 u_0))/\(list_member  il_1 u_1)) -> (not (list_member  il_1 u_0))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push12 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((u_1 = i_0)/\(list_member  il_0 u_1)/\(not (list_order  il_1 u_1 u_0))/\(list_member  il_1 u_1)) -> (list_head  il_1 i_0)).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push13 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((u_1 = i_0)/\(list_member  il_0 u_1)/\(not (list_order  il_1 u_1 u_0))/\(list_member  il_1 u_1)) -> (not (list_head  il_0 u_0))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push14 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (u_1 = i_0))/\(list_member  il_0 u_1)/\(not (list_order  il_1 u_1 u_0))/\(list_member  il_1 u_1)) -> (not (list_head  il_1 u_1))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push15 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (u_1 = u_0))/\(list_head  il_0 u_1)/\(list_order  il_1 u_0 u_1)/\(not (u_1 = i_0))/\(list_member  il_0 u_1)/\(not (list_order  il_1 u_1 u_0))/\(list_member  il_1 u_1)) -> (not (list_member  il_0 u_0))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push16 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (u_1 = u_0))/\(u_0 = i_0)/\(not (list_head  il_0 i_0))/\(list_member  il_0 i_0)/\(not (list_head  il_0 u_1))/\(list_order  il_1 u_0 u_1)/\(not (u_1 = i_0))/\(list_member  il_0 u_1)/\(not (list_order  il_1 u_1 u_0))/\(list_member  il_1 u_1)) -> (list_order  il_0 i_0 u_1)).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push17 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (u_1 = u_0))/\(u_0 = i_0)/\(not (list_head  il_0 i_0))/\(not (list_member  il_0 i_0))/\(not (list_head  il_0 u_1))/\(list_order  il_1 u_0 u_1)/\(not (u_1 = i_0))/\(list_member  il_0 u_1)/\(not (list_order  il_1 u_1 u_0))/\(list_member  il_1 u_1)) -> (not (list_order  il_0 i_0 u_1))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push18 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_order  il_1 u_0 u_1))/\(not (u_1 = i_0))/\(list_member  il_0 u_1)/\(not (list_order  il_1 u_1 u_0))/\(list_member  il_1 u_1)) -> (not (u_0 = i_0))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push19 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_head  il_0 u_1))/\(not (list_order  il_1 u_0 u_1))/\(not (u_1 = i_0))/\(list_member  il_0 u_1)/\(not (list_order  il_1 u_1 u_0))/\(list_member  il_1 u_1)) -> (not (list_member  il_0 u_0))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push20 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_head  il_0 u_1))/\(not (list_order  il_1 u_0 u_1))/\(not (u_1 = i_0))/\(list_member  il_0 u_1)/\(not (list_order  il_1 u_1 u_0))/\(list_member  il_1 u_1)) -> (not (list_order  il_0 u_0 u_1))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push21 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_0 u_1))/\(not (list_order  il_1 u_1 u_0))/\(list_member  il_1 u_1)) -> (u_1 = i_0)).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push22 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_0 u_1))/\(not (list_order  il_1 u_1 u_0))/\(list_member  il_1 u_1)) -> (not (list_member  il_0 u_0))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push23 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_0 u_1))/\(not (list_order  il_1 u_1 u_0))/\(list_member  il_1 u_1)) -> (list_head  il_1 i_0)).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push24 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_0 u_1))/\(not (list_order  il_1 u_1 u_0))/\(list_member  il_1 u_1)) -> (not (list_head  il_0 i_0))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push25 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_1 u_1))) -> (not (list_order  il_0 u_1 u_0))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push26 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_1 u_1))) -> (not (list_head  il_1 u_1))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push27 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_1 u_1))) -> (not (list_order  il_0 u_0 u_1))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push28 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_1 u_1))) -> (not (list_member  il_0 u_1))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push29 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_1 u_1))) -> (not (list_order  il_1 u_1 u_0))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push30 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_1 u_1))) -> (not (u_1 = i_0))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push31 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (list_member  il_1 u_1))) -> (not (list_head  il_0 u_1))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push32 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_head  il_1 u_0))/\(list_member  il_0 u_0)/\(not (list_member  il_1 u_1))) -> (not (u_0 = i_0))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push33 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (u_1 = u_0))/\(not (list_head  il_1 u_0))/\(list_member  il_0 u_0)/\(not (list_member  il_1 u_1))) -> (list_member  il_1 u_0)).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push34 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (u_1 = u_0))/\(u_0 = i_0)/\(not (list_member  il_0 u_0))/\(not (list_member  il_1 u_1))) -> (list_member  il_1 i_0)).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push35 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (u_1 = u_0))/\(u_0 = i_0)/\(not (list_member  il_0 u_0))/\(not (list_member  il_1 u_1))) -> (list_head  il_1 i_0)).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push36 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (u_1 = u_0))/\(not (u_0 = i_0))/\(not (list_member  il_0 u_0))/\(not (list_member  il_1 u_1))) -> (not (list_member  il_1 u_0))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.

Lemma customstk3consistent_push37 (i_0:nat) (il_0:list nat) (il_1:list nat) (u_0:nat) (u_1:nat) : (push_spec  i_0 il_0 il_1) -> (((not (u_1 = u_0))/\(not (u_0 = i_0))/\(not (list_member  il_0 u_0))/\(not (list_member  il_1 u_1))) -> (not (list_head  il_1 u_0))).
Proof. solve_push; try (assert (u_0 = u_1); subst; eauto). Qed.


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

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

Lemma multi_one_u_triple k z ext Z_ : uniq(k, z, ext, Z_, r0) ->
  forall nk Z vz, (0 < nk)%nat -> size Z = nk -> u2Z vz + 4 * Z_of_nat nk < Zbeta 1 ->
  {{ fun s h => [z]_s = vz /\ u2Z [k]_s = Z_of_nat nk /\ (var_e z |--> Z) s h }}
    multi_one_u k z ext Z_
  {{ fun s h => [z]_s = vz /\ u2Z [k]_s = Z_of_nat nk /\
   (var_e z |--> one32 :: nseq (nk - 1) zero32) s h }}.
Proof.
move=> Hnodup=> nk Z vz nk0 Z_nk vz_fit.
rewrite /multi_one_u.
apply while.hoare_seq with (fun s h => ([z ]_ s) = vz /\
  u2Z ([k ]_ s) = Z_of_nat nk /\ (var_e z |--> nseq nk zero32) s h).
move/multi_zero_u_triple : (Hnodup).
move/(_ nk Z vz Z_nk vz_fit) => Htmp.
by apply Htmp.
apply hoare_addiu with (fun s h => ([z ]_ s) = vz /\
  u2Z ([k ]_ s) = Z_of_nat nk /\ (var_e z |--> nseq nk zero32) s h /\ [ext]_s = one32).
rewrite /while.entails => s h.
case=> z_vz [k_nk Hmem].
rewrite /wp_addiu.
repeat Reg_upd.
repeat (split => //).
by Assert_upd.
by rewrite add0i sext_Z2u.
apply hoare_sw_back'.
move=> s h.
case => z_vz [k_nk [Hmem Hext]].
exists (int_e zero32).
destruct nk => //.
rewrite /= in Hmem.
move: Hmem.
apply assert_m.monotony => // h1.
  apply assert_m.mapsto_ext => //=.
  by rewrite sext_Z2u // addi0.
apply assert_m.currying => h2 Hh2.
repeat (split => //).
rewrite assert_m.conCE in Hh2.
rewrite /=.
move: Hh2.
apply assert_m.monotony => // h3.
  apply assert_m.mapsto_ext => //=.
  by rewrite sext_Z2u // addi0.
by rewrite subSS subn0.
Qed.


From iVM Require Export Operations Binary.
From iVM Require Import DSet.
Require iVM.OpCodes.
Import DSetNotations.

Unset Suggest Proof Using.

Set Implicit Arguments.

Notation toB8 := (toBits 8).
Notation toB16 := (toBits 16).
Notation toB32 := (toBits 32).
Notation toB64 := (toBits 64).

Open Scope Z.
Open Scope vector.

Coercion bytesToBits : Bytes >-> Bits.
Coercion bitsToN : Bits >-> N.

(** Now we have coercions [Bytes >-> Bits >-> N >-> Z]
    and also [nat >-> Z] and [option >-> bool >-> Prop]. *)

(* #[global] parameters! *)
Context
  (available': B64 -> bool)
  (allInputImages' : list (Image B8)).

Module concreteParameters <: MachineParameters.
  Definition Addr := B64.
  Instance H_eqdec : EqDec B64.
  Proof.
    typeclasses eauto.
  Qed.
  Definition available := available'.
  Definition offset := fun (z: Z) (a: B64) => toB64 (z + a).
  Instance offset_action : Z_action offset.
  Proof.
    unfold offset.
    split; intros.
    - cbn. apply toBits_ofN_bitsToN.
    - apply toBits_cong.
      repeat rewrite ofN_bitsToN.
      rewrite fromBits_toBits_cong.
      apply eq_cong.
      lia.
  Qed.
  Definition Cell := B8.

  Definition InputColor := B8.
  Definition allInputImages := allInputImages'.

  Definition OutputColor := (B64 * B64 * B64)%type.
  Definition Char := B32.
  Definition Byte := B8.
  Definition Sample := B16.
End concreteParameters.

Module ConcreteCore := Core concreteParameters.
Export ConcreteCore.

(* Why is this needed? *)
#[global] Opaque loadMany.
#[global] Opaque load.
#[global] Opaque popMany.

(* TODO: Is there a more elegant way to achieve this? *)
Definition cells_to_bytes {n} : Cells n -> Bytes n := id.
Coercion cells_to_bytes : Cells >-> Bytes.

Section machine_section.

  (** We leave these assumptions abstract in order improve proof search.
      In Concete.v we have shown that they hold in our standard model. *)

  Context {MP1: MachineParams1}.
  Context {MP2: MachineParams2}.

  Definition toBytes (n: nat) z := bitsToBytes (toBits (n * 8) z).

  Coercion to_list : vector >-> list.

  Definition pushZ (z: Z) : M unit :=
    pushMany (toBytes 8 z).

  Definition pop64 : M B64 :=
    let* bytes := popMany 8 in
    ret (bytes : B64).

  Definition storeZ (n: nat) (a: Z) (x: Z) : M unit :=
    storeMany (toB64 a) (toBytes n x).

  Import OpCodes.

  (* Without [noind] solving obligations seems to go on forever. *)
  Equations(noind) oneStep' (op: Z) : M unit :=
    oneStep' NOP := ret tt;

    oneStep' JUMP :=
      let* a := pop64 in
      put' PC a;

    oneStep' JZ_FWD :=
        let* o := next 1 in
        let* x := pop64 in
        (if (decide (x = 0 :> Z))
         then
           let* pc := get' PC in
           put' PC (offset o pc)
         else
           ret tt);

    oneStep' JZ_BACK :=
        let* o := next 1 in
        let* x := pop64 in
        (if (decide (x = 0 :> Z))
         then
           let* pc := get' PC in
           put' PC (offset (-(1 + o)) pc)
         else
           ret tt);

    oneStep' SET_SP :=
        let* a := pop64 in
        put' SP a;

    oneStep' GET_PC =>
        let* a := get' PC in
        pushZ a;

    oneStep' GET_SP :=
        let* a := get' SP in
        pushZ a;

    oneStep' PUSH0 :=
        pushZ 0;

    oneStep' PUSH1 :=
        let* x := next 1 in
        pushZ x;

    oneStep' PUSH2 :=
        let* x := next 2 in
        pushZ x;

    oneStep' PUSH4 :=
        let* x := next 4 in
        pushZ x;

    oneStep' PUSH8 :=
        let* x := next 8 in
        pushZ x;

    oneStep' LOAD1 :=
        let* a := pop64 in
        let* x := loadMany 1 a in
        pushZ x;

    oneStep' LOAD2 :=
        let* a := pop64 in
        let* x := loadMany 2 a in
        pushZ x;

    oneStep' LOAD4 :=
        let* a := pop64 in
        let* x := loadMany 4 a in
        pushZ x;

    oneStep' LOAD8 :=
        let* a := pop64 in
        let* x := loadMany 8 a in
        pushZ x;

    oneStep' STORE1 :=
        let* a := pop64 in
        let* x := pop64 in
        storeZ 1 a x;

    oneStep' STORE2 :=
        let* a := pop64 in
        let* x := pop64 in
        storeZ 2 a x;

    oneStep' STORE4 :=
        let* a := pop64 in
        let* x := pop64 in
        storeZ 4 a x;

    oneStep' STORE8 :=
        let* a := pop64 in
        let* x := pop64 in
        storeZ 8 a x;

    oneStep' ADD :=
        let* x := pop64 in
        let* y := pop64 in
        pushZ (x + y);

    oneStep' MULT :=
        let* x := pop64 in
        let* y := pop64 in
        pushZ (x * y);

    oneStep' DIV :=
        let* x := pop64 in
        let* y := pop64 in
        pushZ (if decide (x = 0 :> Z) then 0 else y / x);

    oneStep' REM :=
        let* x := pop64 in
        let* y := pop64 in
        pushZ (if decide (x = 0 :> Z) then 0 else y mod x);

    oneStep' LT :=
        let* x := pop64 in
        let* y := pop64 in
        pushZ (if decide (y < x) then -1 else 0);

    oneStep' AND :=
        let* x := pop64 in
        let* y := pop64 in
        pushZ (Vector.map2 andb x y : B64);

    oneStep' OR :=
        let* x := pop64 in
        let* y := pop64 in
        pushZ (Vector.map2 orb x y : B64);

    oneStep' NOT :=
        let* x := pop64 in
        pushZ (Vector.map negb x : B64);

    oneStep' XOR :=
        let* x := pop64 in
        let* y := pop64 in
        pushZ (Vector.map2 xorb x y : B64);

    oneStep' POW2 :=
        let* x := pop64 in
        pushZ (2 ^ x);

    oneStep' READ_FRAME :=
        let* i := pop64 in
        let* pair := readFrame i in
        pushZ (fst pair);;
        pushZ (snd pair);

    oneStep' READ_PIXEL :=
        let* y := pop64 in
        let* x := pop64 in
        let* c := readPixel x y in
        pushZ c;

    oneStep' NEW_FRAME :=
        let* r := pop64 in
        let* h := pop64 in
        let* w := pop64 in
        newFrame w h r;

    oneStep' SET_PIXEL :=
        let* b := pop64 in
        let* g := pop64 in
        let* r := pop64 in
        let* y := pop64 in
        let* x := pop64 in
        setPixel x y (r, g, b);

    oneStep' ADD_SAMPLE :=
        let* r := pop64 in
        let* l := pop64 in
        addSample (toB16 l) (toB16 r);

    oneStep' PUT_CHAR :=
        let* c := pop64 in
        putChar (toB32 c);

    oneStep' PUT_BYTE :=
        let* b := pop64 in
        putByte (toB8 b);

    oneStep' _ := err.

  Definition oneStep : M bool :=
    let* op := next 1 in
    match (op: Z) with
    | EXIT => ret false
    | _ => oneStep' op;; ret true
    end.

  (** ** Chaining steps *)

  Definition chain (u v : M bool) :=
    let* cont := u in
    if cont then v else ret false.

  Lemma true_chain (u: M bool) : chain (ret true) u = u.
  Proof.
    unfold chain. rewrite ret_bind. reflexivity.
  Qed.

  Lemma chain_true (u: M bool) : chain u (ret true) = u.
  Proof.
    unfold chain.
    rewrite <- bind_ret.
    apply bind_extensional.
    intros [|]; reflexivity.
  Qed.

  Lemma chain_assoc (u v w : M bool) : chain (chain u v) w = chain u (chain v w).
  Proof.
    unfold chain.
    smon_rewrite.
    f_equal.
    extensionality x.
    destruct x; [reflexivity|].
    rewrite ret_bind.
    reflexivity.
  Qed.

  (** In other words, this defines a monoid (up to functional extensionality). *)

  Lemma false_chain (u: M bool) : chain (ret false) u = ret false.
  Proof.
    unfold chain. rewrite ret_bind. reflexivity.
  Qed.

  Equations nSteps (n: nat) : M bool :=
    nSteps 0 := ret true;
    nSteps (S n) := chain oneStep (nSteps n).

  Lemma nSteps_action (m n: nat) : nSteps (m + n) = chain (nSteps m) (nSteps n).
  Proof.
    revert n. induction m; intros n; simpl Nat.add; simp nSteps.
    - rewrite true_chain. reflexivity.
    - rewrite chain_assoc, IHm. reflexivity.
  Qed.

  (** *** Extra properties *)

  Equations popN (n: nat) : M (vector B64 n) :=
    popN 0 := ret [];
    popN (S n) := let* h := pop64 in
                  let* r := popN n in
                  ret (h :: r).

  Proposition popN_spec n :
    popN n =
      let* u := popMany (n * 8) in
      ret (bytesToLongs u).
  Proof.
    induction n; simp popN.
    - simp popMany. smon_rewrite.
    - change (S n * 8)%nat with (S (S (S (S (S (S (S (S (n * 8)))))))))%nat.
      setoid_rewrite IHn.
      unfold pop64.
      simp popMany.
      smon_rewrite.
      setoid_rewrite bytesToLongs_equation_2'.
      reflexivity.
  Qed.

  (** Probably not safe to define as a global instance. *)
  Instance disjoint_independent' u v (H: u # v) : Independent (MEM' u) (MEM' v).
  Proof.
    unfold MEM'.
    apply
      composite_independent_r,
      separate_independent. (* TODO: Rename and move. *)
    exact H.
  Qed.

  (* TODO: Safe as global instance? *)
  #[global] Instance mem_point_sub {a u} (Ha: a ∈ u) :
    (MEM'' a | MEM' u).
  Proof.
    unfold MEM', MEM''.
    apply sublens_comp, pointLens_sublens.
    exact Ha.
  Qed.

  Lemma mem_put_get'' {a u} (Ha: a ∈ u) f :
    put' (MEM' u) f;;
    get' (MEM'' a) =
      put' (MEM' u) f;;
      ret (f a Ha).
  Proof.
    unfold MEM', MEM''.
    set (PL := pointLens _).
    set (RL := restrLens _).
    assert (PL|RL) as H;
    [ apply pointLens_sublens; exact Ha | ].
    setoid_rewrite <- (sublensFactor_spec H (fun _ _ => None)).
    setoid_rewrite <- compositeLens_associative.
    setoid_rewrite sub_put_get. f_equal.
    extensionality x. destruct x. f_equal.
    cbn. decided Ha. reflexivity.
  Qed.

  Proposition put_to_get
      {A} (LA: Lens State A)
      {X} (f g: A -> M X)
      (H: forall a,
        put' LA a;; f a =
        put' LA a;; g a) :
    let* a := get' LA in f a =
    let* a := get' LA in g a.
  Proof.
    smon_ext' LA a.
    setoid_rewrite lens_put_get.
    exact (H a).
  Qed.

End machine_section.


From trillium.fairness Require Export fairness.
From stdpp Require Import option.
From Paco Require Import pacotac.

(* TODO: See if we can generalise the notion of fair terminating traces *)
Definition mtrace_fairly_terminating {Mdl : FairModel} (mtr : mtrace Mdl) :=
  mtrace_valid mtr →
  (∀ ρ, fair_model_trace ρ mtr) →
  terminating_trace mtr.

Definition extrace_fairly_terminating {Λ} `{Countable (locale Λ)}
           (extr : extrace Λ) :=
  extrace_valid extr →
  (∀ tid, fair_ex tid extr) →
  terminating_trace extr.

Class FairTerminatingModel (Mdl: FairModel) := {
  ftm_leq: relation Mdl;
  ftm_order: PreOrder ftm_leq;
  ftm_wf: wf (strict ftm_leq);

  ftm_decreasing_role: Mdl -> fmrole Mdl;
  ftm_decr:
    ∀ (s: Mdl), (∃ ρ' s', fmtrans _ s ρ' s') ->
                ftm_decreasing_role s ∈ live_roles _ s ∧
                ∀ s', (fmtrans _ s (Some (ftm_decreasing_role s)) s' ->
                       (strict ftm_leq) s' s);
  ftm_decreasing_role_preserved:
    ∀ (s s': Mdl) ρ',
      (fmtrans _ s ρ' s' -> ρ' ≠ Some (ftm_decreasing_role s) ->
      ftm_decreasing_role s = ftm_decreasing_role s');
  ftm_notinc:
    ∀ (s: Mdl) ρ s', (fmtrans _ s ρ s' -> ftm_leq s' s);
}.

Arguments ftm_leq {_ _}.
Arguments ftm_wf {_ _}.
Arguments ftm_decr {_ _}.
Arguments ftm_decreasing_role {_ _}.

#[global] Existing Instance ftm_order.

Notation ftm_lt := (strict ftm_leq).
Local Infix "<" := ftm_lt.
Local Infix "≤" := ftm_leq.

Lemma ftm_trans' `{FairTerminatingModel Mdl} a b c:
  a < b -> b ≤ c -> a < c.
Proof.
  intros [H1 H1'] H2.
  (* TODO: Why do we need to extract this manually? *)
  assert (EqDecision Mdl) by apply Mdl.(fmstate_eqdec).
  destruct (decide (b = c)) as [->|Heq]; [done|].
  split; [by etransitivity|].
  intros H'. apply H1'.
  by etransitivity.
Qed.

Lemma fair_terminating_traces_terminate_rec `{FairTerminatingModel Mdl}
      (s0: Mdl) (mtr: mtrace Mdl):
  (trfirst mtr) ≤ s0 ->
  mtrace_valid mtr ->
  (∀ ρ, fair_model_trace ρ mtr) ->
  terminating_trace mtr.
Proof.
  revert mtr. induction s0 as [s0 IH] using (well_founded_ind ftm_wf).
  intros mtr Hleq Hval Hfair.
  destruct mtr as [|s ℓ mtr'] eqn:Heq; first by eexists 1.
  destruct (ftm_decr (trfirst mtr)) as (Hlive & Htrdec).
  { exists ℓ, (trfirst mtr'). punfold Hval. inversion Hval; subst; done. }
  rewrite <- Heq in *. clear s ℓ Heq.
  destruct (Hfair (ftm_decreasing_role (trfirst mtr)) 0) as [n Hev];
    first by rewrite /pred_at /=; destruct mtr.
  revert mtr Hval Hleq Hfair Hlive IH Hev Htrdec. induction n as [| n IHn];
    intros mtr Hval Hleq Hfair Hlive IH Hev Htrdec.
  - simpl in *. rewrite /pred_at /= in Hev.
    destruct Hev as [Hev|Hev]; first by destruct mtr; done.
    destruct mtr; first done. injection Hev => ->.
    apply terminating_trace_cons.
    eapply IH =>//; eauto.
    + eapply ftm_trans' =>//. apply Htrdec.
      punfold Hval. inversion Hval; simplify_eq; simpl in *; simplify_eq; done.
    + punfold Hval. inversion Hval; simplify_eq.
      destruct H4; done.
  - simpl in *. destruct mtr; first (exists 1; done).
    rewrite -> !pred_at_S in Hev.
    punfold Hval; inversion Hval as [|??? Htrans Hval']; simplify_eq.
    destruct Hval' as [Hval'|]; last done.
    destruct (decide (ℓ = Some (ftm_decreasing_role s))) as [-> | Hnoteq].
    + apply terminating_trace_cons. eapply IH=>//; eauto.
      eapply ftm_trans' =>//; apply Htrdec. simpl. destruct Hval;done.
    + destruct mtr as [|s' ℓ' mtr''] eqn:Heq; first by eexists 2.
      destruct (ftm_decr (trfirst mtr)) as (Hlive' & Htrdec').
      { exists ℓ', (trfirst mtr''). punfold Hval'; inversion Hval'; subst; done. }
      apply terminating_trace_cons. eapply IHn=>//; eauto.
      * etransitivity; eauto. eapply ftm_notinc =>//.
      * simplify_eq. eapply Hlive'.
      * erewrite <- ftm_decreasing_role_preserved =>//.
      * intros s'' Htrans''. eapply ftm_decr; eauto.
Qed.

Theorem fair_terminating_traces_terminate `{FairTerminatingModel Mdl} :
  ∀ (mtrace : @mtrace Mdl), mtrace_fairly_terminating mtrace.
Proof. intros ???. eapply fair_terminating_traces_terminate_rec=>//. Qed.


Require Import Monad.
Require Import Examples.

(* Examples *)

Definition EM := forall (P : Prop), P \/ ~ P.

(** One representation of [-1,1] **)

Inductive SB : Type := NO | Z | PO.
Definition RR := nat -> SB.

Section partial_function.
  Parameter A B : Type.
  Parameter x : A.
  Parameter y : B.
  Parameter AC : choice.

  Lemma toto : [ {f : A -> B | forall z, z <> x -> f z = y} ].
  Proof.
   destruct (AC A (fun z => {r | r = y})) as [f].
    intro; constructor; eauto.

    constructor.
    pose (g := fun z => proj1_sig (f z)).
    exists g; intros z _.
    unfold g; destruct (f z); auto.
  Qed.

  Lemma toto' : [ {f : A -> B | forall z, z <> x -> f z = y} ].
  Proof.
   destruct (AC A (fun z => {r | r = y})) as [f].
    intro.
    constructor.
    eauto.

    constructor.
    pose (g := fun z => proj1_sig (f z)).
    exists g.
    intros z Hz.
    unfold g.
    destruct (f z).
    auto.
  Qed.
End partial_function.

(** Speaking of a function which decide whether f n = P0 for all n or not **)
(* This is not very nice *)
Definition eq_one_dec : choice -> EM ->
  [ { DEC : RR -> bool |
       forall f,
         ((forall n : nat, f n = PO) -> DEC f = true) /\
         ((exists n : nat, f n <> PO) -> DEC f = false) } ].
Proof.
intros Ch Em.
destruct (AC RR
  (fun f => {b |
    ((forall n : nat, f n = PO) -> b = true) /\
    ((exists n : nat, f n <> PO) -> b = false)})) as [D].
 intros u.
 destruct (Em (exists n : nat, u n <> PO)) as [Ex | Not].
  constructor.
  exists false; split; [ | reflexivity]; intros Hf.
  destruct Ex as (n, Hn).
  apply False_ind; intuition.

  constructor.
  exists true; intuition.

 constructor.
 pose (DD := (fun x => proj1_sig (D x))).
 exists DD.
 unfold DD.
 intros f.
 destruct (D f) as [b [Hb1 Hb2]].
 split; intros Hf; simpl; intuition.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable tTRANSITIVE_REFLEXIVE_REWRITE_ : Universe -> Universe -> Prop.
Variable tREWRITE_ : Universe -> Universe -> Prop.
Variable tEQUALISH_ : Universe -> Universe -> Prop.
Variable goal_ : Prop.
Variable fTRANSITIVE_REFLEXIVE_REWRITE_ : Universe -> Universe -> Prop.
Variable fREWRITE_ : Universe -> Universe -> Prop.
Variable fEQUALISH_ : Universe -> Universe -> Prop.
Variable dom_ : Universe -> Prop.

Variable c_ : Universe.
Variable b_ : Universe.
Variable a_ : Universe.

Variable initial_model_1 : (dom_ b_ /\ (dom_ c_ /\ (dom_ a_ /\ (tTRANSITIVE_REFLEXIVE_REWRITE_ a_ b_ /\ tTRANSITIVE_REFLEXIVE_REWRITE_ a_ c_)))).
Variable botEQUALISH_2 : (forall V1 V2 : Universe, ((tEQUALISH_ V1 V2 /\ fEQUALISH_ V1 V2) -> goal_)).
Variable botREWRITE_3 : (forall V1 V2 : Universe, ((tREWRITE_ V1 V2 /\ fREWRITE_ V1 V2) -> goal_)).
Variable botTRANSITIVE_REFLEXIVE_REWRITE_4 : (forall V1 V2 : Universe, ((tTRANSITIVE_REFLEXIVE_REWRITE_ V1 V2 /\ fTRANSITIVE_REFLEXIVE_REWRITE_ V1 V2) -> goal_)).
Variable ax00_5 : (forall A : Universe, (fEQUALISH_ A A -> goal_)).
Variable ax01_6 : (forall A : Universe, ((tTRANSITIVE_REFLEXIVE_REWRITE_ b_ A /\ tTRANSITIVE_REFLEXIVE_REWRITE_ c_ A) -> goal_)).
Variable ax04_7 : (forall B A : Universe, (fEQUALISH_ B A -> fEQUALISH_ A B)).
Variable ax05_8 : (forall A B : Universe, (tREWRITE_ A B -> tTRANSITIVE_REFLEXIVE_REWRITE_ A B)).
Variable ax06_9 : (forall A B C : Universe, ((tTRANSITIVE_REFLEXIVE_REWRITE_ A B /\ tTRANSITIVE_REFLEXIVE_REWRITE_ B C) -> tTRANSITIVE_REFLEXIVE_REWRITE_ A C)).
Variable ax07_10 : (forall A B : Universe, ((dom_ A /\ dom_ B) -> (fEQUALISH_ A B \/ tTRANSITIVE_REFLEXIVE_REWRITE_ A B))).
Variable ax08_11 : (forall A B C : Universe, ((tREWRITE_ A B /\ tREWRITE_ A C) -> (exists D : Universe, (dom_ D /\ (tTRANSITIVE_REFLEXIVE_REWRITE_ B D /\ tTRANSITIVE_REFLEXIVE_REWRITE_ C D))))).
Variable ax09_12 : (forall A B C : Universe, ((tREWRITE_ a_ A /\ (tTRANSITIVE_REFLEXIVE_REWRITE_ A B /\ tTRANSITIVE_REFLEXIVE_REWRITE_ A C)) -> (exists D : Universe, (dom_ D /\ (tTRANSITIVE_REFLEXIVE_REWRITE_ B D /\ tTRANSITIVE_REFLEXIVE_REWRITE_ C D))))).
Variable ax10_13 : (forall A B : Universe, ((tTRANSITIVE_REFLEXIVE_REWRITE_ A B /\ fEQUALISH_ A B) -> (exists C : Universe, (dom_ C /\ (tREWRITE_ A C /\ tTRANSITIVE_REFLEXIVE_REWRITE_ C B))))).

Theorem nnl_14 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.
Require Import common.lhs_sel_low_reduce.lhs_sel_low_reduce.
Require Import common.lhs_sel_upp_reduce.lhs_sel_upp_reduce.
Require Import common.lhs_sel_equ_reduce.lhs_sel_equ_reduce.
Require Import common.lhs_sel_nom_reduce.lhs_sel_nom_reduce.
Require Import common.lhs_all_reduce.lhs_all_reduce.
Require Import common.lhs_rfn_top_reduce.lhs_rfn_top_reduce.
Require Import common.lhs_rfn_sel_reduce.lhs_rfn_sel_reduce.
Require Import common.lhs_sha_top_reduce.lhs_sha_top_reduce.
Require Import common.lhs_sha_sel_reduce.lhs_sha_sel_reduce.
Require Import common.lhs_upp_reduce.lhs_upp_reduce.
Require Import common.lhs_low_reduce.lhs_low_reduce.
Require Import common.lhs_equ_reduce.lhs_equ_reduce.
Require Import common.lhs_nom_reduce.lhs_nom_reduce.
Require Import common.lhs_nil_reduce.lhs_nil_reduce.
Require Import common.lhs_con_reduce.lhs_con_reduce.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_lhs_sel_upp_reduce :
  forall T1 x1 L1 T1', T1 = t_sel_upp x1 L1 T1' ->
                  forall T2, subtype T1' T2 = true ->
                        (T2 <> t_nil) ->
                        (forall T2' Ts2, T2 <> t_con T2' Ts2) ->
                        (forall L2 T2', T2 <> t_upp L2 T2') ->
                        (forall L2 T2', T2 <> t_low L2 T2') ->
                        (forall L2 T2', T2 <> t_equ L2 T2') ->
                        (forall L2 T2', T2 <> t_nom L2 T2') ->
                        subtype T1 T2 = true.
Proof.
  intros.

  subst T1.
  rewrite subtype_sel_upp_reduce with (x1:=x1)(L1:=L1)(T1':=T1');
    [|auto].

  destruct T2; simpl; auto.

  rewrite H0, orb_true_r; auto.

  rewrite H0, orb_true_r; auto.

  rewrite H0, orb_true_r; auto.

  rewrite H0, orb_true_r; auto.

  rewrite H0, orb_true_r; auto.

  contradiction (H3 l T2); auto.
  contradiction (H4 l T2); auto.
  contradiction (H5 l T2); auto.
  contradiction (H6 l T2); auto.
  contradiction (H2 T2_1 T2_2); auto.
Qed.


(** * Definition of a boolean-returning CFG parser-recognizer *)
Require Import Coq.Lists.List.
Require Import Coq.omega.Omega.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.BaseTypes Fiat.Parsers.CorrectnessBaseTypes.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.MinimalParseOfParse.
Require Import Fiat.Common.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Common.List.ListFacts.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Section brute_force_splitter.
  Context {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}.

  Definition make_all_single_splits (str : String) (offset len : nat) : list nat
    := len::up_to len.

  Context (G : pregrammar' Char).

  Global Instance brute_force_split_data : @split_dataT Char _ (rdp_list_predata (G := G))
    := { split_string_for_production p := make_all_single_splits }.

  Global Instance brute_force_data : @boolean_parser_dataT Char _
    := { predata := @rdp_list_predata _ G;
         split_data := brute_force_split_data }.

  Global Instance brute_force_cdata : @boolean_parser_completeness_dataT' _ _ _ G brute_force_data
    := { split_string_for_production_complete str0 valid str offset len pf nt pf' pf''
         := ForallT_all (fun _ => Forall_tails_all (fun prod => _)) }.
  Proof.
    destruct prod; try solve [ constructor ].
    hnf.
    intros; intros [ n [ p0 p1 ] ].
    destruct (Compare_dec.le_lt_dec len n).
    { exists len; simpl; repeat split.
      { left; reflexivity. }
      { eapply expand_minimal_parse_of_item; [ .. | eassumption ];
        try solve [ reflexivity
                  | left; reflexivity
                  | rewrite !take_long; trivial; reflexivity
                  | rewrite take_long at 1 by (rewrite Properties.substring_length; apply Min.min_case_strong; omega);
                    symmetry;
                    rewrite take_long at 1 by (rewrite Properties.substring_length; apply Min.min_case_strong; omega);
                    reflexivity ]. }
      { eapply expand_minimal_parse_of_production; [ .. | eassumption ];
        try solve [ reflexivity
                  | left; reflexivity
                  | apply bool_eq_empty; rewrite drop_length; omega
                  | apply bool_eq_empty; rewrite drop_length, Properties.substring_length; apply Min.min_case_strong; omega ]. } }
    { exists n; simpl; repeat split; try assumption.
      right; apply List.in_map, in_up_to; assumption. }
  Qed.
End brute_force_splitter.


From iris.base_logic.lib Require Export own saved_prop.
From iris.program_logic Require Export weakestpre.
From iris.proofmode Require Import tactics.
From stdpp Require Import base pretty strings.
From distris Require Import tactics proofmode notation adequacy.
From distris.examples.library Require Import proof frac_auth.
From distris.examples.calculator Require Import calc.
From distris.examples.load_balancer Require Import definitions lb lb_proof.

(* Set Default Proof Using "Type". *)

Import Network.
Import String.

Lemma valid_tag_stringOfZ a :
  valid_tag a.
Proof.
Admitted.

Section calculator_server.
  Context `{dG : distG Σ}
          `{node : Network.node}
          `{P : (Z * Z) -> iProp Σ}.

  Definition Pin (msg : string) (v : Z * Z) : iProp Σ :=
    (⌜msg = StringOfZ(v.1) +:+ "_" +:+ StringOfZ(v.2)⌝)%I.

  Definition Pout (msg : string) (v : Z * Z) : iProp Σ :=
    (⌜msg = StringOfZ(v.1 + v.2)⌝)%I.

  Definition calculator_si := relay_resp_si P Pin Pout.

  Lemma calculator_spec (addr : socket_address) e1 A γs :
    IntoVal ⟨node;e1⟩ 〈node;#addr〉 ->
    addr ∈ A ->
    {{{ addr ⤇ calculator_si ∗ f↦ A ∗ node n↦ γs ∗
        FreePorts (ip_of_address addr) {[port_of_address addr]} }}}
      ⟨node; calculator e1⟩
    {{{ v, RET 〈node;v〉; True }}}.
  Proof.
    iIntros (<-%to_base_val'%ground_lang.of_to_val
                Haddr Φ) "(#Hsi & #Hfixed & Hn & Hip) HΦ".
    wp_lam. wp_socket h as "Hsocket". wp_let.
    wp_apply (wp_bind_socket_fix_suc with "[$Hfixed Hip $Hsocket]"); eauto.
    iDestruct 1 as (g) "(Haddr & ? & Harecs & _)". wp_seq.
    wp_apply (listen_spec (True)
                          (λ v, ⌜True⌝)%I
                          _ _ _ addr
                with "[] [-HΦ]"); last auto; last iFrame; auto.
    iLöb as "IH" forall (g).
    iIntros (mId m φ Φ') "!# H HΦ'".
    iDestruct "H" as (Hrecmsg) "(_ & Hs & Hrec & HmId & #Hsi' & HP)".
    iDestruct (si_pred_agree _ _ _ (message_stable_from_message m)
                 with "Hsi Hsi'") as "#Heq". simpl.
    wp_rec. iRewrite -"Heq" in "HP". wp_let.
    rewrite /calculator_si /relay_resp_si /Pin.
    iDestruct "HP" as (φ' [v1 v2]) "(#Hcsi & Hbody & HP & Hws)".
    iDestruct "Hbody" as %Hbody.
    rewrite /message_stable_from_message /= in Hbody; rewrite Hbody.
    wp_apply (tag_of_message_spec); eauto. apply valid_tag_stringOfZ.
    iIntros (v' Hv') "". subst.
    wp_op. simpl. rewrite ZOfString_inv. eauto.
    wp_apply (unSOME_spec); eauto. iIntros "_". wp_let.
    wp_apply (value_of_message_spec); eauto. apply valid_tag_stringOfZ.
    iIntros (v'' Hv'') "". subst.
    wp_op. simpl. rewrite ZOfString_inv. eauto.
    wp_apply (unSOME_spec); eauto. iIntros "_". wp_let.
    wp_op. wp_let. wp_op.
    rewrite /message_stable_from_message /=.
    wp_apply (wp_send_to_bound ⌜True⌝%I ⌜True⌝%I
                with "[$Hs HP Hws]"); eauto; iFrame; iFrame "#". iSplitR; first done.
    iIntros (M s mId') "(Hm & Hmsg & Hinfo)". iFrame. simpl.
    iApply "Hws". iFrame. done.
    iIntros "[Hsh _]". wp_seq.
    wp_apply (listen_spec (True)
                          (λ v, ⌜True⌝)%I
                          _ _ _ addr
                with "[] [-HΦ']"); last auto; last iFrame; auto.
  Qed.

End calculator_server.

Section calculator_client.
  Context `{dG : distG Σ}.

  Definition client_si a b : socket_interp Σ :=
    (λ msg, ⌜ms_body msg = StringOfZ(a + b)⌝)%I.

  Lemma client_spec n (a b : Z) (ip : ip_address) (server : socket_address)
        e1 e2 e3 e4 A γs :
    IntoVal ⟨n;e1⟩ 〈n;#a〉 ->
    IntoVal ⟨n;e2⟩ 〈n;#b〉 ->
    IntoVal ⟨n;e3⟩ 〈n;#ip〉 ->
    IntoVal ⟨n;e4⟩ 〈n;#server〉 ->
    server ∈ A ->
    SocketAddressInet ip 80 ∉ A ->
    {{{ server ⤇ calculator_si (P:=(λ v, True%I)) ∗ f↦ A ∗ n n↦ γs ∗
        FreePorts ip {[80%positive]} }}}
      ⟨n; client e1 e2 e3 e4⟩
    {{{ v, RET 〈n;#v〉; ⌜v = StringOfZ(a + b)⌝ }}}.
  Proof.
    iIntros (<-%to_base_val'%ground_lang.of_to_val
                <-%to_base_val'%ground_lang.of_to_val
                <-%to_base_val'%ground_lang.of_to_val
                <-%to_base_val'%ground_lang.of_to_val
                Haddr Hnotin Φ) "(#Hsi & #Hfixed & Hn & Hip) HΦ".
    do 4 wp_let.
    wp_socket h as "Hs". wp_let. wp_makeaddress. wp_let.
    wp_apply (wp_bind_socket_dyn_suc _ _ _ _ _ _ _ _
                (client_si a b) with "[$Hfixed Hip $Hs]"); eauto.
    iDestruct 1 as (g) "(Hs & ? & Hrecs & #Hcsi)". wp_seq.
    wp_op. wp_op. wp_op. wp_op. wp_let.
    wp_apply (wp_send_to_bound ⌜True⌝%I ⌜True⌝%I
                with "[$Hs]"); eauto; iFrame; iFrame "#". iSplitR; first done.
    iIntros (M s mId) "(Hms & _)". iFrame; iFrame "#".
    rewrite /calculator_si /relay_resp_si /message_stable_from_message /=.
    iSplitR; last done.
    iModIntro. iNext. iExists (client_si a b),(a,b). iFrame "#".
    iSplitR. by rewrite -append_assoc. iSplitR. done.
    rewrite /Pout /client_si. iIntros (m) "[% %]". done.
    iIntros "[Hs _]". wp_seq.
    wp_apply (listen_wait_spec with "[$Hs Hrecs]"); eauto.
    iIntros (m mId) "(Hrecm & Hs & Hrec & _ & HP)". simpl.
    wp_proj.
    iApply "HΦ".
    rewrite /client_si /message_stable_from_message /= //.
  Qed.

End calculator_client.

Section calculator_runner.
  Context `{dG : distG Σ}.

  Definition ips : gset string := {[ "0.0.0.0" ; "127.0.0.1" ; "127.0.0.2" ]}.
  Definition server := SocketAddressInet "0.0.0.0" 80.

  Lemma calculator_runner_spec A :
    server ∈ A ->
    SocketAddressInet "127.0.0.1" 80 ∉ A →
    SocketAddressInet "127.0.0.2" 80 ∉ A →
    {{{ f↦ A ∗ server ⤇ calculator_si (P:=(λ v, True%I)) ∗
        [∗ set] ip ∈ ips, FreeIP ip }}}
        calc_runner
    {{{ v, RET v; True }}}.
  Proof.
    iIntros (? ? ? Φ) "(#Hfix & #Hsi & Hips) HΦ".
    rewrite /calc_runner.
    iDestruct (big_sepS_delete _ _ "0.0.0.0" with "Hips") as "(Hserver & Hips)";
      first set_solver.
    iDestruct (big_sepS_delete _ _ "127.0.0.1" with "Hips") as "(Hc1 & Hips)";
      first set_solver.
    iDestruct (big_sepS_delete _ _ "127.0.0.2" with "Hips") as "(Hc2 & _)";
      first set_solver.
    wp_makeaddress. wp_let. rewrite /server.
    wp_apply (wp_start with "[-]"); first auto; iFrame. simpl.
    iSplitL "Hc1 Hc2 HΦ"; last first.
    { iNext. iIntros "Hn Hip".
      iDestruct "Hn" as (γs) "Hn".
      iApply (calculator_spec with "[Hn Hip] []");
        try iFrame "#"; simpl;
          eauto; try done.  }
    iNext. wp_seq.
    wp_apply (wp_start _ "127.0.0.1" with "[-]"); first auto. iFrame.
    iSplitL "Hc2 HΦ"; last first.
    { iNext. iIntros "Hn Hip".
      iDestruct "Hn" as (γ) "Hn".
      iApply (client_spec with "[Hn Hip] []"); eauto. }
    iNext. wp_seq.
    wp_apply (wp_start with "[-]"); eauto; iFrame.
    iSplitL "HΦ". by iApply "HΦ".
    { iNext. iIntros "Hn Hip".
      iDestruct "Hn" as (γ) "Hn".
      iApply (client_spec with "[-] []"); eauto. }
  Qed.

End calculator_runner.

Definition calculator_is :=
  {|
    state_heaps := ∅;
    state_sockets := ∅;
    state_lookup := ∅;
    state_ports_in_use :=
      <["0.0.0.0" := ∅ ]> $ <["127.0.0.1" := ∅ ]> $ <["127.0.0.2" := ∅ ]> $ ∅;
    state_ms := ∅;
  |}.

Definition calc_socket_interp `{distG Σ} sa : socket_interp Σ :=
  (match sa with
  | SocketAddressInet "0.0.0.0" 80 => calculator_si (P:=(λ v, True%I))
  | _ => λ msg, ⌜True⌝
   end)%I.

Definition fixed_dom : gset socket_address := {[ server ]}.

Theorem calculator_safe : adequate NotStuck calc_runner calculator_is (λ v, True).
Proof.
  set (Σ := #[distΣ]).
  eapply (@dist_adequacy Σ _ ips fixed_dom); try done; last first.
  { intros i.
    rewrite /ips !elem_of_union !elem_of_singleton.
    intros [[]|]; subst; set_solver. }
  { rewrite /ips /= !dom_insert_L dom_empty_L right_id_L !assoc_L //. }
  iIntros (dinvG).
  iExists calc_socket_interp. iModIntro.
  iIntros "#Hfix #Hsc Hips".
  iApply (calculator_runner_spec fixed_dom with "[-] []"); eauto;
    rewrite /fixed_dom /server; try iFrame; try iFrame "#"; try set_solver.
  rewrite big_sepS_singleton. rewrite /socket_interp. iFrame "#".
Qed.

Section calc_lb_runner.
  Context `{dG : distG Σ, lG : lbG (Z * Z) Σ, N : namespace}.

  Definition calc_lb_ips : gset string :=
    {[ "0.0.0.0" ; "0.0.0.1" ; "0.0.0.2" ; "0.0.0.3" ; "127.0.0.1" ; "127.0.0.2" ]}.

  (* Definition calc_lb_ips : list string := *)
  (*   ["0.0.0.0"; "0.0.0.1" ; "0.0.0.2" ; "0.0.0.3" ; "127.0.0.1" ; "127.0.0.2"]. *)

  Definition calc_servers :=
    [
      SocketAddressInet "0.0.0.1" 80;
      SocketAddressInet "0.0.0.2" 80;
      SocketAddressInet "0.0.0.3" 80
    ].

  Definition lb_ports : gset port :=
    {[ 1100%positive ; 1101%positive ; 1102%positive ]}.

  Lemma calc_lb_runner_spec A :
    SocketAddressInet "0.0.0.0" 80 ∈ A ->
    SocketAddressInet "0.0.0.1" 80 ∈ A ->
    SocketAddressInet "0.0.0.2" 80 ∈ A ->
    SocketAddressInet "0.0.0.3" 80 ∈ A ->
    SocketAddressInet "127.0.0.1" 80 ∉ A →
    SocketAddressInet "127.0.0.2" 80 ∉ A →
    {{{ gen_heap_ctx (L:=socket_address) (V:=Z * Z) ∅ ∗ f↦ A ∗
        SocketAddressInet "0.0.0.0" 80 ⤇ calculator_si (P:=(λ v, True%I)) ∗
        ([∗ set] p ∈ lb_ports, ⌜SocketAddressInet "0.0.0.0" p ∉ A⌝) ∗
        ([∗ list] s∈calc_servers, s ⤇ calculator_si (P:=lb_server_P s)) ∗
        ([∗ set] ip ∈ calc_lb_ips, FreeIP ip)
    }}}
        calc_lb_runner
    {{{ v, RET v; True }}}.
  Proof.
    iIntros (? ? ? ? ? ? Φ)
            "(Hw & #Hfix & #Hsi & #Hfree & #Hcalcsi & Hips) HΦ".
    rewrite /calc_lb_runner.
    do 3 (wp_makeaddress; wp_let).
    wp_apply list_make_spec; auto. iIntros (? ?). simpl. wp_let.
    wp_apply list_cons_spec; auto. iIntros (? ?). simpl. wp_let.
    wp_apply list_cons_spec; auto. iIntros (? ?). simpl. wp_let.
    wp_apply list_cons_spec; auto. iIntros (servers Hservers).
    simpl. rewrite /calc_lb_ips. simpl. wp_let.
    iDestruct (gen_heap_alloc (L:=socket_address)
                              (V:=Z * Z) _
                              (SocketAddressInet "0.0.0.1" 80)
                              (0,0)%Z with "Hw") as ">[Hw Hw1]"; eauto.
    iDestruct (gen_heap_alloc (L:=socket_address)
                              (V:=Z * Z) _
                              (SocketAddressInet "0.0.0.2" 80)
                              (0,0)%Z with "Hw") as ">[Hw Hw2]"; eauto.
    { rewrite lookup_insert_ne; eauto. }
    iDestruct (gen_heap_alloc (L:=socket_address)
                              (V:=Z * Z) _
                              (SocketAddressInet "0.0.0.3" 80)
                              (0,0)%Z with "Hw") as ">[Hw Hw3]"; eauto.
    { rewrite lookup_insert_ne; eauto.
      rewrite lookup_insert_ne; eauto. }
    iApply fupd_wp.
    iMod (inv_alloc lb_inv_w_n _
                    (∃ w, gen_heap_ctx (L:=socket_address) (V:=Z * Z) w)%I
            with "[Hw]") as "#HwI".
    { iNext. iExists _. iFrame. }
    iModIntro.
    iDestruct "Hcalcsi" as "(Hip1 & Hip2 & Hip3 & _)".
    iDestruct (big_sepS_delete _ _ "0.0.0.0" with "Hips") as "(Hlb & Hips)";
      first set_solver.
    iDestruct (big_sepS_delete _ _ "127.0.0.1" with "Hips") as "(Hc1 & Hips)";
      first set_solver.
    iDestruct (big_sepS_delete _ _ "127.0.0.2" with "Hips") as "(Hc2 & Hips)";
      first set_solver.
    iDestruct (big_sepS_delete _ _ "0.0.0.1" with "Hips") as "(Hcalc1 & Hips)";
      first set_solver.
    iDestruct (big_sepS_delete _ _ "0.0.0.2" with "Hips") as "(Hcalc2 & Hips)";
      first set_solver.
    iDestruct (big_sepS_delete _ _ "0.0.0.3" with "Hips") as "(Hcalc3 & _)";
      first set_solver.
    wp_apply (wp_start _ _ (lb_ports ∪ {[80%positive]}) with "[-]"); first auto;
      iFrame. simpl.
    iSplitR "Hw1 Hw2 Hw3"; last first.
    { iNext. iIntros "Hn Hip".
      iDestruct "Hn" as (γs) "Hn".
      iApply (lb_spec A (SocketAddressInet "0.0.0.0" 80)
                      _ _ _ "0.0.0.0" calc_servers  with "[Hn Hip Hw1 Hw2 Hw3] []");
        eauto.
      rewrite /lb_ports /calc_servers /=.
      rewrite !FreePorts_distribute; try set_solver.
      iDestruct "Hip" as "[[[Hp1100 Hp1101] Hp1102] Hp80]". iFrame; iFrame "#".
      iDestruct (big_sepS_elem_of _ _ 1100%positive with "Hfree") as "#Hf1";
        first set_solver.
      iDestruct (big_sepS_elem_of _ _ 1101%positive with "Hfree") as "#Hf2";
        first set_solver.
      iDestruct (big_sepS_elem_of _ _ 1102%positive with "Hfree") as "#Hf3";
        first set_solver. iFrame "#".
      iSplitL "Hw1". by iExists (0,0)%Z.
      iSplitL "Hw2". by iExists (0,0)%Z.
      iSplitL; last done.
      by iExists (0,0)%Z. }
    iNext. wp_seq.
    wp_apply (wp_start with "[-]"); first auto; iFrame.
    iSplitR ""; last first.
    { iNext. iIntros "Hn Hip".
      iDestruct "Hn" as (γs) "Hn".
      iApply (calculator_spec with "[Hn Hip] []");
        try iFrame "#"; simpl;
          eauto; try done.  }
    iNext. wp_seq.
    wp_apply (wp_start with "[-]"); first auto; iFrame.
    iSplitR ""; last first.
    { iNext. iIntros "Hn Hip".
      iDestruct "Hn" as (γs) "Hn".
      iApply (calculator_spec with "[Hn Hip] []");
        try iFrame "#"; simpl;
          eauto; try done.  }
    iNext. wp_seq.
    wp_apply (wp_start with "[-]"); first auto; iFrame.
    iSplitR ""; last first.
    { iNext. iIntros "Hn Hip".
      iDestruct "Hn" as (γs) "Hn".
      iApply (calculator_spec with "[Hn Hip] []");
        try iFrame "#"; simpl;
          eauto; try done.  }
    iNext. wp_seq. wp_makeaddress. wp_let.
    wp_apply (wp_start with "[-]"); first auto; iFrame.
    iSplitR ""; last first.
    { iNext. iIntros "Hn Hip".
      iDestruct "Hn" as (γs) "Hn".
      iApply (client_spec with "[Hn Hip] []");
        try iFrame "#"; simpl;
          eauto; try done.  }
    iNext. wp_seq.
    wp_apply (wp_start with "[-]"); first auto; iFrame.
    iSplitR ""; last first.
    { iNext. iIntros "Hn Hip".
      iDestruct "Hn" as (γs) "Hn".
      iApply (client_spec with "[Hn Hip] []");
        try iFrame "#"; simpl;
          eauto; try done.  }
      by iApply "HΦ".
    Unshelve. done.
  Qed.

End calc_lb_runner.

Definition calc_lb_is :=
  {|
    state_heaps := ∅;
    state_sockets := ∅;
    state_lookup := ∅;
    state_ports_in_use :=
      <["0.0.0.0" := ∅ ]> $
      <["0.0.0.1" := ∅ ]> $
      <["0.0.0.2" := ∅ ]> $
      <["0.0.0.3" := ∅ ]> $
      <["127.0.0.1" := ∅ ]> $
      <["127.0.0.2" := ∅ ]> $ ∅;
    state_ms := ∅;
  |}.

Definition calc_lb_socket_interp `{distG Σ, lbG (Z * Z) Σ} sa : socket_interp Σ :=
  (match sa with
  | SocketAddressInet "0.0.0.0" 80 => calculator_si (P:=(λ v, True%I))
  | SocketAddressInet "0.0.0.1" 80 =>
    calculator_si (P:=lb_server_P (SocketAddressInet "0.0.0.1" 80))
  | SocketAddressInet "0.0.0.2" 80 =>
    calculator_si (P:=lb_server_P (SocketAddressInet "0.0.0.2" 80))
  | SocketAddressInet "0.0.0.3" 80 =>
    calculator_si (P:=lb_server_P (SocketAddressInet "0.0.0.3" 80))
  | _ => λ msg, ⌜True⌝
   end)%I.

Definition calc_fixed_dom : gset socket_address :=
  {[ SocketAddressInet "0.0.0.0" 80;
     SocketAddressInet "0.0.0.1" 80;
     SocketAddressInet "0.0.0.2" 80;
     SocketAddressInet "0.0.0.3" 80 ]}.

Lemma make_lbG `{lbPreG (X:=Z * Z)} :
  (|==> ∃ _ : lbG (X:=Z * Z) (Σ:=Σ), gen_heap_ctx (L:=socket_address) ∅)%I.
Proof.
  iStartProof.
  iMod (gen_heap_init (L:=socket_address) (V:=(Z*Z)) ∅) as (γlb) "Hlb".
  iExists {|
      lb_relayG := γlb;
    |}. by iFrame.
Qed.
Theorem calc_lb_safe : adequate NotStuck calc_lb_runner calc_lb_is (λ v, True).
Proof.
  set (Σ := #[distΣ;lbΣ (X:=Z * Z)]).
  eapply (dist_adequacy (Σ:=Σ) calc_lb_ips calc_fixed_dom); eauto; last first.
  { intros i.
    rewrite /ips !elem_of_union !elem_of_singleton.
    intros [[]|]; subst; set_solver. }
  { rewrite /ips /= !dom_insert_L dom_empty_L right_id_L !assoc_L //. }
  iIntros (dinvG).
  iMod (@make_lbG Σ) as (?) "H".
  iExists calc_lb_socket_interp. iModIntro.
  iIntros "#Hfix #Hsc Hips".
  iApply (calc_lb_runner_spec (N:=nroot) calc_fixed_dom with "[-] []"); eauto;
    rewrite /calc_fixed_dom /calc_servers /lb_ports /=;
            try iFrame; try iFrame "#"; try set_solver.
  iDestruct (big_sepS_elem_of _ _ (SocketAddressInet "0.0.0.0" 80) with "Hsc")
    as "Hp0"; first set_solver. iFrame "#".
  iDestruct (big_sepS_elem_of _ _ (SocketAddressInet "0.0.0.1" 80) with "Hsc")
    as "Hp1"; first set_solver. iFrame "#".
  iDestruct (big_sepS_elem_of _ _ (SocketAddressInet "0.0.0.2" 80) with "Hsc")
    as "Hp2"; first set_solver. iFrame "#".
  iDestruct (big_sepS_elem_of _ _ (SocketAddressInet "0.0.0.3" 80) with "Hsc")
    as "Hp3"; first set_solver. iFrame "#".
  rewrite !big_sepS_union; try set_solver. rewrite !big_sepS_singleton.
  iPureIntro. repeat split; set_solver.
Qed.


Require Export Base.

Module Cocomplete.

Structure mixin_of (C: Category) := Mixin {
  colim {D: Category} (F: Functor D C): C;
  Colim {D: Category} (F: Functor D C): F ~> Δ (colim F);
  colim_med {D: Category} {F: Functor D C} {X: C} (η: F ~> Δ X): colim F ~> X;
  colim_med_comm {D: Category} {F: Functor D C} {X: C} (η: F ~> Δ X): ∇ (colim_med η) ∘ Colim F = η;
  colim_med_unique {D: Category} {F: Functor D C} {X: C} (η: F ~> Δ X) (f: colim F ~> X): ∇ f ∘ Colim F = η -> colim_med η = f;
}.

Notation class_of := mixin_of (only parsing).

Section ClassDef.

Structure type := Pack { sort: Category; _: class_of sort }.
Local Coercion sort: type >-> Category.

Variable T: type.
Definition class := match T return class_of T with Pack _ c => c end.

Definition Cat: Cat := T.

End ClassDef.

Module Exports.

Coercion sort: type >-> Category.
Coercion Cat: type >-> Category.obj.
Notation Cocomplete := type.

End Exports.
End Cocomplete.

Export Cocomplete.Exports.

Section Cocomplete_theory.
Context {C: Cocomplete}.

Definition colim: forall {D: Category} (F: Functor D C), C := @Cocomplete.colim C (Cocomplete.class C).
Definition Colim: forall {D: Category} (F: Functor D C), F ~> Δ (colim F) := @Cocomplete.Colim C (Cocomplete.class C).
Definition colim_med: forall {D: Category} {F: Functor D C} {X: C} (η: F ~> Δ X), colim F ~> X := @Cocomplete.colim_med C (Cocomplete.class C).
Definition colim_med_comm: forall {D: Category} {F: Functor D C} {X: C} (η: F ~> Δ X), ∇ (colim_med η) ∘ Colim F = η := @Cocomplete.colim_med_comm C (Cocomplete.class C).
Definition colim_med_unique: forall {D: Category} {F: Functor D C} {X: C} (η: F ~> Δ X) (f: colim F ~> X), ∇ f ∘ Colim F = η -> colim_med η = f := @Cocomplete.colim_med_unique C (Cocomplete.class C).

Lemma from_colim_eq {D} {F: Functor D C} {X: C} (f g: colim F ~> X): f = g <-> forall x, f ∘ Colim F x = g ∘ Colim F x.
Proof.
  split.
  now intros [].
  intros H.
  transitivity (colim_med (∇ g ∘ Colim F)).
  symmetry.
  all: apply colim_med_unique.
  2: reflexivity.
  now natural_eq x.
Qed.

Definition Colim_map {D: Category} {F G: Functor D C} (η: F ~> G): colim F ~> colim G :=
  colim_med (Colim G ∘ η).

Lemma Colim_map_comm {D: Category} {F G: Functor D C} (η: F ~> G): ∇ (Colim_map η) ∘ Colim F = Colim G ∘ η.
Proof. apply colim_med_comm. Qed.

Lemma colim_med_Colim {D: Category} {F: Functor D C} {X: C} (η: F ~> Δ X) (Y: D): colim_med η ∘ Colim F Y = η Y.
Proof. exact (proj1 (natural_eq _ _) (colim_med_comm η) Y). Qed.

Lemma Colim_map_Colim {D: Category} {F G: Functor D C} (η: F ~> G) (X: D): Colim_map η ∘ Colim F X = Colim G X ∘ η X.
Proof. exact (proj1 (natural_eq _ _) (Colim_map_comm η) X). Qed.

Lemma Colim_map_id {D: Category} {F: Functor D C}: Colim_map (id F) = id (colim F).
Proof.
  apply from_colim_eq.
  intros x.
  rewrite Colim_map_Colim.
  rewrite comp_id_l.
  apply comp_id_r.
Qed.

Lemma Colim_map_comp {D: Category} {F G H: Functor D C} (η: G ~> H) (ϵ: F ~> G): Colim_map (η ∘ ϵ) = Colim_map η ∘ Colim_map ϵ.
Proof.
  apply from_colim_eq.
  intros x.
  rewrite <- comp_assoc.
  rewrite !Colim_map_Colim; simpl.
  rewrite !comp_assoc.
  f_equal.
  symmetry.
  apply Colim_map_Colim.
Qed.

Canonical FColim {D: Category}: Functor (Fun D C) C := {|
  fobj := colim;
  fmap := @Colim_map D;
  fmap_id := @Colim_map_id D;
  fmap_comp := @Colim_map_comp D;
|}.

Definition map_Colimit {D E: Category} (F: Functor E C) (G: Functor D E): colim (F ∘ G) ~> colim F :=
  colim_med (eq_iso (diag_comp (colim F) G) ∘ (Colim F |> G)).

Lemma map_Colimit_Colim {D E: Category} (F: Functor E C) (G: Functor D E) (X: D): map_Colimit F G ∘ Colim (F ∘ G) X = Colim F (G X).
Proof.
  unfold map_Colimit.
  rewrite colim_med_Colim; simpl.
  rewrite <- comp_id_l.
  apply (f_equal (fun f => f ∘ _)).
  apply is_eq_refl.
  apply (transform_is_eq (eq_iso (diag_comp (colim F) G))).
  apply eq_iso_is_eq.
Qed.

Lemma map_Colimit_map {D E: Category} {F G: Functor E C} (H: Functor D E) (η: F ~> G): map_Colimit G H ∘ Colim_map (η |> H) = Colim_map η ∘ map_Colimit F H.
Proof.
  apply from_colim_eq.
  intros x.
  rewrite <- !comp_assoc.
  rewrite Colim_map_Colim.
  rewrite (map_Colimit_Colim F).
  rewrite comp_assoc.
  rewrite map_Colimit_Colim.
  symmetry.
  exact (Colim_map_Colim η (H x)).
Qed.

Lemma map_Colimit_is_eq {D E: Category} (F: Functor E C) (G: Functor D E): is_eq G -> is_eq (map_Colimit F G).
Proof.
  intros [e H].
  unfold fun_hom in H.
  subst G.
  destruct e; simpl.
  cut (is_eq (Colim_map (ρ F))).
  change (?P -> ?Q) with (impl P Q).
  f_equiv.
  symmetry.
  apply colim_med_unique.
  rewrite Colim_map_comm.
  rewrite <- unitor_whisk_r.
  f_equal.
  apply is_eq_unique.
  apply unitor_r_is_eq.
  apply eq_iso_is_eq.
  apply fmap_is_eq, unitor_r_is_eq.
Qed.

End Cocomplete_theory.


Require Import Rupicola.Lib.Api.
Require Import Rupicola.Lib.Arrays.
Require Import Rupicola.Examples.Nondeterminism.NonDeterminism.
Require Import coqutil.Byte.

Section Alloc.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.

  Definition stack_alloc (nbytes: nat) : ND.M (list byte) :=
    %{ ls: list byte | List.length ls = nbytes }.

  Lemma compile_stack_alloc : forall {tr mem locals functions} (nbytes: nat),
    let c := stack_alloc nbytes in
    forall {B} {pred: B -> predicate}
      {k: list byte -> ND.M B} {k_impl}
      (R: _ -> Prop) var,
      R mem ->
      Z.of_nat nbytes mod Memory.bytes_per_word width = 0 ->
      (forall ptr (bs: ListArray.t byte) mem,
          List.length bs = nbytes ->
          (sizedlistarray_value AccessByte nbytes ptr bs * R)%sep mem ->
          let pred g tr' mem' locals' :=
              exists R' bs',
                (sizedlistarray_value AccessByte nbytes ptr bs' * R')%sep mem' /\
                forall mem'', R' mem'' -> pred g tr' mem'' locals' in
          <{ Trace := tr;
             Memory := mem;
             Locals := map.put locals var ptr;
             Functions := functions }>
          k_impl
          <{ ndspec_k pred (k bs) }>) ->
      <{ Trace := tr;
         Memory := mem;
         Locals := locals;
         Functions := functions }>
      cmd.stackalloc var (Z.of_nat nbytes) k_impl
      <{ ndspec_k pred (mbindn [var] c k) }>.
  Proof.
    red; red; cbn; intros * Hmem Hmod Hkimpl.
    split; eauto; red. intros ptr mStack mCombined Hany Hsplit.
    generalize Hany; intros [bs [Hbs Hlen]]%anybytes_to_array_1.
    rewrite Nat2Z.id in Hlen.
    eapply WeakestPrecondition_weaken; cycle 1.
    - apply Hkimpl; eauto.
      apply sep_comm; exists mem0, mStack;
        eauto using sizedlistarray_value_of_array.
    - intros tr' mem' locals' (b & Hk & (R' & bs' & (mR' & mStack' & Hsplit' & HR' & Hbs')%sep_comm & Hpred')).
      eexists; eexists; split; [|split].
      + subst nbytes.
        rewrite <- (length_of_sizedlistarray_value Hbs').
        apply array_1_to_anybytes.
        eapply array_of_sizedlistarray_value in Hbs'.
        apply Hbs'.
      + eassumption.
      + unfold ndspec_k, ndspec, mbindn, mbind; cbn; eauto 6.
  Qed.

  Lemma stackalloc_universal_bound :
    forall z,
      Z.modulo z 8 = 0 ->
      Z.modulo z (Memory.bytes_per_word width) = 0.
  Proof.
    intros z Hmod.
    destruct width_cases as [-> | ->];
      unfold Memory.bytes_per_word, Z.div; simpl.
    2: eauto.
    - apply Z_div_exact_full_2 in Hmod; try congruence; rewrite Hmod.
      apply Zmod_divides; try congruence.
      exists (2 * (z / 8)); ring.
  Qed.

  Definition nondet_xor_src (w: word) :=
    let/+ bs := stack_alloc 8 in
    let/n idx := 0%nat in
    let/n undef := ListArray.get bs idx in
    let/n out := w in
    let/n out := word.xor (word_of_byte undef) out in
    let/n out := word.xor (word_of_byte undef) out in
    mret out.

  Lemma nondef_xor_id w w' : nondet_xor_src w w' -> w = w'.
  Proof.
    intros (bs & Hlen & ->).
    apply word.unsigned_inj. unfold byte.unsigned.
    rewrite !word.unsigned_xor_nowrap, !word.unsigned_of_Z.
    rewrite <- Z.lxor_assoc, Z.lxor_nilpotent, Z.lxor_0_l; reflexivity.
  Qed.

  Implicit Type R : mem -> Prop.
  Instance spec_of_nondet_xor : spec_of "nondet_xor" :=
    fnspec! "nondet_xor" w0 / R,
    { requires tr mem := R mem;
      ensures tr' mem' rets :=
        ndspec (nondet_xor_src w0)
               (fun w => tr' = tr /\ R mem' /\ rets = [w]) }.

  Import SizedListArrayCompiler.
  Hint Extern 1 => simple eapply compile_stack_alloc; shelve : compiler.
  Hint Extern 1 (_ < _) => reflexivity : compiler_side_conditions.

  Hint Resolve stackalloc_universal_bound : compiler_side_conditions.

  Derive nondet_xor_br2fn SuchThat
         (defn! "nondet_xor"("w") ~> "out"
              { nondet_xor_br2fn },
          implements nondet_xor_src)
  As nondet_xor_br2fn_ok.
  Proof.
    compile.
  Qed.
End Alloc.

From bedrock2 Require Import BasicC64Semantics NotationsCustomEntry.
Compute nondet_xor_br2fn (word := word).


Require Import Coq.Lists.List.
Require Import Coq.Strings.Ascii.
Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.

Require Import Byte.
Require Import ByteData.
Require Import DiskSubset.
Require Import Fetch.
Require Import File.
Require Import FileData.
Require Import FileIds.
Require Import FileNames.
Require Import StringOps.
Require Import Util.

Local Open Scope bool.
Local Open Scope N.

Fixpoint fromOctalAscii (bytes: list Byte) : Exc N :=
  match bytes with
  | nil => value 0
  | byte :: tl => match (fromOctalAscii tl) with
    | error => error
    | value rest =>
      let byte := Ascii.N_of_ascii byte in
      if (andb (48 <=? byte) (byte <=? 56))
      then value (rest + ((byte - 48)
                          * (8 ^ (N.of_nat (List.length tl)))))
      else error (* Invalid character *)
    end
  end.

Definition parseFileName (tar: File) (offset: N) (disk: Disk): @Fetch string :=
  N.peano_rect
  (fun _ => N -> @Fetch string) (* Signature of recursive calls *)
  (fun (_: N) => Found EmptyString) (* Base case -- empty file *)
  (fun (prev: N) (rec: N -> @Fetch string) (idx: N) =>
    (* Recursive case -- more file remaining *)
    match (tar @[ offset + idx | disk ]) with
    | Found byte =>
      if (ascii_eqb byte Ascii.zero) (* Null *)
      then Found EmptyString
      else match (rec (idx + 1)) with
      | Found rest => Found (String byte rest)
      | MissingAt val => MissingAt val
      | ErrorString val => ErrorString val
      end
    | MissingAt val => MissingAt val
    | ErrorString val => ErrorString val
    end)
  100 0.

Lemma parseFileName_subset:
  forall (sub super: Disk) (tar: File) (offset: N) (val: string),
    sub ⊆ super ->
      parseFileName tar offset sub = Found val ->
        parseFileName tar offset super = Found val.
Proof.
  unfold parseFileName.
  generalize 0.
  apply N.peano_ind with (n := 100).
    simpl; auto.
  intros n H m sub super tar offset val subset H1.
  rewrite N.peano_rect_succ.
  rewrite N.peano_rect_succ in H1.
  destruct (tar @[ offset + m | sub ]) eqn:TarAt;
      [| discriminate H1 | discriminate H1].
  apply fetchByte_subset with (1:=subset) in TarAt.
  rewrite TarAt.
  destruct (ascii_eqb b zero) eqn:IsZero.
  assumption.
  match goal with   (* match helps us reference subterms in the goal *)
    | [ _: match ?peano with _ => _ end = _ |- _] =>
        destruct peano eqn:Hpeano; [| discriminate H1 | discriminate H1]
  end.
  apply H with (1:=subset) in Hpeano. rewrite Hpeano.
  assumption.
Qed.

Lemma parseFileName_fsubset:
  forall (sub super: File) (disk: Disk) (offset: N) (val: string),
    sub f⊆ super ->
      parseFileName sub offset disk = Found val ->
        parseFileName super offset disk = Found val.
Proof.
  unfold parseFileName.
  generalize 0.
  apply N.peano_ind with (n := 100).
    simpl; auto.
  intros n H m sub super disk offset val subset H1.
  rewrite N.peano_rect_succ.
  rewrite N.peano_rect_succ in H1.
  destruct (sub @[ offset + m | disk ]) eqn:TarAt;
      [| discriminate H1 | discriminate H1].
  apply fetchByte_fsubset with (1:=subset) in TarAt.
  rewrite TarAt.
  destruct (ascii_eqb b zero) eqn:IsZero.
  assumption.
  match goal with   (* match helps us reference subterms in the goal *)
    | [ _: match ?peano with _ => _ end = _ |- _] =>
        destruct peano eqn:Hpeano; [| discriminate H1 | discriminate H1]
  end.
  apply H with (1:=subset) in Hpeano. rewrite Hpeano.
  assumption.
Qed.

Definition parseFileSize (tar: File) (offset: N) (disk: Disk): @Fetch N :=
  (tar @[ offset + 124 | disk ]) _fflatmap_ (fun byte0 =>
  (tar @[ offset + 125 | disk ]) _fflatmap_ (fun byte1 =>
  (tar @[ offset + 126 | disk ]) _fflatmap_ (fun byte2 =>
  (tar @[ offset + 127 | disk ]) _fflatmap_ (fun byte3 =>
  (tar @[ offset + 128 | disk ]) _fflatmap_ (fun byte4 =>
  (tar @[ offset + 129 | disk ]) _fflatmap_ (fun byte5 =>
  (tar @[ offset + 130 | disk ]) _fflatmap_ (fun byte6 =>
  (tar @[ offset + 131 | disk ]) _fflatmap_ (fun byte7 =>
  (tar @[ offset + 132 | disk ]) _fflatmap_ (fun byte8 =>
  (tar @[ offset + 133 | disk ]) _fflatmap_ (fun byte9 =>
  (tar @[ offset + 134 | disk ]) _fflatmap_ (fun byte10 =>
    match (fromOctalAscii (byte0 :: byte1 :: byte2 :: byte3
                           :: byte4 :: byte5 :: byte6 :: byte7
                           :: byte8 :: byte9 :: byte10 :: nil)) with
    | error =>
        if ((Byte.eqb byte0 Ascii.zero) && (Byte.eqb byte1 Ascii.zero)
            && (Byte.eqb byte2 Ascii.zero) && (Byte.eqb byte3 Ascii.zero)
            && (Byte.eqb byte4 Ascii.zero) && (Byte.eqb byte5 Ascii.zero)
            && (Byte.eqb byte6 Ascii.zero) && (Byte.eqb byte7 Ascii.zero)
            && (Byte.eqb byte8 Ascii.zero) && (Byte.eqb byte9 Ascii.zero)
            && (Byte.eqb byte10 Ascii.zero))
          (* the last few chunks of the Tar file are full of zeros *)
          then Found 0
          (* something went wrong *)
          else ErrorString "Invalid Tar Size"
    | value size => Found size
    end))))))))))).

Lemma parseFileSize_subset:
  forall (sub super: Disk) (tar: File) (offset val: N),
    sub ⊆ super ->
      parseFileSize tar offset sub = Found val ->
        parseFileSize tar offset super = Found val.
Proof.
  intros sub super tar offset val subset.
  unfold parseFileSize.
  unfold disk_subset in subset.
  repeat (apply found_fflatmap_found_twice; [
    intros ?; apply fetchByte_subset with (1:=subset)
    | intro; intro]).
  intros. assumption.
Qed.

Lemma parseFileSize_fsubset:
  forall (sub super: File) (disk: Disk) (offset val: N),
    sub f⊆ super ->
      parseFileSize sub offset disk = Found val ->
        parseFileSize super offset disk = Found val.
Proof.
  intros sub super tar offset val subset.
  unfold parseFileSize.
  unfold disk_subset in subset.
  repeat (apply found_fflatmap_found_twice; [
    intros ?; apply fetchByte_fsubset with (1:=subset)
    | intro; intro]).
  intros. assumption.
Qed.

Definition parseFileNameAndSize (tar: File) (offset: N)
  (disk: Disk) : @Fetch (string*N) :=
  (parseFileName tar offset disk) _fflatmap_ (fun name =>
  (parseFileSize tar offset disk) _fmap_ (fun size =>
    (name, size)
  )).

Lemma parseFileNameAndSize_subset:
  forall (sub super: Disk) (tar: File) (offset: N) (val: string*N),
    sub ⊆ super ->
      parseFileNameAndSize tar offset sub = Found val ->
        parseFileNameAndSize tar offset super = Found val.
Proof.
  intros sub super tar offset val subset.
  unfold parseFileNameAndSize.
  intros H.
  apply found_fflatmap_found in H. destruct H as [fileName [HfileName H]].
  apply found_fmap_found in H. destruct H as [size [Hsize H]].
  apply parseFileName_subset with (1:=subset) in HfileName.
  rewrite HfileName. unfold fetch_flatmap at 1.
  apply parseFileSize_subset with (1:=subset) in Hsize.
  rewrite Hsize. unfold fetch_map at 1.
  rewrite H. auto.
Qed.

Lemma parseFileNameAndSize_fsubset:
  forall (sub super: File) (disk: Disk) (offset: N) (val: string*N),
    sub f⊆ super ->
      parseFileNameAndSize sub offset disk = Found val ->
        parseFileNameAndSize super offset disk = Found val.
Proof.
  intros sub super tar offset val subset.
  unfold parseFileNameAndSize.
  intros H.
  apply found_fflatmap_found in H. destruct H as [fileName [HfileName H]].
  apply found_fmap_found in H. destruct H as [size [Hsize H]].
  apply parseFileName_fsubset with (1:=subset) in HfileName.
  rewrite HfileName. unfold fetch_flatmap at 1.
  apply parseFileSize_fsubset with (1:=subset) in Hsize.
  rewrite Hsize. unfold fetch_map at 1.
  rewrite H. auto.
Qed.

Definition recFileNameFrom (nextCall: N -> @Fetch (list string))
  (tar: File) (offset: N) (disk: Disk) : @Fetch (list string) :=
  if (tar.(fileSize) <=? offset)
    then Found nil
  else match
    (parseFileNameAndSize tar offset disk) with
    | Found (fileName, fileSize) =>
        (* Strip the next file out of the tar *)
        (* Round to the nearest 512 *)
        let nextFileSize := (
          if (fileSize mod 512 =? 0)
          then fileSize + 512
          else 512 * (2 + (fileSize / 512))) in
        match (nextCall (offset + nextFileSize)) with
        | Found rest => Found (fileName :: rest)
        | MissingAt val => MissingAt val
        | ErrorString val => ErrorString val
        end
    | MissingAt val => MissingAt val
    | ErrorString val => ErrorString val
    end.

Definition parseFileNames (file: File) (disk: Disk): @Fetch (list string) :=
  N.peano_rect
  (fun _ => N -> @Fetch (list string)) (* Signature of recursive calls *)
  (fun (_: N) => Found (nil:(list string))) (* Base case -- empty file *)
  (fun (prev: N) (rec: N -> @Fetch (list string)) (offset: N) =>
    (* Recursive case -- more file remaining *)
    recFileNameFrom rec file offset disk)
  file.(fileSize)
  0.

Lemma parseFileNames_subset:
  forall (sub super: Disk) (file: File) (val: list string),
    sub ⊆ super ->
      parseFileNames file sub = Found val ->
        parseFileNames file super = Found val.
Proof.
  unfold parseFileNames.
  intros sub super file. revert sub super.
  generalize 0.
  apply N.peano_ind with (n := fileSize file).
    simpl; auto.
  intros n H m sub super val subset H1.
  rewrite N.peano_rect_succ.
  rewrite N.peano_rect_succ in H1.
  unfold recFileNameFrom at 1.
  unfold recFileNameFrom at 1 in H1.
  destruct (fileSize file <=? m) eqn:H_fileSize.
    assumption.
  destruct (parseFileNameAndSize file m sub) eqn:H_fileNameAndSize;
    [| discriminate H1 | discriminate H1].
  destruct p as [fileName fileSize].
  apply parseFileNameAndSize_subset with (1:=subset) in H_fileNameAndSize.
  rewrite H_fileNameAndSize.
  destruct (fileSize mod 512 =? 0) eqn:H_fsize_mod_512.
  simpl. simpl in H1.
  match goal with   (* match helps us reference subterms in the goal *)
    | [ _: match ?peano with _ => _ end = _ |- _] =>
        destruct peano eqn:Hpeano; [| discriminate H1 | discriminate H1]
  end.
  apply H with (1:=subset) in Hpeano. rewrite Hpeano.
  assumption.
  cbv zeta. cbv zeta in H1.
  destruct (N.peano_rect (fun _ : N => N -> Fetch) (fun _ : N => Found nil)
                         (fun (_ : N) (rec : N -> Fetch) (offset : N) =>
                         recFileNameFrom rec file offset sub) n
                         (m + 512 * (2 + fileSize / 512))) eqn:Hpeano;
    [|discriminate H1 | discriminate H1].
  apply H with (1:=subset) in Hpeano. rewrite Hpeano.
  assumption.
Qed.

Lemma parseFileNames_fsubset:
  forall (sub super: File) (disk: Disk) (val: list string),
    sub f⊆ super ->
      parseFileNames sub disk = Found val ->
        parseFileNames super disk = Found val.
Proof.
  unfold parseFileNames.
  intros sub super disk val subset.
  revert disk val.
  assert (sub f⊆ super) as subset2; [assumption |].
  unfold file_subset in subset2.
  destruct subset2 as [Hid Heq]. destruct Heq as [HfileSize Heq].
  generalize 0.
  rewrite HfileSize.
  apply N.peano_ind with (n := fileSize super).
    simpl; auto.
  intros n H m disk val H1.
  rewrite N.peano_rect_succ in H1.
  unfold recFileNameFrom at 1 in H1.
  rewrite HfileSize in H1.
  rewrite N.peano_rect_succ.
  unfold recFileNameFrom at 1.
  destruct (fileSize super <=? m) eqn:H_fileSize.
    assumption.
  destruct (parseFileNameAndSize sub m disk) eqn:H_fileNameAndSize;
    [| discriminate H1 | discriminate H1].
  destruct p as [fileName fileSize].
  apply parseFileNameAndSize_fsubset with (1:=subset) in H_fileNameAndSize.
  rewrite H_fileNameAndSize.
  destruct (fileSize mod 512 =? 0) eqn:H_fsize_mod_512.
  simpl. simpl in H1.
  match goal with   (* match helps us reference subterms in the goal *)
    | [ _: match ?peano with _ => _ end = _ |- _] =>
        destruct peano eqn:Hpeano; [| discriminate H1 | discriminate H1]
  end.
  apply H in Hpeano. rewrite Hpeano.
  assumption.
  cbv zeta. cbv zeta in H1.
  destruct (N.peano_rect (fun _ : N => N -> Fetch) (fun _ : N => Found nil)
                         (fun (_ : N) (rec : N -> Fetch) (offset : N) =>
                         recFileNameFrom rec sub offset disk) n
                         (m + 512 * (2 + fileSize / 512))) eqn:Hpeano;
    [|discriminate H1 | discriminate H1].
  apply H in Hpeano. rewrite Hpeano.
  assumption.
Qed.

Definition looksLikeRootkit (file: File) (disk: Disk) :=
  match (parseFileNames file disk) with
  | Found fileNames =>
    exists (filename1 filename2: string),
      filename1 <> filename2
      /\ In filename1 fileNames
      /\ In filename2 fileNames
      /\ (FileNames.systemFile filename1)
      /\ (FileNames.systemFile filename2)
  | _ => False
  end.

Definition looksLikeRootkit_compute (file: File) (disk: Disk)
  (filename1 filename2: string) :=
  match (parseFileNames file disk) with
  | Found fileNames =>
       (negb (string_eqb filename1 filename2))
    && (existsb (string_eqb filename1) fileNames)
    && (existsb (string_eqb filename2) fileNames)
    && (FileNames.systemFile_compute filename1)
    && (FileNames.systemFile_compute filename2)
  | _ => false
  end.

Lemma looksLikeRootkit_reflection (file: File) (disk: Disk)
  (filename1 filename2: string) :
  looksLikeRootkit_compute file disk filename1 filename2 = true
    -> looksLikeRootkit file disk.
Proof.
  intros. unfold looksLikeRootkit_compute in H.
  unfold looksLikeRootkit.
  destruct (parseFileNames file disk); [|discriminate H | discriminate].
  apply Bool.andb_true_iff in H. destruct H.
  apply Bool.andb_true_iff in H. destruct H.
  apply Bool.andb_true_iff in H. destruct H.
  apply Bool.andb_true_iff in H. destruct H.
  exists filename1. exists filename2.
  split.
    compute. intros. apply <- string_eqb_reflection in H4.
    rewrite H4 in H. discriminate H.
  split.
    apply existsb_exists in H3. destruct H3. destruct H3.
    apply string_eqb_reflection in H4. rewrite <- H4 in H3. auto.
  split.
    apply existsb_exists in H2. destruct H2. destruct H2.
    apply string_eqb_reflection in H4. rewrite <- H4 in H2. auto.
  split.
    apply systemFile_reflection. auto.

    apply systemFile_reflection. auto.
Qed.

Lemma looksLikeRootkit_subset:
  forall (sub super: Disk) (file: File),
    sub ⊆ super ->
      looksLikeRootkit file sub ->
        looksLikeRootkit file super.
Proof.
  intros sub super file subset.
  unfold looksLikeRootkit.
  intros H.
  destruct (parseFileNames file sub) eqn:H_parseFileNames.
    apply parseFileNames_subset with (1:=subset) in H_parseFileNames.
    rewrite H_parseFileNames. assumption.
  contradict H.
  contradict H.
Qed.

Lemma looksLikeRootkit_fsubset:
  forall (sub super: File) (disk: Disk),
    sub f⊆ super ->
      looksLikeRootkit sub disk ->
        looksLikeRootkit super disk.
Proof.
  intros sub super disk subset.
  unfold looksLikeRootkit.
  intros H.
  destruct (parseFileNames sub disk) eqn:H_parseFileNames.
    apply parseFileNames_fsubset with (1:=subset) in H_parseFileNames.
    rewrite H_parseFileNames. assumption.
  contradict H.
  contradict H.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              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 INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Correctness proof for constant propagation (processor-dependent part). *)

Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Events.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import ConstpropOp.
Require Import Constprop.

(** * Correctness of the static analysis *)

Section ANALYSIS.

Variable ge: genv.
Variable sp: val.

(** We first show that the dataflow analysis is correct with respect
  to the dynamic semantics: the approximations (sets of values)
  of a register at a program point predicted by the static analysis
  are a superset of the values actually encountered during concrete
  executions.  We formalize this correspondence between run-time values and
  compile-time approximations by the following predicate. *)

Definition val_match_approx (a: approx) (v: val) : Prop :=
  match a with
  | Unknown => True
  | I p => v = Vint p
  | F p => v = Vfloat p
  | L p => v = Vlong p
  | G symb ofs => v = symbol_address ge symb ofs
  | S ofs => v = Val.add sp (Vint ofs)
  | _ => False
  end.

Inductive val_list_match_approx: list approx -> list val -> Prop :=
  | vlma_nil:
      val_list_match_approx nil nil
  | vlma_cons:
      forall a al v vl,
      val_match_approx a v ->
      val_list_match_approx al vl ->
      val_list_match_approx (a :: al) (v :: vl).

Ltac SimplVMA :=
  match goal with
  | H: (val_match_approx (I _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (F _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (L _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (G _ _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (S _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | _ =>
      idtac
  end.

Ltac InvVLMA :=
  match goal with
  | H: (val_list_match_approx nil ?vl) |- _ =>
      inv H
  | H: (val_list_match_approx (?a :: ?al) ?vl) |- _ =>
      inv H; SimplVMA; InvVLMA
  | _ =>
      idtac
  end.

(** We then show that [eval_static_operation] is a correct abstract
  interpretations of [eval_operation]: if the concrete arguments match
  the given approximations, the concrete results match the
  approximations returned by [eval_static_operation]. *)

Lemma eval_static_condition_correct:
  forall cond al vl m b,
  val_list_match_approx al vl ->
  eval_static_condition cond al = Some b ->
  eval_condition cond vl m = Some b.
Proof.
  intros until b.
  unfold eval_static_condition.
  case (eval_static_condition_match cond al); intros;
  InvVLMA; simpl; congruence.
Qed.

Remark shift_symbol_address:
  forall symb ofs n,
  symbol_address ge symb (Int.add ofs n) = Val.add (symbol_address ge symb ofs) (Vint n).
Proof.
  unfold symbol_address; intros. destruct (Genv.find_symbol ge symb); auto.
Qed.

Lemma eval_static_operation_correct:
  forall op al vl m v,
  val_list_match_approx al vl ->
  eval_operation ge sp op vl m = Some v ->
  val_match_approx (eval_static_operation op al) v.
Proof.
  intros until v.
  unfold eval_static_operation.
  case (eval_static_operation_match op al); intros;
  InvVLMA; simpl in *; FuncInv; try subst v; auto.

  destruct (propagate_float_constants tt); simpl; auto.

  rewrite shift_symbol_address; auto.

  rewrite Int.add_commut. rewrite shift_symbol_address. rewrite Val.add_commut. auto.

  rewrite Int.add_commut; auto.

  rewrite Val.add_assoc. rewrite Int.add_commut. auto.

  change (Val.add (Vint n1) (Val.add sp (Vint n2)) = Val.add sp (Vint (Int.add n1 n2))).
  rewrite Val.add_permut. auto.

  rewrite shift_symbol_address; auto.

  rewrite Val.add_assoc; auto.

  unfold symbol_address. destruct (Genv.find_symbol ge s1); auto.

  rewrite Val.sub_add_opp. rewrite Val.add_assoc. simpl. rewrite Int.sub_add_opp. auto.

  destruct (Int.eq n2 Int.zero). inv H0.
  destruct (Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone); inv H0; simpl; auto.
  destruct (Int.eq n2 Int.zero); inv H0; simpl; auto.

  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.
  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.
  destruct (Int.ltu n Int.iwordsize); simpl; auto.
  destruct (Int.ltu n (Int.repr 31)); inv H0. simpl; auto.
  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.

  unfold eval_static_intoffloat. destruct (Float.intoffloat n1); simpl in H0; inv H0.
  simpl; auto.

  destruct (propagate_float_constants tt); simpl; auto.

  unfold eval_static_condition_val, Val.of_optbool.
  destruct (eval_static_condition c vl0) eqn:?.
  rewrite (eval_static_condition_correct _ _ _ m _ H Heqo).
  destruct b; simpl; auto.
  simpl; auto.
Qed.

Lemma eval_static_addressing_correct:
  forall addr al vl v,
  val_list_match_approx al vl ->
  eval_addressing ge sp addr vl = Some v ->
  val_match_approx (eval_static_addressing addr al) v.
Proof.
  intros until v. unfold eval_static_addressing.
  case (eval_static_addressing_match addr al); intros;
  InvVLMA; simpl in *; FuncInv; try subst v; auto.
  rewrite shift_symbol_address; auto.
  rewrite Val.add_assoc. auto.
  repeat rewrite shift_symbol_address. auto.
  fold (Val.add (Vint n1) (symbol_address ge id ofs)).
  repeat rewrite shift_symbol_address. apply Val.add_commut.
  repeat rewrite Val.add_assoc. auto.
  fold (Val.add (Vint n1) (Val.add sp (Vint ofs))).
  rewrite Val.add_permut. decEq. rewrite Val.add_commut. auto.
  rewrite shift_symbol_address. auto.
Qed.

(** * Correctness of strength reduction *)

(** We now show that strength reduction over operators and addressing
  modes preserve semantics: the strength-reduced operations and
  addressings evaluate to the same values as the original ones if the
  actual arguments match the static approximations used for strength
  reduction. *)

Section STRENGTH_REDUCTION.

Variable app: D.t.
Variable rs: regset.
Variable m: mem.
Hypothesis MATCH: forall r, val_match_approx (approx_reg app r) rs#r.

Ltac InvApproxRegs :=
  match goal with
  | [ H: _ :: _ = _ :: _ |- _ ] =>
        injection H; clear H; intros; InvApproxRegs
  | [ H: ?v = approx_reg app ?r |- _ ] =>
        generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs
  | _ => idtac
  end.

Lemma cond_strength_reduction_correct:
  forall cond args vl,
  vl = approx_regs app args ->
  let (cond', args') := cond_strength_reduction cond args vl in
  eval_condition cond' rs##args' m = eval_condition cond rs##args m.
Proof.
  intros until vl. unfold cond_strength_reduction.
  case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVMA.
  rewrite H0. apply Val.swap_cmp_bool.
  rewrite H. auto.
  rewrite H0. apply Val.swap_cmpu_bool.
  rewrite H. auto.
  auto.
Qed.

Lemma make_addimm_correct:
  forall n r,
  let (op, args) := make_addimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.add rs#r (Vint n)) v.
Proof.
  intros. unfold make_addimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst. exists (rs#r); split; auto. destruct (rs#r); simpl; auto; rewrite Int.add_zero; auto.
  exists (Val.add rs#r (Vint n)); auto.
Qed.

Lemma make_shlimm_correct:
  forall n r1 r2,
  rs#r2 = Vint n ->
  let (op, args) := make_shlimm n r1 r2 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shl rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shlimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shl_zero. auto.
  destruct (Int.ltu n Int.iwordsize) eqn:?; intros.
  rewrite Val.shl_rolm; auto. econstructor; split; eauto. auto.
  econstructor; split; eauto. simpl. congruence.
Qed.

Lemma make_shrimm_correct:
  forall n r1 r2,
  rs#r2 = Vint n ->
  let (op, args) := make_shrimm n r1 r2 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shr rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shrimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shr_zero. auto.
  destruct (Int.ltu n Int.iwordsize) eqn:?.
  econstructor; split; eauto. simpl. auto.
  econstructor; split; eauto. simpl. congruence.
Qed.

Lemma make_shruimm_correct:
  forall n r1 r2,
  rs#r2 = Vint n ->
  let (op, args) := make_shruimm n r1 r2 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shru rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shruimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shru_zero. auto.
  destruct (Int.ltu n Int.iwordsize) eqn:?; intros.
  rewrite Val.shru_rolm; auto. econstructor; split; eauto. auto.
  econstructor; split; eauto. simpl. congruence.
Qed.

Lemma make_mulimm_correct:
  forall n r1 r2,
  rs#r2 = Vint n ->
  let (op, args) := make_mulimm n r1 r2 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mul rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_mulimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (Vint Int.zero); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.one; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_one; auto.
  destruct (Int.is_power2 n) eqn:?; intros.
  rewrite (Val.mul_pow2 rs#r1 _ _ Heqo). rewrite Val.shl_rolm.
  econstructor; split; eauto. auto.
  eapply Int.is_power2_range; eauto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_divimm_correct:
  forall n r1 r2 v,
  Val.divs rs#r1 rs#r2 = Some v ->
  rs#r2 = Vint n ->
  let (op, args) := make_divimm n r1 r2 in
  exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_divimm.
  destruct (Int.is_power2 n) eqn:?.
  destruct (Int.ltu i (Int.repr 31)) eqn:?.
  exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence.
  exists v; auto.
  exists v; auto.
Qed.

Lemma make_divuimm_correct:
  forall n r1 r2 v,
  Val.divu rs#r1 rs#r2 = Some v ->
  rs#r2 = Vint n ->
  let (op, args) := make_divuimm n r1 r2 in
  exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_divuimm.
  destruct (Int.is_power2 n) eqn:?.
  econstructor; split. simpl; eauto.
  exploit Int.is_power2_range; eauto. intros RANGE.
  rewrite <- Val.shru_rolm; auto. rewrite H0 in H.
  destruct (rs#r1); simpl in *; inv H.
  destruct (Int.eq n Int.zero); inv H2.
  rewrite RANGE. rewrite (Int.divu_pow2 i0 _ _ Heqo). auto.
  exists v; auto.
Qed.

Lemma make_andimm_correct:
  forall n r,
  let (op, args) := make_andimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.and rs#r (Vint n)) v.
Proof.
  intros; unfold make_andimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (Vint Int.zero); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.mone; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_mone; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_orimm_correct:
  forall n r,
  let (op, args) := make_orimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.or rs#r (Vint n)) v.
Proof.
  intros; unfold make_orimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.mone; intros.
  subst n. exists (Vint Int.mone); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_mone; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_xorimm_correct:
  forall n r,
  let (op, args) := make_xorimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.xor rs#r (Vint n)) v.
Proof.
  intros; unfold make_xorimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.xor_zero; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_mulfimm_correct:
  forall n r1 r2,
  rs#r2 = Vfloat n ->
  let (op, args) := make_mulfimm n r1 r1 r2 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v.
Proof.
  intros; unfold make_mulfimm.
  destruct (Float.eq_dec n (Float.floatofint (Int.repr 2))); intros.
  simpl. econstructor; split. eauto. rewrite H; subst n.
  destruct (rs#r1); simpl; auto. rewrite Float.mul2_add; auto.
  simpl. econstructor; split; eauto.
Qed.

Lemma make_mulfimm_correct_2:
  forall n r1 r2,
  rs#r1 = Vfloat n ->
  let (op, args) := make_mulfimm n r2 r1 r2 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v.
Proof.
  intros; unfold make_mulfimm.
  destruct (Float.eq_dec n (Float.floatofint (Int.repr 2))); intros.
  simpl. econstructor; split. eauto. rewrite H; subst n.
  destruct (rs#r2); simpl; auto. rewrite Float.mul2_add; auto.
  rewrite Float.mul_commut; auto.
  simpl. econstructor; split; eauto.
Qed.

Lemma op_strength_reduction_correct:
  forall op args vl v,
  vl = approx_regs app args ->
  eval_operation ge sp op rs##args m = Some v ->
  let (op', args') := op_strength_reduction op args vl in
  exists w, eval_operation ge sp op' rs##args' m = Some w /\ Val.lessdef v w.
Proof.
  intros until v; unfold op_strength_reduction;
  case (op_strength_reduction_match op args vl); simpl; intros.
(* add *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H1. rewrite Val.add_commut. apply make_addimm_correct.
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_addimm_correct.
(* sub *)
  InvApproxRegs; SimplVMA. inv H0. rewrite H1. econstructor; split; eauto.
  InvApproxRegs; SimplVMA. inv H0. rewrite H. rewrite Val.sub_add_opp. apply make_addimm_correct.
(* mul *)
  InvApproxRegs; SimplVMA. inv H0. rewrite H1. rewrite Val.mul_commut. apply make_mulimm_correct; auto.
  InvApproxRegs; SimplVMA. inv H0. rewrite H. apply make_mulimm_correct; auto.
(* divs *)
  assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
  apply make_divimm_correct; auto.
(* divu *)
  assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
  apply make_divuimm_correct; auto.
(* and *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H1. rewrite Val.and_commut. apply make_andimm_correct.
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_andimm_correct.
(* or *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H1. rewrite Val.or_commut. apply make_orimm_correct.
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_orimm_correct.
(* xor *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H1. rewrite Val.xor_commut. apply make_xorimm_correct.
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_xorimm_correct.
(* shl *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_shlimm_correct; auto.
(* shr *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_shrimm_correct; auto.
(* shru *)
  InvApproxRegs. SimplVMA. inv H0. rewrite H. apply make_shruimm_correct; auto.
(* cmp *)
  generalize (cond_strength_reduction_correct c args0 vl0).
  destruct (cond_strength_reduction c args0 vl0) as [c' args']; intros.
  rewrite <- H1 in H0; auto. econstructor; split; eauto.
(* mulf *)
  inv H0. assert (rs#r2 = Vfloat n2). InvApproxRegs; SimplVMA; auto.
  apply make_mulfimm_correct; auto.
  inv H0. assert (rs#r1 = Vfloat n1). InvApproxRegs; SimplVMA; auto.
  apply make_mulfimm_correct_2; auto.
(* default *)
  exists v; auto.
Qed.

Lemma addr_strength_reduction_correct:
  forall addr args vl,
  vl = approx_regs app args ->
  let (addr', args') := addr_strength_reduction addr args vl in
  eval_addressing ge sp addr' rs##args' = eval_addressing ge sp addr rs##args.
Proof.
  intros until vl. unfold addr_strength_reduction.
  destruct (addr_strength_reduction_match addr args vl); simpl; intros; InvApproxRegs; SimplVMA.
  rewrite H; rewrite H0. rewrite shift_symbol_address. auto.
  rewrite H; rewrite H0. rewrite Int.add_commut. rewrite shift_symbol_address. rewrite Val.add_commut; auto.
  rewrite H; rewrite H0. rewrite Val.add_assoc; auto.
  rewrite H; rewrite H0. rewrite Val.add_permut; auto.
  rewrite H0. auto.
  rewrite H. rewrite Val.add_commut. auto.
  rewrite H0. rewrite Val.add_commut; auto.
  rewrite H; auto.
  rewrite H. rewrite shift_symbol_address. auto.
  rewrite H. rewrite shift_symbol_address. auto.
  rewrite H. rewrite Val.add_assoc. auto.
  auto.
Qed.

End STRENGTH_REDUCTION.

End ANALYSIS.