(* 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 ssrZ ZArith_ext seq_ext machine_int multi_int uniq_tac.
Import MachineInt.
Require Import mips_seplog mips_contrib mips_tactics mapstos.
Require Import multi_lt_prg.

Local Open Scope machine_int_scope.
Import expr_m.
Local Open Scope mips_expr_scope.
Import assert_m.
Local Open Scope mips_assert_scope.
Local Open Scope mips_cmd_scope.
Local Open Scope mips_hoare_scope.
Local Open Scope uniq_scope.
Local Open Scope multi_int_scope.

Section multi_lt.

Variables k a b i flag ret ret2 a0 a1 : reg.

Lemma multi_lt_triple : uniq(k, a, b, i, flag, ret, ret2, a0, a1, r0) ->
  forall nk A B va vb, size A = nk -> size B = nk ->
  {{ fun s h => u2Z [ k ]_s = Z_of_nat nk /\ [ a ]_s = va /\ [ b ]_s = vb /\
     (var_e a |--> A ** var_e b |--> B) s h }}
  multi_lt k a b i flag ret ret2 a0 a1
  {{ fun s h => u2Z [ k ]_s = Z_of_nat nk /\ [ a ]_s = va /\ [ b ]_s = vb /\
    (((\S_{ nk } A < \S_{ nk } B /\ [ret]_s = one32 /\ [ret2]_s = zero32) \/
      (\S_{ nk } A > \S_{ nk } B /\ [ret]_s = zero32 /\ [ret2]_s = one32) \/
      (\S_{ nk } A = \S_{ nk } B /\ [ret]_s = zero32 /\ [ret2]_s = zero32)) /\
    (var_e a |--> A ** var_e b |--> B) s h) }}.
Proof.
move=> Hset nk A B va vb HlenA HlenB.
rewrite /multi_lt.

(** addiu i k zero16 ; *)

apply hoare_addiu with (fun s h => u2Z [k]_s = Z_of_nat nk /\ [a]_s = va /\
  [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\ [i]_s = [k]_s).

move => s h [r_k [r_a [r_b Hmem]]].
rewrite /wp_addiu; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite sext_0 addi0.

(** addiu flag r0 one16 ; *)

apply hoare_addiu with (fun s h => u2Z [k]_s = Z_of_nat nk /\ [a]_s = va /\
  [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\
  [i]_s = [k]_s /\ [flag]_s = one32).

move=> s h [r_k [r_a [r_b [Hmem r_i]]]].
rewrite /wp_addiu; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite add0i sext_Z2u.

(** ifte (beq i r0) *)

apply while.hoare_ifte.

(** addiu ret r0 zero16 *)

apply hoare_addiu with (fun s h => u2Z [k]_s = Z_of_nat nk /\ [a]_s = va /\
  [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\
  [i]_s = [k]_s /\ [flag]_s = one32 /\ [i]_s = zero32 /\ [ret]_s = zero32).

rewrite /wp_addiu => s h [[r_k [r_a [r_b [Hmem [r_i r_flag]]]]] r_i'].
repeat Reg_upd.
have {}r_i' : [i]_s = zero32.
  move/eqP : r_i' => /= /u2Z_inj ->.
  by rewrite store.get_r0.
repeat (split; trivial).
by Assert_upd.
by rewrite sext_Z2u // addi0.

apply hoare_addiu'.
move => s h [r_k [r_a [r_b [Hmem [r_i [r_flag [r_i' r_ret]]]]]]].
rewrite /wp_addiu; repeat Reg_upd; repeat (split; trivial).
- right; right.
  rewrite -r_i r_i' Z2uK // in r_k.
  destruct nk; last by [].
  by rewrite sext_Z2u // addi0.
- by Assert_upd.

(** while (bne flag r0) ( *)

apply hoare_prop_m.hoare_while_invariant with (fun s h => u2Z [k]_s = Z_of_nat nk /\ [a]_s = va /\
  [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\
  exists ni, u2Z [i]_s = Z_of_nat ni /\
    (ni <= nk)%nat /\
    (([flag]_s <> zero32 /\ [i]_s <> zero32 /\
      \S_{ nk - ni } (drop ni A) = \S_{ nk - ni } (drop ni B)) \/
     [flag]_s = zero32 /\
     (([ret]_s = one32 /\ [ret2]_s = zero32 /\
       \S_{ nk - ni } (drop ni A) < \S_{ nk - ni } (drop ni B)) \/
      ([ret]_s = zero32 /\ [ret2]_s = one32 /\
        \S_{ nk - ni } (drop ni A) > \S_{ nk - ni } (drop ni B)) \/
      ([ret]_s = zero32 /\ [i]_s = zero32 /\ [ret2]_s = zero32 /\
       \S_{ nk - ni } (drop ni A) = \S_{ nk - ni } (drop ni B))))).

move=> s h [[r_k [r_a [r_b [Hmem [r_i r_flag]]]]] r_i'].
rewrite /= store.get_r0 Z2uK // in r_i'; move/eqP in r_i'.
repeat (split; trivial).
exists nk; split; first by rewrite r_i r_k.
split => //.
left; split.
- rewrite r_flag; exact: Z2u_dis.
- split.
  + contradict r_i'; by rewrite r_i' Z2uK.
  + by rewrite subnn.

move=> s h [ [r_k [r_a [r_b [Hmem [ni [r_i [Hnink [
  [r_flag [r_ret2 Hsum]] |
  [ r_flag [ [r_ret [r_ret2 Hsum] ] |
  [ [r_ret [r_ret2 Hsum]] |
  [gprret [r_i' [r_ret2 Hsum]]]]]]]]]]]]]] Hneq]; rewrite /= in Hneq.
- have {}Hneq : u2Z [flag]_s = u2Z zero32.
    move/negPn/eqP : Hneq.
    by rewrite store.get_r0.
  apply u2Z_inj in Hneq; contradiction.
- repeat (split; trivial).
  left; split; last by [].
  by eapply lSum_skipn; eauto.
- repeat (split; trivial).
  right; left; split; last by [].
  apply Z.lt_gt.
  apply Z.gt_lt in Hsum.
  by eapply lSum_skipn; eauto.
- repeat (split; trivial).
  right; right; split; last by [].
  have ni_O : ni = O .
    symmetry in r_i; move: r_i.
    rewrite r_i' /zero32 Z2uK //; by move/Z_of_nat_0.
  by rewrite ni_O subn0 !drop0 in Hsum.

(**  addiu i i mone16 ; *)

apply hoare_addiu with (fun s h => u2Z [k]_s = Z_of_nat nk /\ [a]_s = va /\
  [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\
  exists ni, u2Z [i]_s = Z_of_nat ni /\ (ni < nk)%nat /\
    ([flag]_s <> zero32 /\
      \S_{ nk - S ni } (drop (S ni) A) = \S_{ nk - S ni } (drop (S ni) B))).

move=> s h [ [r_k [ r_a [r_b [Hmem [ni [r_i [Hnink [
  [r_flag [r_i' Hsum] ] |
  [ r_flag [ [r_ret Hsum] |
  [ [r_ret Hsum] |
  [r_ret [r_i' Hsum]]]]]]]]]]]]] Hneq]; rewrite /= in Hneq.
- have X : (1 <= ni)%nat.
    apply/ltP/not_ge; contradict r_i'.
    apply u2Z_inj; rewrite r_i Z2uK //.
    apply le_n_0_eq in r_i'; by subst ni.
  rewrite /wp_addiu; repeat Reg_upd; repeat (split; trivial).
  + by Assert_upd.
  + exists (ni - 1)%nat; repeat (split; trivial).
    * rewrite sext_Z2s // u2Z_add_Z2s //.
      rewrite r_i inj_minus1 //; exact/leP.
      rewrite r_i.
      apply (@leZ_trans (1 + -1)); first by [].
      apply leZ_add2r.
      rewrite (_ : 1 = Z_of_nat 1) //; exact/inj_le/leP.
    * destruct ni.
      by move/leP in X; apply le_Sn_0 in X.
      by rewrite /= subn1.
    * by rewrite -subSn //= subn1.
- move/eqP: Hneq; by rewrite r_flag store.get_r0.
- move/eqP: Hneq; by rewrite r_flag store.get_r0.
- move/eqP: Hneq; by rewrite r_flag store.get_r0.

(**  lwxs a0 i a ; *)

apply hoare_lwxs_back_alt'' with (fun s h => u2Z [k]_s = Z_of_nat nk /\
  [a]_s = va /\ [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\
  exists ni, u2Z [i]_s = Z_of_nat ni /\ (ni < nk)%nat /\
    ([flag]_s <> zero32 /\
      \S_{ nk - S ni } (drop (S ni) A) = \S_{ nk - S ni } (drop (S ni) B)) /\
    [a0]_s = A `32_ ni).

move=> s h [r_k [r_a [r_b [Hmem [ni [r_i [ni_nk [r_flag Hsum]]]]]]]].
exists (A `32_ ni); split.
- Decompose_32 A ni A1 A2 HlenA1 HA'; last by rewrite HlenA.
  rewrite HA' (decompose_equiv _ _ _ _ _ HlenA1) !assert_m.conAE assert_m.conCE !assert_m.conAE in Hmem.
  move: Hmem; apply monotony => // h'.
  apply mapsto_ext => //.
  by rewrite /= shl_Z2u r_i inj_mult mulZC.
- rewrite /update_store_lwxs; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.
  by exists ni.

(**  lwxs a1 i b ; *)

apply hoare_lwxs_back_alt'' with (fun s h => u2Z [k]_s = Z_of_nat nk /\
  [a]_s = va /\ [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\
  exists ni, u2Z [i]_s = Z_of_nat ni /\ (ni < nk)%nat /\
    ([flag]_s <> zero32 /\
      \S_{ nk - S ni } (drop (S ni) A) = \S_{ nk - S ni } (drop (S ni) B)) /\
    [a0]_s = A `32_ ni /\ [a1]_s = B `32_ ni).

move=> s h [r_k [r_a [r_b [Hmem [ni [r_i [ni_nk [[r_flag Hsum] r_a0]]]]]]]].
exists (B `32_ ni); split.
- Decompose_32 B ni B1 B2 HlenB1 HB'; last by rewrite HlenB.
  rewrite HB' (decompose_equiv _ _ _ _ _ HlenB1) assert_m.conCE !assert_m.conAE assert_m.conCE !assert_m.conAE in Hmem.
  move: Hmem; apply monotony => // h'.
  apply mapsto_ext => //.
  by rewrite /= shl_Z2u r_i inj_mult mulZC.
- rewrite /update_store_lwxs; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.
  by exists ni.

(**  sltu ret a0 a1 ; *)

apply hoare_sltu with (fun s h => u2Z [k]_s = Z_of_nat nk /\ [a]_s = va /\
  [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\
  exists ni, u2Z [i]_s = Z_of_nat ni /\ (ni < nk)%nat /\
    ([flag]_s <> zero32 /\
      \S_{ nk - S ni } (drop (S ni) A) = \S_{ nk - S ni } (drop (S ni) B)) /\
    [a0]_s = A `32_ ni /\ [a1]_s = B `32_ ni /\
    (([ret]_s = one32 /\ u2Z [a0]_s < u2Z [a1]_s) \/
      ([ret]_s = zero32 /\ u2Z [a0]_s >= u2Z [a1]_s))).

move=> s h [r_k [r_a [r_b [Hmem [ni [r_i [ni_nk [[r_flag Hsum [r_a0 r_a1]]]]]]]]]].
rewrite /wp_sltu; repeat Reg_upd; repeat (split; trivial).
- by Assert_upd.
- exists ni; repeat (split; trivial).
  case: ifP; move/ltZP.
  by move=> ?; left.
  by move/Znot_lt_ge; right.

(**  movn flag r0 ret ; *)

apply hoare_movn with (fun s h => u2Z [k]_s = Z_of_nat nk /\ [a]_s = va /\
  [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\
  exists ni, u2Z [i]_s = Z_of_nat ni /\ (ni < nk)%nat /\
    (\S_{ nk - S ni } (drop (S ni) A) = \S_{ nk - S ni } (drop (S ni) B)) /\
    [a0]_s = A `32_ ni /\ [a1]_s = B `32_ ni /\
    (([ret]_s = one32 /\ [flag]_s = zero32 /\
      u2Z [a0]_s < u2Z [a1]_s) \/
     ([ret]_s = zero32 /\ [flag]_s <> zero32 /\
      u2Z [a0]_s >= u2Z [a1]_s))).

move=> s h [r_k [r_a [r_b [Hmem [ni [r_i [ni_nk [[r_flag HSum]]]]]]]] [r_a0 [r_a1 [ [X1 X2] | [X1 X2]]]]].
- rewrite /wp_movn; repeat Reg_upd; split => Hr_ret.
  + repeat (split; trivial).
    * by Assert_upd.
    * exists ni; repeat (split; trivial); by left.
  + rewrite X1 in Hr_ret.
    have {Hr_ret}: u2Z one32 = u2Z zero32 by rewrite Hr_ret.
    by rewrite ?Z2uK.
- rewrite /wp_movn; repeat Reg_upd; split => Hr_ret.
  + done.
  + repeat (split; trivial).
    exists ni; repeat (split; trivial).
    by right.

(**  sltu ret2 a1 a0 ; *)

apply hoare_sltu with (fun s h => u2Z [k]_s = Z_of_nat nk /\ [a]_s = va /\
  [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\
  exists ni, u2Z [i]_s = Z_of_nat ni /\ (ni < nk)%nat /\
    \S_{ nk - S ni } (drop (S ni) A) = \S_{ nk - S ni } (drop (S ni) B) /\
    [a0]_s = A `32_ ni /\ [a1]_s = B `32_ ni /\
    (([ret]_s = one32 /\ [ret2]_s = zero32 /\
        [flag]_s = zero32 /\ u2Z [a0]_s < u2Z [a1]_s) \/
     ([ret]_s = zero32 /\ [ret2]_s = one32 /\
        [flag]_s <> zero32 /\ u2Z [a0]_s > u2Z [a1]_s) \/
     ([ret]_s = zero32 /\ [ret2]_s = zero32 /\
        [flag]_s <> zero32 /\ u2Z [a0]_s = u2Z [a1]_s))).

move=> s h [r_k [r_a [r_b [Hmem [ni [r_i [ni_nk [Hsum [r_a0 [r_a1 [
  [r_ret [r_flag Hneq] ] |
  [r_ret [r_flag Hneq]]]]]]]]]]]]].
- rewrite /wp_sltu; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.
  exists ni; repeat (split; trivial).
  left; split; first by [].
  rewrite ifF //; apply/negbTE/ltZP; rewrite -leZNgt; exact/ltZW.
- rewrite /wp_sltu; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.
  exists ni; repeat (split; trivial).
  right.
  move/Z.ge_le : Hneq; case/leZ_eqVlt => Hneq.
  * right; repeat (split => //).
    by rewrite Hneq ltZZ'.
  * left; repeat (split; trivial).
    by move/ltZP : Hneq => ->.
    exact/Z.lt_gt.

(**  movn flag r0 ret2 ; *)

apply hoare_movn with (fun s h => u2Z [k]_s = Z_of_nat nk /\ [a]_s = va /\
  [b]_s = vb /\ (var_e a |--> A ** var_e b |--> B) s h /\
  exists ni, u2Z [i]_s = Z_of_nat ni /\ (ni < nk)%nat /\
    \S_{ nk - S ni } (drop (S ni) A) = \S_{ nk - S ni} (drop (S ni) B) /\
    [a0]_s = A `32_ ni /\ [a1]_s = B `32_ ni /\
    (([ret]_s = one32 /\ [ret2]_s = zero32 /\ [flag]_s = zero32 /\ u2Z [a0]_s < u2Z [a1]_s) \/
     ([ret]_s = zero32 /\ [ret2]_s = one32 /\ [flag]_s = zero32 /\ u2Z [a0]_s > u2Z [a1]_s) \/
     ([ret]_s = zero32 /\ [ret2]_s = zero32 /\ [flag]_s <> zero32 /\ u2Z [a0]_s = u2Z [a1]_s))).

move=> s h [r_k [r_a [r_b [Hmem [ni [r_i [ni_nk [Hsum [r_a0 [r_a1 [
[r_ret [r_ret2 [r_flag Hneq] ] ] |
[[r_ret [r_ret2 [r_flag Hneq] ] ] |
[r_ret [r_ret2 [r_flag Hneq]]]]]]]]]]]]]]].
- rewrite /wp_movn; repeat Reg_upd; split=> r_ret2'.
  + by rewrite r_ret2 in r_ret2'.
  + repeat (split; trivial).
    exists ni; repeat (split; trivial).
    by left.
- rewrite /wp_movn; repeat Reg_upd; split=> r_ret2'.
  + repeat (split; trivial).
    by Assert_upd.
    exists ni; repeat (split; trivial).
    by right; left.
  + rewrite r_ret2 in r_ret2'.
    have {r_ret2'} : u2Z one32 = u2Z zero32 by rewrite r_ret2'.
    by rewrite ?Z2uK.
- rewrite /wp_movn; repeat Reg_upd; split => r_ret2'.
  + by rewrite r_ret2 in r_ret2'.
  + repeat (split; trivial).
    exists ni; repeat (split; trivial).
    by right; right.

(**  movz flag r0 i
). *)

apply hoare_movz'.

move=> s h [r_k [r_a [r_b [Hmem [ni [r_i [Hnink [Hsum [r_a0 [r_a1 [ [r_ret [r_ret2 [r_flag Hneq]] ] |
[ [r_ret [r_ret2 [r_flag Hneq]] ] |
[r_ret [r_ret2 [r_flag Hneq] ]]]]]]]]]]]]]].
- rewrite /wp_movz; repeat Reg_upd; split => r_i'.
  + repeat (split; trivial).
    by Assert_upd.
    exists ni; repeat (split; trivial).
    by rewrite ltnW.
    right; split; first by [].
    left; split; first by [].
    have ? : ni = O.
      symmetry in r_i; move: r_i.
      rewrite r_i' Z2uK //; by move/Z_of_nat_0.
    subst ni.
    rewrite subn0 !drop0.
    destruct nk as [|nk].
    * by move: (lt_irrefl O).
    * split; first by [].
      destruct A => //; destruct B => //.
      rewrite /= subn1 /= !drop0 in Hsum.
      rewrite /nth' /= in r_a0 r_a1.
      rewrite 2!lSum_S Hsum -r_a0 -r_a1; exact/ltZ_add2r.
  + repeat (split; trivial).
    exists ni; repeat (split; trivial).
    exact/ltnW.
    right; split; first by [].
    left; split; first by [].
    destruct nk as [|nk].
    * by rewrite ltn0 in Hnink.
    * split; first by []; rewrite /= in Hsum.
      rewrite subSn; last by rewrite -ltnS.
      rewrite (drop_nth zero32); last by rewrite HlenA.
      apply Z.gt_lt.
      rewrite -/(A `32_ ni) -r_a0 lSum_S [drop _ _]/= (drop_nth zero32); last by rewrite HlenB.
      rewrite -/(B `32_ ni) [drop _ _]/= -r_a1 lSum_S Hsum; exact/Z.lt_gt/ltZ_add2r.
- rewrite /wp_movz; repeat Reg_upd; split => r_i'.
  + repeat (split; trivial).
    by Assert_upd.
    exists ni; split; first by [].
    split; first exact/ltnW.
    right; split; first by [].
    right; left; split; first by [].
    have ? : ni = O.
      symmetry in r_i; move: r_i.
      rewrite r_i' Z2uK //; by move/Z_of_nat_0.
    subst ni.
    rewrite /= subn0.
    rewrite /= in Hsum.
    destruct A.
    * rewrite -HlenA in Hnink; by rewrite lt0n in Hnink.
    * destruct B.
      - by rewrite -HlenB in Hnink; rewrite lt0n in Hnink.
      - rewrite /= in Hsum.
        destruct nk.
        + by rewrite ltnn in Hnink.
        + split; first by [].
          rewrite /= subn1 !drop0 in Hsum.
          rewrite /nth' /= in r_a0 r_a1.
          rewrite 2!lSum_S Hsum -r_a0 -r_a1; exact/Z.lt_gt/ltZ_add2r/Z.gt_lt.
  + repeat (split; trivial).
    exists ni; split; trivial.
    split; first exact/ltnW.
    right; split; first by [].
    right; left; split; first by [].
    rewrite /= in Hsum.
    destruct A.
    * rewrite -HlenA in Hnink; by rewrite ltn0 in Hnink.
    * destruct B.
      - rewrite -HlenB in Hnink; by rewrite ltn0 in Hnink.
      - split; first by [].
        rewrite /= in Hsum.
        rewrite (drop_nth zero32); last by rewrite HlenA.
        apply Z.lt_gt.
        rewrite (drop_nth zero32); last by rewrite HlenB.
        have -> : (nk - ni = S (nk - S ni))%nat by rewrite -subSn.
        simpl drop; rewrite 2!lSum_S.
        rewrite Hsum -!/(nth' _ _ _).
        rewrite -r_a0 -r_a1; exact/ltZ_add2r/Z.gt_lt.
- rewrite /wp_movz; repeat Reg_upd; split=> r_i'.
  + repeat (split; trivial).
    by Assert_upd.
    exists ni; split; trivial.
    split; first exact/ltnW.
    right; split; first by [].
    right; right; split; first by [].
    split; first by [].
    have ? : ni = O.
      rewrite r_i' Z2uK // in r_i.
      symmetry in r_i; by move/Z_of_nat_0 : r_i.
    subst ni.
    rewrite /= subn0.
    rewrite /= in Hsum.
    destruct nk => //; destruct A => //; destruct B => //.
    rewrite /= subn1 !drop0 in Hsum.
    rewrite /nth' /= in r_a0 r_a1.
    by rewrite 2!lSum_S Hsum -r_a0 -r_a1 Hneq.
  + repeat (split; trivial).
    exists ni; split; first by [].
    split; first exact/ltnW.
    left; split; first by [].
    split; first by [].
    rewrite /= in Hsum.
    destruct nk as [|nk].
    * by rewrite ltn0 in Hnink.
    * destruct A => //; destruct B => //.
      rewrite /= in Hsum.
      rewrite subSn; last by rewrite -ltnS.
      rewrite (drop_nth zero32); last by rewrite HlenA.
      symmetry.
      rewrite (drop_nth zero32); last by rewrite HlenB.
      rewrite 2!lSum_S Hsum; simpl drop.
      by rewrite -!/(nth' _ _ _) -r_a0 -r_a1 Hneq.
Qed.

End multi_lt.


Require Import Arith.
Require Import ZArith.
Require Import List.
Import ListNotations.

Require Import v1.NeutronTactics.
Require Import v1.Util.
Require Import v1.Multi.

Require Import epics.SpecTypes.
Require Import expr.Expr.

Definition abs_value := option (Z * Z).

(* calc *)
Record calc_abs : Set :=
    CalcAbs {
        calc_A_to_L : multi 12 abs_value;
        calc_VAL : abs_value
    }.

(* calc_out *)
Record calc_out_abs : Set :=
    CalcOutAbs {
        calc_out_A_to_L : multi 12 abs_value;
        calc_out_VAL : abs_value;
        calc_out_PVAL : abs_value;
        calc_out_OVAL : abs_value;
        calc_out_tmp0 : abs_value
    }.

(* str_calc_out *)
Record str_calc_out_abs : Set :=
    StrCalcOutAbs {
        str_calc_out_A_to_L : multi 12 abs_value;
        (* str_calc_out_AA_to_LL : HAVOC; *)
        str_calc_out_VAL : abs_value;
        (* str_calc_out_SVAL : HAVOC; *)
        str_calc_out_PVAL : abs_value;
        str_calc_out_OVAL : abs_value;
        (* str_calc_out_OSV : HAVOC; *)
        str_calc_out_tmp0 : abs_value
    }.

(* array_calc_out *)
Record array_calc_out_abs {n : nat} : Set :=
    ArrayCalcOutAbs {
        array_calc_out_A_to_L : multi 12 abs_value;
        (* array_calc_out_AA_to_LL : HAVOC; *)
        array_calc_out_VAL : abs_value;
        (* array_calc_out_AVAL : HAVOC; *)
        array_calc_out_PVAL : abs_value;
        array_calc_out_OVAL : abs_value;
        (* array_calc_out_OAV : HAVOC; *)
        array_calc_out_tmp0 : abs_value
    }.
Implicit Arguments array_calc_out_abs.

(* fanout *)
Record fanout_abs : Set :=
    FanoutAbs {
    }.

(* ai *)
Record analog_in_abs : Set :=
    AnalogInAbs {
        analog_in_VAL : abs_value
    }.

(* ao *)
Record analog_out_abs : Set :=
    AnalogOutAbs {
        analog_out_VAL : abs_value;
        analog_out_PVAL : abs_value
    }.

(* bi *)
Record binary_in_abs : Set :=
    BinaryInAbs {
        binary_in_VAL : abs_value
    }.

(* bo *)
Record binary_out_abs : Set :=
    BinaryOutAbs {
        binary_out_VAL : abs_value;
    }.

(* mbbo *)
Record mbbo_abs : Set :=
    MBBOAbs {
        mbbo_VAL : abs_value
    }.

(* stringin *)
Record string_in_abs : Set :=
    StringInAbs {
    }.

(* stringout *)
Record string_out_abs : Set :=
    StringOutAbs {
    }.

(* longin *)
Record long_in_abs : Set :=
    LongInAbs {
        long_in_VAL : abs_value
    }.

(* longout *)
Record long_out_abs : Set :=
    LongOutAbs {
        long_out_VAL : abs_value
    }.

(* dfanout *)
Record dfanout_abs : Set :=
    DFanoutAbs {
        dfanout_VAL : abs_value
    }.

(* seq *)
Record seq_abs : Set :=
    SeqAbs {
        seq_DO1_to_DOA : multi 10 abs_value
    }.

(* waveform *)
Record waveform_abs {ty : elem_type} {n : nat} : Set :=
    WaveformAbs {
        (* waveform_VAL : HAVOC *)
    }.
Implicit Arguments waveform_abs.

(* subarray *)
Record subarray_abs {ty : elem_type} {n m : nat} : Set :=
    SubarrayAbs {
        (* subarray_VAL : HAVOC; *)
        (* subarray_tmp0 : HAVOC *)
    }.
Implicit Arguments subarray_abs.

(* asyn *)
Record asyn_abs : Set :=
    AsynAbs {
    }.


Require Export Arith.EqNat.
Require Export Arith.Lt.
Require Export Arith.Compare_dec.
Require Export List.
Require Import String.
Open Scope string_scope.
Require Import TacticsSF.
Require Import TacticsCPDT.
Require Import Process.
Require Import List.
Require Import PrettyPrinter.
Require Import TypeAssignmentPoly.
Require Import ResultBasics.
Require Import ExampleCommon.
Require Import ExampleRecursion.

Lemma abp_recvA_Ack_procR_typing :
  forall i t (xc:free_id) (xerr2:free_id) (xout:free_id),
    ~ In xc ("recv_true" :: "recv_false" :: nil)
    ->
    ~ In xerr2 (xc :: "recv_true" :: "recv_false" :: nil)
    ->
    ~ In xout (xerr2 :: xc :: "recv_true" :: "recv_false" :: nil)
    ->
    (CTX.add (ValVariable (Var (Free xout)), TChannel (SDual (SToks t)))
      (CTX.add (ValVariable (Var (Free xc)), TChannel SEpsilon)
      (CTX.add (ValVariable (Var (Free xerr2)),
        TChannel (SDual (SAck t (token_of_bool (negb i)))))
      (CTX.add (ValName (Nm (Free ("recv_" ++ string_of_bool i))),
        TChannel (SFwd (SRecv i)))
      (CTX.add (ValName (CoNm (Free ("recv_" ++ string_of_bool i))),
        TChannel (SDual (SFwd (SRecv i))))
      (CTX.add (ValName (CoNm (Free ("recv_" ++ string_of_bool (negb i)))),
        TChannel (SDual (SFwd (SRecv (negb i)))))
      CTX.empty))))))
    |-p Var (Free xerr2) !
          Token (if if i then false else true then "true" else "false");
        (New
        (CoNm (Free (String.append "recv_" (if i then "true" else "false")))
          ! Nm (Bound 0);
        (CoNm (Bound 0) ! Var (Free xerr2);
        (CoNm (Bound 0) ! Var (Free xout);
        Zero)))).
Proof.
  intros i t xc xerr2 xout Hxc_nin Hxerr2_nin Hxout_nin.
  (* err2!(1-i); rest *)
  eapply TypPrefixOutput with
      (s:=SDual (SAck t (token_of_bool (negb i))))
      (rho:=TSingleton (token_of_bool (negb i)))
      (t:=SDual (SAck t (token_of_bool (negb i))));
    [apply trdual_w_mdual_involution; constructor; assumption
      | left; discriminate
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | apply LToken; destruct i; ctx_wf; discriminate_w_list
      | right; split; [reflexivity | constructor]
      | reflexivity
      | ].
  (* recv_i(err2, out), i.e. New d *)
  apply TypNew with (s:=SRecv i)
      (L:=xc :: xerr2 :: xout :: "recv_true" :: "recv_false" :: nil);
    intros d G' H_d_nin G'def; compute; subst G'.
  (* d!"recv_i"; rest *)
  eapply TypPrefixOutput with (s:=SDual (SFwd (SRecv i)))
      (rho:=TChannel (SRecv i)) (t:=SDual (SFwd (SRecv i)));
    [apply trdual_w_mdual_involution; constructor
      | left; discriminate
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | left; reflexivity
      | reflexivity
      | ].
  (* d!err2; rest *)
  eapply TypPrefixOutput with (s:=SDual (SRecv i))
      (rho:=TChannel (SDual (SAck t (token_of_bool (negb i)))))
      (t:=SDual (SRecv1 i (SAck t (token_of_bool (negb i))) t));
    [apply trdual_w_mdual_involution; constructor; reflexivity
      | left; discriminate
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | left; reflexivity
      | reflexivity
      | ].
  (* d!out; rest *)
  eapply TypPrefixOutput with
      (s:=SDual (SRecv1 i (SAck t (token_of_bool (negb i))) t))
      (rho:=TChannel (SDual (SToks t)))
      (t:=SDual SEpsilon);
    [apply trdual_w_mdual_involution; constructor; reflexivity
      | left; discriminate
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | constructor; [destruct i; ctx_wf; discriminate_w_list | x_in_G]
      | left; reflexivity
      | reflexivity
      | ].
  (* 0 *)
  apply TypZero;
    destruct i;
    ctx_wf;
    discriminate_w_list.
Qed.


Set Implicit Arguments.

Section ADTValue.

  Variable ADTValue : Type.

  Require Import Coq.Lists.List.

  Require Import Platform.Cito.WordMap.
  Import WordMap.
  Require Import Platform.Cito.WordMapFacts.
  Import FMapNotations.
  Open Scope fmap_scope.

  Require Import Platform.Cito.GeneralTactics4.

  Arguments empty {_}.

  Require Import Platform.Cito.SemanticsUtil.

  Definition make_heap' := fold_right (fun x m => @store_pair ADTValue m x) empty.

  Definition no_clash A (p1 p2 : A * Value ADTValue) :=
    match snd p1, snd p2 with
      | ADT _, ADT _ => (fst p1 <> fst p2)%type
      | _, _ => True
    end.

  Definition no_clash_ls A p := List.Forall (@no_clash A p).

  Definition not_in_heap elt w (v : Value ADTValue) (h : WordMap.t elt) :=
    match v with
      | SCA _ => True
      | ADT _ => ~ WordMap.In w h
    end.

  Require Import Coq.Setoids.Setoid.

  Add Morphism (@store_pair ADTValue) with signature Equal ==> eq ==> Equal as store_pair_Equal_m.
  Proof.
    intros st1 st2 Heq [w v].
    unfold store_pair.
    destruct v.
    eauto.
    simpl.
    rewrite Heq.
    reflexivity.
  Qed.

  Add Parametric Morphism elt : (@not_in_heap elt) with signature eq ==> eq ==> Equal ==> iff as not_in_heap_Equal_m.
  Proof.
    intros w v st1 st2 Heq.
    destruct v; simpl in *.
    intuition.
    rewrite Heq.
    intuition.
  Qed.

  Lemma store_pair_comm p1 p2 h : no_clash p1 p2 -> store_pair (store_pair h p1) p2 == store_pair (store_pair h p2) p1.
  Proof.
    intros Hnc.
    intros p.
    destruct p1 as [w1 v1].
    destruct p2 as [w2 v2].
    unfold store_pair.
    simpl.
    destruct v1 as [? | a1]; destruct v2 as [? | a2]; eauto.
    unfold no_clash in *.
    simpl in *.
    Require Import Bedrock.Word.
    destruct (weq p w2) as [? | Hne2].
    {
      subst.
      rewrite add_eq_o by eauto.
      rewrite add_neq_o by eauto.
      rewrite add_eq_o by eauto.
      eauto.
    }
    rewrite add_neq_o by eauto.
    destruct (weq p w1) as [? | Hne1].
    {
      subst.
      rewrite add_eq_o by eauto.
      rewrite add_eq_o by eauto.
      eauto.
    }
    rewrite add_neq_o by eauto.
    rewrite add_neq_o by eauto.
    rewrite add_neq_o by eauto.
    eauto.
  Qed.

  Definition DisjointPtrs A := List.ForallOrdPairs (@no_clash A).

  Require Import Bedrock.Memory.

  Definition disjoint_ptrs_ls (p : W * Value ADTValue) (pairs : list (W * Value ADTValue)):=
    match (snd p) with
      | SCA _ => True
      | ADT _ => ~ List.In (fst p) (List.map fst (List.filter (fun p => is_adt (snd p)) pairs))
    end.

  Require Import Platform.Cito.Semantics.

  Lemma disjoint_ptrs_cons_elim' pairs : forall p, disjoint_ptrs (p :: pairs) -> disjoint_ptrs_ls p pairs /\ disjoint_ptrs pairs.
  Proof.
    induction pairs; simpl; intros [w1 v1] H.
    {
      split.
      unfold disjoint_ptrs_ls; simpl.
      destruct v1; intuition.
      unfold disjoint_ptrs; simpl.
      econstructor.
    }
    destruct a as [w2 v2]; simpl in *.
    destruct v1 as [? | a1]; destruct v2 as [? | a2]; simpl in *; try solve [unfold disjoint_ptrs, disjoint_ptrs_ls in *; simpl in *; eauto].
    {
      inversion H; subst; clear H.
      split; eauto.
    }
    {
      inversion H; subst; clear H.
      split; eauto.
    }
  Qed.

  Lemma disjoint_ptrs_ls_no_clash_ls pairs : forall p, disjoint_ptrs_ls p pairs -> no_clash_ls p pairs.
  Proof.
    induction pairs; simpl; intros [w1 v1] H.
    {
      econstructor.
    }
    destruct a as [w2 v2]; simpl in *.
    destruct v1 as [? | a1]; destruct v2 as [? | a2]; simpl in *; eauto.
    {
      unfold disjoint_ptrs_ls, no_clash_ls, no_clash in *.
      econstructor.
      eauto.
      eapply Forall_forall.
      intuition.
    }
    {
      unfold disjoint_ptrs_ls, no_clash_ls, no_clash in *.
      econstructor.
      eauto.
      eapply Forall_forall.
      intuition.
    }
    {
      unfold disjoint_ptrs_ls, no_clash_ls, no_clash in *; simpl in *.
      econstructor; simpl in *.
      eauto.
      eapply (IHpairs (w1, ADT a1)); eauto.
    }
    {
      unfold disjoint_ptrs_ls, no_clash_ls, no_clash in *; simpl in *.
      intuition.
      econstructor; simpl in *.
      eauto.
      eapply (IHpairs (w1, ADT a1)); eauto.
    }
  Qed.

  Lemma disjoint_ptrs_cons_elim pairs : forall p, disjoint_ptrs (p :: pairs) -> no_clash_ls p pairs /\ disjoint_ptrs pairs.
    intros p H.
    eapply disjoint_ptrs_cons_elim' in H.
    Require Import Platform.Cito.GeneralTactics.
    openhyp.
    split; eauto.
    eapply disjoint_ptrs_ls_no_clash_ls; eauto.
  Qed.

  Lemma disjoint_ptrs_DisjointPtrs ls : disjoint_ptrs ls -> DisjointPtrs ls.
  Proof.
    induction ls; simpl; intros H.
    {
      econstructor.
    }
    eapply disjoint_ptrs_cons_elim in H.
    openhyp.
    econstructor; eauto.
    eapply IHls; eauto.
  Qed.

  Lemma no_clash_ls_not_in_heap pairs : forall w v, no_clash_ls (w, v) pairs -> not_in_heap w v (make_heap' pairs).
  Proof.
    induction pairs; simpl; intros w v H.
    {
      destruct v; simpl.
      eauto.
      intros Hin.
      eapply empty_in_iff in Hin.
      eauto.
    }
    inversion H; subst.
    destruct a as [w' v'].
    destruct v as [? | a]; simpl in *.
    { eauto. }
    unfold store_pair.
    destruct v' as [? | a']; simpl in *.
    {
      eapply IHpairs in H3.
      simpl in *.
      eauto.
    }
    unfold no_clash in H2; simpl in *.
    intros Hin.
    eapply add_in_iff in Hin.
    destruct Hin as [Hin | Hin].
    {
      subst; intuition.
    }
    eapply IHpairs in H3.
    simpl in *.
    intuition.
  Qed.

  Arguments store_pair {_} _ _.

  Lemma fold_left_store_pair_comm pairs : forall w v h1 h2, no_clash_ls (w, v) pairs -> h2 == store_pair h1 (w, v) -> fold_left store_pair pairs h2 == store_pair (fold_left store_pair pairs h1) (w, v).
  Proof.
    induction pairs; simpl; intros w v h1 h2 Hnin Hh.
    rewrite Hh; reflexivity.
    destruct a as [w' v'].
    inversion Hnin; subst.
    eapply IHpairs; eauto.
    rewrite Hh.
    rewrite store_pair_comm by eauto.
    reflexivity.
  Qed.

  Lemma make_heap_make_heap' pairs : disjoint_ptrs pairs -> make_heap pairs == make_heap' pairs.
  Proof.
    induction pairs; simpl; intros Hdisj.
    reflexivity.
    unfold make_heap in *.
    simpl.
    destruct a as [w v].
    eapply disjoint_ptrs_cons_elim in Hdisj.
    destruct Hdisj as [Hnin Hdisj].
    rewrite <- IHpairs by eauto.
    eapply fold_left_store_pair_comm; eauto.
    reflexivity.
  Qed.

  Add Morphism (@Semantics.word_adt_match ADTValue) with signature Equal ==> eq ==> iff as word_adt_match_Equal_m.
  Proof.
    intros st1 st2 Heq [w v].
    unfold Semantics.word_adt_match.
    simpl.
    destruct v.
    {
      intuition.
    }
    rewrite Heq.
    intuition.
  Qed.

  Arguments word_scalar_match {ADTValue} _.

  Lemma DisjointPtrs_good_scalars_forall_word_adt_match : forall pairs h, DisjointPtrs pairs -> List.Forall word_scalar_match pairs -> List.Forall (word_adt_match (fold_left store_pair pairs h)) pairs.
  Proof.
    induction pairs; simpl; try solve [intuition].
    intros h Hdisj H.
    inversion H; subst.
    inversion Hdisj; subst.
    destruct a as [w v]; simpl in *.
    econstructor.
    {
      rewrite fold_left_store_pair_comm; try reflexivity; trivial.
      unfold word_adt_match.
      unfold Semantics.word_adt_match.
      unfold word_scalar_match in *.
      simpl in *.
      destruct v; simpl in *; trivial.
      unfold store_pair; simpl.
      rewrite add_eq_o by eauto.
      eauto.
    }
    eapply IHpairs; eauto.
  Qed.

  Lemma disjoint_ptrs_good_scalars_good_inputs pairs :
    @disjoint_ptrs ADTValue pairs ->
    good_scalars pairs ->
    good_inputs (make_heap pairs) pairs.
  Proof.
    intros Hdisj Hgs.
    split; eauto.
    eapply DisjointPtrs_good_scalars_forall_word_adt_match; eauto.
    eapply disjoint_ptrs_DisjointPtrs; eauto.
  Qed.

  Lemma good_inputs_add addr (a : ADTValue) h : ~ In addr h -> good_inputs (add addr a h) ((addr, ADT a) :: nil).
  Proof.
    intros Hnin.
    unfold good_inputs.
    unfold Semantics.good_inputs.
    unfold Semantics.disjoint_ptrs.
    unfold Semantics.word_adt_match.
    simpl.
    split.
    - repeat econstructor; simpl.
      rewrite add_eq_o by eauto.
      eauto.
    - repeat econstructor; eauto.
  Qed.

End ADTValue.


(* En este archivo se demuestra la corrección de la acción revokeGroup *)
Require Export Exec.
Require Export Implementacion.
Require Export AuxFunsCorrect.
Require Export ListAuxFuns.
Require Import Classical.
Require Import Estado.
Require Import DefBasicas.
Require Import Semantica.
Require Import Operaciones.
Require Import ErrorManagement.
Require Import Maps.
Require Import Tacticas.
Require Import ValidStateLemmas.

Section RevokeGroup.

Lemma postRevokeGroupCorrect : forall (s:System) (a:idApp) (p:idGrp), (pre (revokePermGroup p a) s) -> validstate s -> post_revokeGroup p a s (revokegroup_post p a s).
Proof.
    intros.
    unfold post_revokeGroup.
    split. simpl; auto.
    simpl in H.
    unfold pre_revokeGroup in H;simpl in H.
    destruct H.

    split.
    destruct H.
    unfold Semantica.revokePermGroup.
    unfold revokegroup_post;unfold revokePermissionGroup;simpl.
    rewrite H.
    split;intros.
    elim (classic (a=a'));intros.
    exists x.

    split.
    rewrite<- H3.
    auto.
    intros.
    rewrite<- H3 in H2.
    rewrite <-(addAndApply idApp_eq a (remove idGrp_eq p x) (grantedPermGroups (state s))) in H2.
    inversion H2.
    rewrite<- H6 in H4.
    apply removeSthElse in H4.
    destruct H4.
    auto.

    exists lGrp'.
    split.
    rewrite overrideNotEq in H2.
    auto.
    auto.
    intros.
    auto.

    split;intros.
    elim (classic (a=a'));intros.
    exists (remove idGrp_eq p x).
    split.
    rewrite H3.
    symmetry.
    apply addAndApply.
    intros.
    split;auto.
    symmetry.
    apply (notInRemove idGrp x g' p idGrp_eq ).
    rewrite H3 in H.
    rewrite H in H2.
    inversion H2.
    auto.
    auto.

    exists lGrp.
    split.
    rewrite overrideNotEq.
    auto.
    auto.
    intros.
    contradiction.
    split.
    exists (remove idGrp_eq p x).
    split.
    symmetry.
    apply addAndApply.
    rewrite <-removeSthElse.
    unfold not;intros.
    destruct H2.
    apply H2;auto.
    apply addPreservesCorrectness.
    apply grantedPermGroupsCorrect;auto.

    split.
  - unfold revokegroup_post. unfold revokeGroupedPerms; simpl.
    assert (exists l : list Perm,
             map_apply idApp_eq (perms (state s)) a = Value idApp l).
    destructVS H0.
    destructSC statesConsistencyVS a.
    destruct H.
    destruct grantedPermGroupsSC. clear H1.
    assert (exists l : list idGrp,
        map_apply idApp_eq (grantedPermGroups (state s)) a = Value idApp l).
    exists x; auto.
    apply H2 in H1.
    apply permsSC in H1. auto.
    repeat split.
 -- intros.
    elim (classic (a=a'));intros.
    rewrite <- H3. destruct H1 as [lPerm H1].
    exists lPerm. split; auto.
    intros. unfold revokeAllPermsOfGroup in H2; rewrite H1 in H2.
    rewrite <- H3 in H2.
    rewrite <- addAndApply in H2.
    inversion H2. clear H2.
    rewrite <- H6 in H4. clear H6.
    induction (getPermsOfGroup p a s).
    simpl in H4. auto.
    simpl in H4. apply removeSthElse in H4.
    destruct H4. apply IHl. auto.

    (* Caso a <> a' *)
    exists lPerm'. destruct H1 as [lPerm H1].
    unfold revokeAllPermsOfGroup in H2. rewrite H1 in H2.
    split.
    apply (overrideNotEq idApp_eq (MyList.removeAll EqTheorems.Perm_eq (getPermsOfGroup p a s) lPerm) (perms (state s))) in H3.
    rewrite <- H3. auto.
    intros; auto.
 -- intros.
    elim (classic (a=a'));intros.
    unfold revokeAllPermsOfGroup.
    rewrite H3. clear H1. rewrite H2.
    exists (MyList.removeAll EqTheorems.Perm_eq (getPermsOfGroup p a' s) lPerm).
    split.
    rewrite <- addAndApply. auto.
    intros. split; auto.

    assert (In p' (getPermsOfGroup p a' s)).
    specialize (notInRemoveAll Perm (getPermsOfGroup p a' s) lPerm p' EqTheorems.Perm_eq H1 H4).
    intros; auto.

    apply (ifInPermsOfGroupThenSome p' p a' s).
    auto.
    exists lPerm. split.
    destruct H1.
    unfold revokeAllPermsOfGroup.
    rewrite H1.
    rewrite overrideNotEq.
    auto. auto.
    intros. contradiction.
 -- destruct H1 as [lPerm H1].
    unfold revokeAllPermsOfGroup. rewrite H1.
    exists (MyList.removeAll EqTheorems.Perm_eq (getPermsOfGroup p a s) lPerm).
    split.

    rewrite <- addAndApply. auto.
    intros. unfold not. intros.
    apply inRemoveAll in H3.
    destruct H3.

    assert (In p0 (getPermsOfGroup p a s)).
    unfold getPermsOfGroup. unfold grantedPermsForApp.
    rewrite H1. clear H1.
    induction lPerm.
    intros. inversion H3.
    simpl in *.
    destruct H3.
    rewrite <- H1 in H2. rewrite H2.
    destruct (idGrp_eq p p).
    simpl. left. auto.
    contradiction.
    apply IHlPerm in H1.
    case_eq (maybeGrp a0); intros.
    simpl. destruct (idGrp_eq p i).
    simpl. right. auto. auto. auto.

    contradiction.
 -- unfold revokeAllPermsOfGroup.
    destruct H1. rewrite H1.
    apply addPreservesCorrectness.
    apply permsCorrect;auto.

  - repeat (split;auto).
Qed.

Lemma notPreRevokeGroupThenError : forall (s:System) (a:idApp) (p:idGrp), ~(pre (revokePermGroup p a) s) -> validstate s -> exists ec : ErrorCode, response (step s (revokePermGroup p a)) = error ec /\ ErrorMsg s (revokePermGroup p a) ec /\ s = system (step s (revokePermGroup p a)).
Proof.
    intros.
    simpl.
    simpl in H.
    unfold pre_revokeGroup in H.
    exists group_wasnt_granted.
    assert (revokegroup_pre p a s=Some group_wasnt_granted).
    unfold revokegroup_pre.
    case_eq (map_apply idApp_eq (grantedPermGroups (state s)) a);intros.
    assert (InBool idGrp idGrp_eq p l=false).
    rewrite<- not_true_iff_false.
    unfold not;intros.
    apply H.
    unfold InBool in H2.
    rewrite existsb_exists in H2.
    destruct H2.
    destruct H2.
    unfold grantedPermsForApp in H2.
    destruct idGrp_eq in H3.
    exists l.
    rewrite e.
    auto.
    discriminate H3.
    rewrite H2;auto.
    auto.
    unfold revokegroup_safe.
    rewrite H1.
    simpl.
    auto.
Qed.

Lemma revokegroupIsSound : forall (s:System) (a:idApp) (p:idGrp),
        validstate s -> exec s (revokePermGroup p a) (system (step s (revokePermGroup p a))) (response (step s (revokePermGroup p a))).
Proof.
    intros.
    unfold exec.
    split.
    auto.
    elim (classic (pre (revokePermGroup p a) s));intro.
    left.
    assert(revokegroup_pre p a s = None).
    unfold revokegroup_pre.
    destruct H0.

    destruct H0.
    rewrite H0.
    assert (InBool idGrp idGrp_eq p x = true).
    unfold InBool.
    rewrite existsb_exists.
    exists p.
    split.
    auto.
    destruct idGrp_eq.
    auto.
    destruct n.
    auto.
    rewrite H2.
    auto.

    unfold step;simpl.
    unfold revokegroup_safe;simpl.
    rewrite H1;simpl.
    split;auto.
    split;auto.
    apply postRevokeGroupCorrect;auto.
    right.
    apply notPreRevokeGroupThenError;auto.

Qed.
End RevokeGroup.


From Coq Require Import Extraction.
From Coq Require Import ZArith.

Extract Inductive nat => "u64" ["0" "__nat_succ"] "__nat_elim!".
Extract Inductive positive => "u64" ["__pos_onebit" "__pos_zerobit" "1"] "__pos_elim!".
Extract Inductive N => "u64" ["0" "__N_frompos"] "__N_elim!".
Extract Inductive Z => "i64" ["0" "__Z_frompos" "__Z_fromneg"] "__Z_elim!".
Extract Inductive comparison =>
  "std::cmp::Ordering"
    ["std::cmp::Ordering::Equal"
     "std::cmp::Ordering::Less"
     "std::cmp::Ordering::Greater"].

Extract Constant BinPosDef.Pos.add => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a.checked_add(b).unwrap() }".
Extract Constant BinPosDef.Pos.succ => "fn ##name##(&'a self, a: u64) -> u64 { a.checked_add(1).unwrap() }".
Extract Constant BinPosDef.Pos.pred => "fn ##name##(&'a self, a: u64) -> u64 { a.checked_sub(1).unwrap_or(1) }".
Extract Constant BinPosDef.Pos.sub => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a.checked_sub(b).unwrap_or(1) }".
Extract Constant BinPosDef.Pos.mul => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a.checked_mul(b).unwrap() }".
Extract Constant BinPosDef.Pos.min => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { std::cmp::min(a, b) }".
Extract Constant BinPosDef.Pos.max => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { std::cmp::max(a, b) }".
Extract Constant BinPosDef.Pos.eqb => "fn ##name##(&'a self, a: u64, b: u64) -> bool { a == b }".
Extract Constant BinPosDef.Pos.compare =>
"fn ##name##(&'a self, a: u64, b: u64) -> std::cmp::Ordering {
  a.cmp(&b)
}".
Extract Constant BinPosDef.Pos.compare_cont =>
"fn ##name##(&'a self, cont: std::cmp::Ordering, a: u64, b: u64) -> std::cmp::Ordering {
  if a < b then
    std::cmp::Ordering::Less
  else if a == b then
    cont
  else
    std::cmp::Ordering::Greater".

Extract Constant BinNatDef.N.add => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a.checked_add(b).unwrap() }".
Extract Constant BinNatDef.N.succ => "fn ##name##(&'a self, a: u64) -> u64 { a.checked_add(1).unwrap() }".
Extract Constant BinNatDef.N.pred => "fn ##name##(&'a self, a: u64) -> u64 { a.checked_sub(1).unwrap_or(0) }".
Extract Constant BinNatDef.N.sub => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a.checked_sub(b).unwrap_or(0) }".
Extract Constant BinNatDef.N.mul => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a.checked_mul(b).unwrap() }".
Extract Constant BinNatDef.N.div => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a.checked_div(b).unwrap_or(0) }".
Extract Constant BinNatDef.N.modulo => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a.checked_rem(b).unwrap_or(a) }".
Extract Constant BinNatDef.N.min => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { std::cmp::min(a, b) }".
Extract Constant BinNatDef.N.max => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { std::cmp::max(a, b) }".
Extract Constant BinNatDef.N.eqb => "fn ##name##(&'a self, a: u64, b: u64) -> bool { a == b }".
Extract Constant BinNatDef.N.compare =>
"fn ##name##(&'a self, a: u64, b: u64) -> std::cmp::Ordering { a.cmp(&b) }".

Extract Constant BinIntDef.Z.add => "fn ##name##(&'a self, a: i64, b: i64) -> i64 { a.checked_add(b).unwrap() }".
Extract Constant BinIntDef.Z.succ => "fn ##name##(&'a self, a: i64) -> i64 { a.checked_add(1).unwrap() }".
Extract Constant BinIntDef.Z.pred => "fn ##name##(&'a self, a: i64) -> i64 { a.checked_sub(1).unwrap() }".
Extract Constant BinIntDef.Z.sub => "fn ##name##(&'a self, a: i64, b: i64) -> i64 { a.checked_sub(b).unwrap() }".
Extract Constant BinIntDef.Z.mul => "fn ##name##(&'a self, a: i64, b: i64) -> i64 { a.checked_mul(b).unwrap() }".
Extract Constant BinIntDef.Z.opp => "fn ##name##(&'a self, a: i64) -> i64 { a.checked_neg().unwrap() }".
Extract Constant BinIntDef.Z.min => "fn ##name##(&'a self, a: i64, b: i64) -> i64 { std::cmp::min(a, b) }".
Extract Constant BinIntDef.Z.max => "fn ##name##(&'a self, a: i64, b: i64) -> i64 { std::cmp::max(a, b) }".
Extract Constant BinIntDef.Z.eqb => "fn ##name##(&'a self, a: i64, b: i64) -> bool { a == b }".
(* TODO: div and modulo are nontrivial since Coq rounds towards negative infinity *)
(*Extract ConstanBinIntDef.t Z.div => "fn ##name##(a: i64, b: i64) -> i64 { a.checked_div(b).unwrap_or(0) }".
Extract Constant BinIntDef.Z.modulo => "fn ##name##(a: i64, b: i64) -> i64 { a.checked_rem(b).unwrap_or(a) }".*)
Extract Constant BinIntDef.Z.compare =>
"fn ##name##(&'a self, a: i64, b: i64) -> std::cmp::Ordering { a.cmp(&b) }".
Extract Constant BinIntDef.Z.of_N =>
"fn ##name##(&'a self, a: u64) -> i64 {
  use std::convert::TryFrom;
  i64::try_from(a).unwrap()
}".
Extract Constant BinIntDef.Z.abs_N => "fn ##name#(&'a self, a: i64) -> u64 { a.unsigned_abs() }".


Require Import Coq.Logic.FunctionalExtensionality Coq.Arith.EqNat Coq.Vectors.Vector Coq.MSets.MSets Names Sets Fun.

Inductive config : Set :=
  | nil : config
  | create : name -> name -> config -> config
  | send : name -> name -> config
  | restrict : name -> config -> config
  | compose : config -> config -> config
  | caseof : name -> list (name * config) -> config
  | instantiate_1 : forall n, name -> Vector.t name n ->
                              name -> config ->
                              name -> Vector.t name n -> config
  | instantiate_2 : forall n, name -> name -> Vector.t name n ->
                              name -> config ->
                              name -> name -> Vector.t name n -> config.

Inductive ConfigName (x : name) : config -> Prop :=
  | send_name_1 : forall y, ConfigName x (send x y)
  | send_name_2 : forall y, ConfigName x (send y x)
  | create_name_1 : forall y p, ConfigName x (create x y p)
  | create_name_2 : forall y p, ConfigName x (create y x p)
  | create_name_p : forall y z p, ConfigName x p -> ConfigName x (create y z p)
  | compose_name_l : forall pl pr, ConfigName x pl -> ConfigName x (compose pl pr)
  | compose_name_r : forall pl pr, ConfigName x pr -> ConfigName x (compose pl pr)
  | restrict_name : forall p, ConfigName x (restrict x p)
  | restrict_name_p : forall y p, ConfigName x p -> ConfigName x (restrict y p)
  | caseof_name : forall l, ConfigName x (caseof x l)
  | caseof_name_h_fst : forall y c l, ConfigName x (caseof y ((x, c) :: l))
  | caseof_name_h_snd : forall y n c l, ConfigName x c -> ConfigName x (caseof y ((n, c) :: l))
  | caseof_name_t : forall y nc l, ConfigName x (caseof y l) -> ConfigName x (caseof y (nc :: l)).

Hint Constructors ConfigName.

Inductive ConfigBoundedName (x : name) : config -> Prop :=
  | create_bounded : forall y p, x <> y -> ConfigBoundedName x (create y x p)
  | create_bounded_p : forall y z p, ConfigBoundedName x p -> x <> y ->
                                     ConfigBoundedName x (create y z p)
  | compose_bounded_b : forall pl pr, ConfigBoundedName x pl ->
                                      ConfigBoundedName x pr ->
                                      ConfigBoundedName x (compose pl pr)
  | compose_bounded_l : forall pl pr, ConfigBoundedName x pl ->
                                      ~ ConfigName x pr ->
                                      ConfigBoundedName x (compose pl pr)
  | compose_bounded_r : forall pl pr, ConfigBoundedName x pr ->
                                      ~ ConfigName x pl ->
                                      ConfigBoundedName x (compose pl pr)
  | restrict_bounded : forall p, ConfigBoundedName x (restrict x p)
  | restrict_bounded_p : forall y p, ConfigBoundedName x p ->
                                     ConfigBoundedName x (restrict y p)
  | caseof_bounded_s : forall y n c l, ConfigBoundedName x c ->
                                       ~ ConfigName x (caseof y l) ->
                                       x <> n ->
                                       ConfigBoundedName x (caseof y ((n, c) :: l))
  | caseof_bounded_h : forall y n c l, ConfigBoundedName x c ->
                                       ConfigBoundedName x (caseof y l) ->
                                       x <> n ->
                                       ConfigBoundedName x (caseof y ((n, c) :: l))
  | caseof_bounded_t : forall y n c l, ConfigBoundedName x (caseof y l) ->
                                       ~ ConfigName x c ->
                                       x <> n ->
                                       ConfigBoundedName x (caseof y ((n, c) :: l)).

  (* | caseof_bounded_s : forall y n c, ConfigBoundedName x c -> *)
  (*                                    x <> y -> *)
  (*                                    x <> n -> *)
  (*                                    ConfigBoundedName x (caseof y ((n, c) :: List.nil)) *)
  (* | caseof_bounded_h : forall y n c l, ConfigBoundedName x c -> *)
  (*                                      ~ ConfigBoundedName x (caseof y l) -> *)
  (* | caseof_bounded_t : forall y n c l, ConfigBoundedName x (caseof y l) -> *)
  (*                                      x <> n -> *)
  (*                                      ConfigBoundedName x (caseof y ((n, c) :: l)) *)
  (* | caseof_bounded : forall y l, Forall (fun nc => ConfigBoundedName x (snd nc)) l -> *)
  (*                                ConfigBoundedName x (caseof y l). *)

Hint Constructors ConfigBoundedName.

Inductive ConfigFreeName (x : name) : config -> Prop :=
  | send_free_1 : forall y, ConfigFreeName x (send x y)
  | send_free_2 : forall y, ConfigFreeName x (send y x)
  | create_free : forall y p, ConfigFreeName x (create x y p)
  | create_free_p : forall y z p, ConfigFreeName x p -> x <> z -> ConfigFreeName x (create y z p)
  | compose_free_l : forall pl pr, ConfigFreeName x pl -> ConfigFreeName x (compose pl pr)
  | compose_free_r : forall pl pr, ConfigFreeName x pr -> ConfigFreeName x (compose pl pr)
  | restrict_free : forall r p, ConfigFreeName x p -> x <> r -> ConfigFreeName x (restrict r p)
  | caseof_free : forall l, ConfigFreeName x (caseof x l)
  | caseof_free_h_fst : forall y c l, ConfigFreeName x (caseof y ((x, c) :: l))
  | caseof_free_h_snd : forall y n c l, ConfigFreeName x c -> ConfigFreeName x (caseof y ((n, c) :: l))
  | caseof_free_t : forall y nc l, ConfigFreeName x (caseof y l) -> ConfigFreeName x (caseof y (nc :: l))
  | instantiate_1_free_x : forall n u v z p y,
                             ConfigFreeName x (instantiate_1 n u v z p x y)
  | instantiate_1_free_y : forall n u v z p x' y,
                             Vector.In x y ->
                             ConfigFreeName x (instantiate_1 n u v z p x' y)
  | instantiate_1_free_p : forall n u v z p x' y,
                             ConfigFreeName x p ->
                             x <> u ->
                             ~ Vector.In x v ->
                             x <> z ->
                             ConfigFreeName x (instantiate_1 n u v z p x' y)
  | instantiate_2_free_x_1 : forall n u1 u2 v z p x2 y,
                               ConfigFreeName x (instantiate_2 n u1 u2 v z p x x2 y)
  | instantiate_2_free_x_2 : forall n u1 u2 v z p x1 y,
                               ConfigFreeName x (instantiate_2 n u1 u2 v z p x1 x y)
  | instantiate_2_free_y : forall n u1 u2 v z p x1 x2 y,
                             Vector.In x y ->
                             ConfigFreeName x (instantiate_2 n u1 u2 v z p x1 x2 y)
  | instantiate_2_free_p : forall n u1 u2 v z p x1 x2 y,
                             ConfigFreeName x p ->
                             x <> u1 ->
                             x <> u2 ->
                             ~ Vector.In x v ->
                             x <> z ->
                             ConfigFreeName x (instantiate_2 n u1 u2 v z p x1 x2 y).

Hint Constructors ConfigFreeName.

(* Lemma config_name_dec : forall x p, {ConfigName x p} + {~ ConfigName x p}. *)
(* Proof. *)
(*   intros. *)
(*   induction p. *)
(*     right; intro. *)
(*     inversion H. *)

(*     inversion IHp. *)
(*       left; auto. *)

(*       destruct (name_dec x n). *)
(*         rewrite e; left; auto. *)

(*         destruct (name_dec x n0). *)
(*           rewrite e; left; auto. *)

(*           right; intro. *)
(*           inversion H0; auto. *)

(*     destruct (name_dec x n). *)
(*       rewrite e; left; auto. *)

(*       destruct (name_dec x n0). *)
(*         rewrite e; left; auto. *)

(*         right; intro. *)
(*         inversion H; auto. *)

(*     destruct (name_dec x n). *)
(*       rewrite e; left; auto. *)

(*       inversion IHp. *)
(*         left; auto. *)

(*         right; intro. *)
(*         inversion H0; auto. *)

(*     inversion IHp1; inversion IHp2. *)
(*       left; auto. *)

(*       left; auto. *)

(*       left; auto. *)

(*       right; intro. *)
(*       inversion H1; auto. *)

(*     destruct (name_dec x n). *)
(*       rewrite e; left; auto. *)

(*       induction l. *)
(*         right; intro. *)
(*         inversion H. *)
(*           apply n0; auto. *)

(*         inversion IHl. *)
(*           left. *)
(*           inversion H; subst. *)
(*             auto. *)

(*             apply caseof_name_t; auto. *)

(*             apply caseof_name_t; auto. *)

(*             apply caseof_name_t; auto. *)

(*           destruct a. *)
(*           destruct (name_dec x n1). *)
(*             left; rewrite e; auto. *)

(*             destruct (config_name_dec x c). *)
(* Qed. *)

(* Lemma config_free_dec : forall x p, {ConfigFreeName x p} + {~ ConfigFreeName x p}. *)
(* Proof. *)
(*   intros. *)
(*   induction p. *)
(*     right; intro; inversion H. *)

(*     destruct (name_dec x n). *)
(*       rewrite e; left; auto. *)
(*       destruct (name_dec x n0). *)
(*         rewrite e; right; intro; inversion H; subst; auto. *)
(*         inversion IHp. *)
(*           left; auto. *)
(*           right; intro; inversion H0; subst; auto. *)

(*     destruct (name_dec x n); destruct (name_dec x n0). *)
(*       rewrite e; auto. *)
(*       rewrite e; auto. *)
(*       rewrite e; auto. *)
(*       right; intro; inversion H; subst; auto. *)

(*     destruct (name_dec x n). *)
(*       rewrite e; right; intro; inversion H; subst; auto. *)
(*       inversion IHp. *)
(*         left; auto. *)
(*         right; intro; inversion H0; subst; auto. *)

(*     inversion_clear IHp1; inversion_clear IHp2. *)
(*       left; auto. *)
(*       left; auto. *)
(*       left; auto. *)
(*       right; intro; inversion H1; subst; auto. *)
(* Qed. *)

(* Lemma config_bounded_prop : forall x p, ConfigBoundedName x p -> ConfigName x p. *)
(* Proof. *)
(*   intros. *)
(*   induction p; inversion H; subst; auto. *)
(* Qed. *)

(* Lemma config_free_prop : forall x p, ConfigFreeName x p -> ConfigName x p. *)
(* Proof. *)
(*   intros. *)
(*   induction p; inversion H; subst; auto. *)
(* Qed. *)

(* Lemma config_name_prop : forall x p, ConfigName x p -> *)
(*                                      (ConfigBoundedName x p <-> ~ ConfigFreeName x p) /\ *)
(*                                      (ConfigFreeName x p <-> ~ ConfigBoundedName x p). *)
(* Proof. *)
(*   intros. *)
(*   induction p. *)
(*     inversion H. *)

(*     inversion H; subst. *)
(*       split; split; intros; try intro. *)
(*         inversion H0; subst; auto. *)

(*         absurd (ConfigFreeName n (create n n0 p)); auto. *)

(*         inversion H1; subst; auto. *)

(*         auto. *)

(*       split; split; intros; try intro. *)
(*         inversion H0; subst; inversion H1; subst; auto. *)

(*         apply create_bounded. *)
(*         intro; subst; apply H0; auto. *)

(*         inversion H0; subst; inversion H1; subst; auto. *)

(*         assert (n <> n0 -> False). *)
(*           intro. *)
(*           apply H0. *)
(*           auto. *)
(*         apply eq_name_double_neg in H1. *)
(*         rewrite H1; auto. *)

(*       apply IHp in H1. *)
(*       inversion_clear H1. *)
(*       split; split; intros; try intro. *)
(*         inversion H1; subst; inversion H3; subst; auto. *)
(*         apply H0 in H6; auto. *)

(*         assert (x <> n). *)
(*           intro; apply H1. *)
(*           rewrite H3; auto. *)
(*         destruct (beq_name x n0) eqn:?. *)
(*           apply beq_name_true_iff in Heqb. *)
(*           rewrite <- Heqb. *)
(*           apply create_bounded; auto. *)

(*           apply beq_name_false_iff in Heqb. *)
(*           apply create_bounded_p. *)
(*             apply H0. *)
(*             intro. *)
(*             apply H1. *)
(*             apply create_free_p; auto. *)

(*             auto. *)

(*         inversion H1; subst; inversion H3; subst; auto. *)
(*         apply H0 in H6; auto. *)

(*         destruct (beq_name x n) eqn:?. *)
(*           apply beq_name_true_iff in Heqb. *)
(*           rewrite Heqb; auto. *)

(*           apply beq_name_false_iff in Heqb. *)
(*           assert (x <> n0). *)
(*             intro. *)
(*             rewrite <- H3 in H1. *)
(*             apply H1. *)
(*             auto. *)
(*           apply create_free_p; auto. *)
(*           apply H2. *)
(*           intro. *)
(*           apply H1. *)
(*           auto. *)

(*     inversion_clear H; subst. *)
(*       split; split; intros; try intro. *)
(*         inversion H. *)

(*         exfalso; apply H; auto. *)

(*         inversion H0. *)

(*         auto. *)
(*       split; split; intros; try intro. *)
(*         inversion H. *)

(*         exfalso; apply H; auto. *)

(*         inversion H0. *)

(*         auto. *)

(*     inversion_clear H; subst. *)
(*       split; split; intros; try intro. *)
(*         inversion H0; auto. *)

(*         auto. *)

(*         inversion H; auto. *)

(*         exfalso; apply H; auto. *)
(*       apply IHp in H0. *)
(*       clear IHp. *)
(*       inversion_clear H0. *)
(*       split; split; intros; try intro. *)
(*         inversion H0; subst; inversion H2; subst; auto. *)
(*         apply H in H4; auto. *)

(*         destruct (beq_name x n) eqn:?. *)
(*           apply beq_name_true_iff in Heqb. *)
(*           rewrite Heqb; auto. *)

(*           apply beq_name_false_iff in Heqb. *)
(*           apply restrict_bounded_p. *)
(*           apply H; intro. *)
(*           apply H0; apply restrict_free; auto. *)

(*         inversion H0; subst; inversion H2; subst; auto. *)
(*         apply H in H4; auto. *)

(*         destruct (beq_name x n) eqn:?. *)
(*           apply beq_name_true_iff in Heqb. *)
(*           rewrite Heqb in H0. *)
(*           exfalso; apply H0; auto. *)

(*           apply beq_name_false_iff in Heqb. *)
(*           apply restrict_free; auto. *)
(*           apply H1. *)
(*           intro. *)
(*           apply H0; auto. *)

(*     inversion_clear H; subst. *)
(*       assert (ConfigName x p1); auto. *)
(*       apply IHp1 in H0. *)
(*       inversion_clear H0. *)
(*       split; split; intros; try intro. *)
(*         inversion_clear H0; subst; inversion_clear H3; subst; auto. *)
(*           apply H1 in H4; auto. *)

(*           assert (ConfigBoundedName x p2); auto. *)
(*           apply config_bounded_prop in H3. *)
(*           apply IHp2 in H3. *)
(*           inversion_clear H3. *)
(*           apply H6 in H5; auto. *)

(*           apply H1 in H0; auto. *)

(*           apply config_free_prop in H0; auto. *)

(*         assert (~ ConfigFreeName x p1 /\ ~ ConfigFreeName x p2). *)
(*           split. *)
(*             intro; apply H0; auto. *)
(*             intro; apply H0; auto. *)
(*         inversion_clear H3. *)
(*         apply H1 in H4. *)
(*         destruct (config_name_dec x p2). *)
(*           apply IHp2 in c. *)
(*           inversion_clear c. *)
(*           apply H3 in H5. *)
(*           auto. *)

(*           auto. *)

(*         inversion H0; subst; inversion H3; subst; auto. *)
(*           apply H1 in H7; auto. *)

(*           apply H1 in H7; auto. *)

(*           assert (ConfigBoundedName x p2); auto. *)
(*           apply config_bounded_prop in H4; apply IHp2 in H4. *)
(*           inversion_clear H4. *)
(*           apply H6 in H8; auto. *)

(*           apply config_free_prop in H5; auto. *)

(*         destruct (config_name_dec x p2). *)
(*           apply IHp2 in c. *)
(*           inversion_clear c. *)
(*           destruct (config_free_dec x p1); auto. *)
(*           destruct (config_free_dec x p2); auto. *)
(*           apply H1 in n. *)
(*           apply H3 in n0. *)
(*           exfalso; apply H0; auto. *)

(*           apply compose_free_l. *)
(*           apply H2. *)
(*           intro. *)
(*           apply H0. *)
(*           auto. *)

(*       assert (ConfigName x p2); auto. *)
(*       apply IHp2 in H0. *)
(*       inversion_clear H0. *)
(*       clear IHp2. *)
(*       split; split; intros; try intro. *)
(*         inversion H0; subst; inversion H3; subst; auto. *)
(*           assert (ConfigBoundedName x p1); auto. *)
(*           apply config_bounded_prop in H4. *)
(*           apply IHp1 in H4. *)
(*           inversion_clear H4. *)
(*           apply H8 in H6; auto. *)

(*           apply H1 in H7; auto. *)

(*           apply config_free_prop in H5; auto. *)

(*           apply H1 in H5; auto. *)

(*         assert (~ ConfigFreeName x p1 /\ ~ ConfigFreeName x p2). *)
(*           split. *)
(*             intro; apply H0; auto. *)
(*             intro; apply H0; auto. *)
(*         inversion_clear H3. *)
(*         apply H1 in H5. *)
(*         destruct (config_name_dec x p1). *)
(*           apply IHp1 in c; inversion_clear c. *)
(*           apply H3 in H4. *)
(*           auto. *)

(*           auto. *)

(*         inversion H0; subst; inversion H3; subst; auto. *)
(*           assert (ConfigBoundedName x p1); auto. *)
(*           apply config_bounded_prop in H4; apply IHp1 in H4; inversion_clear H4. *)
(*           apply H6 in H7; auto. *)

(*           apply config_free_prop in H5; auto. *)

(*           apply H1 in H8; auto. *)

(*           apply H1 in H7; auto. *)

(*         destruct (config_free_dec x p1); auto. *)
(*         destruct (config_free_dec x p2); auto. *)
(*         destruct (config_name_dec x p1). *)
(*           apply IHp1 in c; inversion_clear c. *)
(*           apply H3 in n. *)
(*           apply H1 in n0. *)
(*           exfalso; apply H0; auto. *)

(*           apply compose_free_r. *)
(*           apply H2. *)
(*           intro. *)
(*           apply H0. *)
(*           auto. *)
(* Qed. *)


Require Import
        Coq.Vectors.Vector
        Coq.ZArith.ZArith
        Coq.Strings.Ascii
        Coq.Strings.String
        Coq.Bool.Bool
        Coq.Vectors.Vector
        Coq.Lists.List.

Require Import
        Fiat.Common.BoundedLookup
        Fiat.Common.SumType
        Fiat.Common.EnumType
        Fiat.Narcissus.Formats.DomainNameOpt
        Fiat.QueryStructure.Specification.Representation.Notations
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.QueryStructure.Specification.Representation.Tuple.

Require Import
        Bedrock.Word
        Bedrock.Memory.

Import Lists.List.ListNotations.
Import Vectors.Vector.VectorNotations.

Local Open Scope string_scope.
Local Open Scope Tuple_scope.
Local Open Scope vector_scope.

Require Export Fiat.Narcissus.Examples.DNS.SimpleRRecordTypes.

Section QTypes.

  (* DNS packet Query Types are a superset of RR Types. *)
  Definition QTypes :=
    ["TKEY"; (* Transaction Key 	[RFC2930] *)
     "TSIG"; (* Transaction Signature 	[RFC2845] *)
     "IXFR"; (* incremental transfer 	[RFC1995] *)
     "AXFR"; (* transfer of an entire zone 	[RFC1035][RFC5936] *)
     "MAILB"; (* mailbox-related RRs (MB, MG or MR) 	[RFC1035] *)
     "MAILA"; (* mail agent RRs (OBSOLETE - see MX) 	[RFC1035] *)
     "STAR" (*A request for all records the server/cache has available 	[RFC1035][RFC6895] *)
    ].

  Definition QType_Ws : t (word 16) 11 :=
    Eval simpl in RRecordType_Ws ++ Vector.map (natToWord 16)
                             [249; (*"TKEY" *)
                                250; (*"TSIG" *)
                                251; (*"IXFR" *)
                                252; (*"AXFR" *)
                                253;(*"MAILB" *)
                                254;(*"MAILA" *)
                                255 (* "STAR" *)].

  Definition QType := EnumType ((OurRRecordTypes(* ++ ExtraRRecordTypes) *) ++ QTypes)).

  Definition QType_inj (rr : RRecordType) : QType :=
    Fin.L _ rr.

  Definition beq_QType (a b : QType) : bool :=
    fin_beq a b.

  Definition QType_dec (a b : QType) :=
    fin_eq_dec a b.

  Lemma beq_QType_sym :
    forall rrT rrT', beq_QType rrT rrT' = beq_QType rrT' rrT.
  Proof.
    intros; eapply fin_beq_sym.
  Qed.

  Coercion QType_inj : RRecordType >-> QType.

  Definition QType_match (rtype : RRecordType) (qtype : QType) :=
    qtype = ```"STAR" \/ qtype = rtype.

End QTypes.

Section RRecordClass.

  Definition RRecordClasses :=
    [ "Internet"; (* (IN) 	[RFC1035] *)
        "Chaos"; (* (CH) 	[D. Moon, "Chaosnet", A.I. Memo 628, Massachusetts Institute of Technology Artificial Intelligence Laboratory, June 1981.] *)
        "Hesiod" (* (HS) 	[Dyer, S., and F. Hsu, "Hesiod", Project Athena Technical Plan - Name Service, April 1987.] *)
    ].

  Definition RRecordClass_Ws : t (word 16) 3 :=
    Eval simpl in Vector.map (natToWord 16)
                             [1; (* "IN" *)
                                3; (* "CH" *)
                                4 (* "Hesiod" *)].

  Definition RRecordClass := EnumType RRecordClasses.

  Definition beq_RRecordClass (a b : RRecordClass) : bool
    := fin_beq a b.

  Definition RRecordClass_dec (a b : RRecordClass) :=
    fin_eq_dec a b.

  (* DNS Packet Question Classes *)
  Definition QClass := EnumType (RRecordClasses ++ ["Any"]).

  Definition QClass_Ws : t (word 16) 4 :=
    Eval simpl in Vector.append
                    RRecordClass_Ws
                    [natToWord 16 255 (* "Any"*)].

  Definition QClass_inj (qclass : RRecordClass) : QClass :=
    Fin.L _ qclass.

  Definition beq_QClass (a b : QClass) : bool
    := fin_beq a b.

  Definition QClass_dec (a b : QClass) :=
    fin_eq_dec a b.

End RRecordClass.

Section ResponseCode.

    Definition ResponseCodes :=
    ["NoError";  (* No Error [RFC1035] *)
       "FormErr";  (* Format Error [RFC1035] *)
       "ServFail"; (* Server Failure [RFC1035] *)
       "NXDomain"; (* Non-Existent  Domain 	[RFC1035] *)
       "NotImp";   (* Not Implemented [RFC1035] *)
       "Refused";  (* Query Refused [RFC1035] *)
       "YXDomain"; (* Name Exists when it should not [RFC2136][RFC6672] *)
       "YXRRSet";  (* RR Set Exists when it should not 	[RFC2136] *)
       "NXRRSet";  (* RR Set that should exist does not 	[RFC2136] *)
       "NotAuth";  (* Server Not Authoritative for zone 	[RFC2136] *)
                   (* and Not Authorized [RFC2845] *)
       "NotZone" 	 (* Name not  contained in zone 	[RFC2136] *)
    ].

  Definition RCODE_Ws : t (word 4) 11 :=
    Eval simpl in Vector.map (natToWord 4)
    [0;  (* No Error [RFC1035] *)
     1;  (* Format Error [RFC1035] *)
     2; (* Server Failure [RFC1035] *)
     3; (* Non-Existent  Domain 	[RFC1035] *)
     4;   (* Not Implemented [RFC1035] *)
     5;  (* Query Refused [RFC1035] *)
     6; (* Name Exists when it should not [RFC2136][RFC6672] *)
     7;  (* RR Set Exists when it should not 	[RFC2136] *)
     8;  (* RR Set that should exist does not 	[RFC2136] *)
     9;  (* Server Not Authoritative for zone 	[RFC2136] *)
         (* and Not Authorized [RFC2845] *)
     10 	 (* Name not  contained in zone 	[RFC2136] *)
    ].

  Definition ResponseCode := EnumType ResponseCodes.

  Definition beq_ResponseCode (a b : ResponseCode) : bool
    := fin_beq a b.

  Definition ResponseCode_dec (a b : ResponseCode) :=
    fin_eq_dec a b.
End ResponseCode.

Section OpCode.

  Definition OpCodes :=
    ["Query";    (* RFC1035] *)
     "IQuery"; (* Inverse Query  OBSOLETE) [RFC3425] *)
     "Status"; (* [RFC1035] *)
     "Notify"  (* [RFC1996] [RFC2136] *)
    ].

  Definition OpCode := EnumType OpCodes.

  Definition Opcode_Ws : t (word 4) 4 :=
    Eval simpl in Vector.map (natToWord 4)
                             [0;    (* RFC1035] *)
                              1; (* Inverse Query  OBSOLETE) [RFC3425] *)
                              2; (* [RFC1035] *)
                              4  (* [RFC1996] [RFC2136] *)].

  Definition beq_OpCode (a b : OpCode) : bool
    := fin_beq a b.

  Definition OpCode_dec (a b : OpCode) :=
    fin_eq_dec a b.

End OpCode.

Section Packet.

  (* The question section of a DNS packet. *)
  Definition question :=
    @Tuple <
    "qname" :: DomainName,
    "qtype" :: QType,
    "qclass" :: QClass >%Heading.
  (* ["google", "com"] *)

  (* DNS Resource Records. *)
  Definition sRRecords := "ResourceRecords".
  Definition sNAME := "Name".
  Definition sTTL := "TTL".
  Definition sCLASS := "Class".
  Definition sTYPE := "Type".
  Definition sRDATA := "rdata".
  Definition sRLENGTH := "rlength".

  Definition resourceRecordHeading :=
    < sNAME :: DomainName,
      sTTL :: timeT,
      sCLASS :: RRecordClass,
      sRDATA :: RDataType>%Heading.

  Definition resourceRecord := @Tuple resourceRecordHeading.

  (* Variant headings for each RDataType *)
  Definition VariantResourceRecordHeading RDATAT :=
    < sNAME :: DomainName,
      sTTL :: timeT,
      sCLASS :: RRecordClass,
      sRDATA :: RDATAT >%Heading.

  Definition VariantResourceRecord RDATAT := @Tuple (VariantResourceRecordHeading RDATAT).

  (* Aliases for the Common Record Types *)
  Definition CNAME_Record :=
    VariantResourceRecord ResourceRecordTypeTypes[@ OurCNAME].
  Definition A_Record :=
    VariantResourceRecord ResourceRecordTypeTypes[@ OurA ].
  Definition NS_Record :=
    VariantResourceRecord ResourceRecordTypeTypes[@ OurNS].
  Definition SOA_Record :=
    VariantResourceRecord ResourceRecordTypeTypes[@ OurSOA].

  Definition RRecord2VariantResourceRecord
             (rr : resourceRecord)
    : VariantResourceRecord ResourceRecordTypeTypes[@(SumType_index ResourceRecordTypeTypes (rr!sRDATA))] :=
    < sNAME :: rr!sNAME,
      sTTL :: rr!sTTL,
      sCLASS :: rr!sCLASS,
      sRDATA :: SumType_proj _ (rr!sRDATA)>.

  Definition VariantResourceRecord2RRecord
             {idx}
             (vrr : VariantResourceRecord ResourceRecordTypeTypes[@idx])
    : resourceRecord :=
    < sNAME :: vrr!sNAME,
      sTTL :: vrr!sTTL,
      sCLASS :: vrr!sCLASS,
      sRDATA :: inj_SumType _ idx (vrr!sRDATA)>.

  Definition CNAME_Record2RRecord
             (vrr : CNAME_Record)
    : resourceRecord := VariantResourceRecord2RRecord vrr.
  Definition A_Record2RRecord
             (vrr : A_Record)
    : resourceRecord := VariantResourceRecord2RRecord vrr.
  Definition NS_Record2RRecord
             (vrr : NS_Record)
    : resourceRecord := VariantResourceRecord2RRecord vrr.
  Definition SOA_Record2RRecord
             (vrr : SOA_Record)
    : resourceRecord := VariantResourceRecord2RRecord vrr.

  (* Binary Format of DNS Header:
                              1  1  1  1  1  1
0  1  2  3  4  5  6  7  8  9  0  1  2  3  4  5
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|                      ID                       |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|QR|   Opcode  |AA|TC|RD|RA|   Z    |   RCODE   |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|                    QDCOUNT                    |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|                    ANCOUNT                    |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|                    NSCOUNT                    |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
|                    ARCOUNT                    |
+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+
   *)

  (* DNS Packet Layout:
+---------------------+
|        Header       |
+---------------------+
|       Question      |
+---------------------+
|        Answer       |
+---------------------+
|      Authority      |
+---------------------+
|      Additional     |
+---------------------+
   *)

(* Unique Request IDs *)
Definition ID : Type := word 16.

  Definition packetHeading :=
    < "id" :: ID, (* 16 bit Word. *)
      "QR" :: bool, (* is packet a query (0), or a response (1) *)
      "Opcode" :: OpCode, (* kind of query in packet *)
      "AA" :: bool, (* is responding server authorative *)
      "TC" :: bool, (* is packet truncated *)
      "RD" :: bool, (* are recursive queries desired *)
      "RA" :: bool, (* are recursive queries supported by responding server *)
      "RCODE" :: ResponseCode, (* response code *)
      "question" :: question, (* `list question` in case we can have multiple questions? *)
      "answers" :: list resourceRecord,
      "authority" :: list resourceRecord,
      "additional" :: list resourceRecord >%Heading.

  Definition packet := @Tuple packetHeading.

  Definition buildempty (is_authority : bool)
             (rcode : BoundedIndex ResponseCodes)
             (p : packet) :=
    p ○ [ "AA" ::= is_authority; (* Update Authority field *)
          "QR" ::= true; (* Set response flag to true *)
          "RCODE" ::= ibound (indexb rcode);
          "answers" ::= nil;
          "authority"  ::= nil;
          "additional" ::= nil ].

  (* add a resource record to a packet's answers *)
  Definition add_answer (p : packet) (t : resourceRecord) :=
    p ○ [o !! "answers" / t :: o].

  (* add a resource record authority to a packet's authorities
   (ns = name server). *)
  Definition add_ns (p : packet) (t : resourceRecord) :=
    p ○ [o !! "authority" / t :: o].

  (* combine with above? *)
  Definition add_additional (p : packet) (t : resourceRecord) :=
    p ○ [o !! "additional" / t :: o].

  Definition updateRecords (p : packet) answers' authority' additional' :=
    p ○ ["answers" ::= answers';
           "authority" ::= authority';
           "additional" ::= additional'].

  Definition get_name (r : resourceRecord) := r!sNAME.
  Definition name_length (r : resourceRecord) := String.length (get_name r).

  Definition isQuestion (p : packet) :=
    match p!"answers", p!"authority", p!"additional" with
    | nil, nil, nil => true
    | _, _, _ => false
    end.

  Definition is_empty {A} (l : list A) : bool :=
    match l with
    | nil => true
    | _ => false
    end.

  Lemma is_empty_app {A} :
    forall (l l' : list A),
      is_empty (l ++ l') = andb (is_empty l) (is_empty l').
  Proof.
    induction l; simpl; eauto.
  Qed.

  Definition isAnswer (p : packet) := negb (is_empty (p!"answers")).

  Definition isReferral (p : packet) :=
    is_empty (p!"answers")
             && (negb (is_empty (p!"authority")))
             && (negb (is_empty (p!"additional"))).

  Definition add_answers := List.fold_left add_answer.
  Definition add_nses := List.fold_left add_ns.
  Definition add_additionals := List.fold_left add_additional.

End Packet.

Coercion CNAME_Record2RRecord : CNAME_Record >-> resourceRecord.
Coercion A_Record2RRecord : A_Record >-> resourceRecord.
Coercion NS_Record2RRecord : NS_Record >-> resourceRecord.
Coercion SOA_Record2RRecord : SOA_Record >-> resourceRecord.


Require Export SpecializedCommaCategory ProductCategory.
Require Import Common Notations.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Local Open Scope category_scope.

Section CommaCategory.
  Context `(A : @SpecializedCategory objA).
  Context `(B : @SpecializedCategory objB).
  Context `(C : @SpecializedCategory objC).
  Variable S : SpecializedFunctor A C.
  Variable T : SpecializedFunctor B C.

  Definition CommaCategoryProjection : SpecializedFunctor (S ↓ T) (A * B)
    := Build_SpecializedFunctor (S ↓ T) (A * B)
                                (@projT1 _ _)
                                (fun _ _ m => proj1_sig m)
                                (fun _ _ _ _ _ => eq_refl)
                                (fun _ => eq_refl).
End CommaCategory.

Section SliceCategory.
  Context `(A : @SpecializedCategory objA).

  Local Arguments ComposeFunctors' / .

  Definition ArrowCategoryProjection : SpecializedFunctor (ArrowSpecializedCategory A) A
    := Eval simpl in ComposeFunctors' fst_Functor (CommaCategoryProjection _ (IdentityFunctor A)).

  Definition SliceCategoryOverProjection (a : A) : SpecializedFunctor (A / a) A
    := Eval simpl in ComposeFunctors' fst_Functor (CommaCategoryProjection (IdentityFunctor A) _).

  Definition CosliceCategoryOverProjection (a : A) : SpecializedFunctor (a \ A) A
    := ComposeFunctors' snd_Functor (CommaCategoryProjection _ (IdentityFunctor A)).

  Section Slice_Coslice.
    Context `(C : @SpecializedCategory objC).
    Variable a : C.
    Variable S : SpecializedFunctor A C.

    Section Slice.
      Definition SliceCategoryProjection : SpecializedFunctor (S ↓ a) A
        := Eval simpl in ComposeFunctors' fst_Functor (CommaCategoryProjection S (FunctorFromTerminal C a)).
    End Slice.

    Section Coslice.
      Definition CosliceCategoryProjection : SpecializedFunctor (a ↓ S) A
        := Eval simpl in ComposeFunctors' snd_Functor (CommaCategoryProjection (FunctorFromTerminal C a) S).
      Check CosliceCategoryProjection.
      Eval simpl in SpecializedFunctor (a ↓ S) A.
    End Coslice.
  End Slice_Coslice.
End SliceCategory.