theory Discussion_NCPC
imports "../Observation_Setup" Discussion_Value_Setup "Bounded_Deducibility_Security.Compositional_Reasoning"
begin

subsection \<open>Confidentiality protection from non-PC-members\<close>

text \<open>We verify the following property:

\ \\
A group of users UIDs learn
nothing about the various updates of a paper's discussion
(i.e., about the comments being posted on a paper by the PC members)
(save for the non-existence of any edit)
unless/until a user in UIDs becomes a PC member in the paper's conference having no conflict with that paper
and the conference moves to the discussion phase.

\ \\
\<close>

fun T :: "(state,act,out) trans \<Rightarrow> bool" where
"T (Trans _ _ ou s') =
 (\<exists> uid \<in> UIDs. \<exists> cid.
    PID \<in>\<in> paperIDs s' cid \<and> isPC s' cid uid \<and> pref s' uid PID \<noteq> Conflict \<and> phase s' cid \<ge> disPH
 )"

declare T.simps [simp del]

definition B :: "value list \<Rightarrow> value list \<Rightarrow> bool" where
"B vl vl1 \<equiv> vl \<noteq> []"

interpretation BD_Security_IO where
istate = istate and step = step and
\<phi> = \<phi> and f = f and \<gamma> = \<gamma> and g = g and T = T and B = B
done

lemma reachNT_non_isPC_isChair:
assumes "reachNT s" and "uid \<in> UIDs"
shows
"(PID \<in>\<in> paperIDs s cid \<and> isPC s cid uid \<and> phase s cid \<ge> disPH \<longrightarrow> pref s uid PID = Conflict) \<and>
 (PID \<in>\<in> paperIDs s cid \<and> isChair s cid uid \<and> phase s cid \<ge> disPH \<longrightarrow> pref s uid PID = Conflict)"
  using assms
  apply induct
   apply (auto simp: istate_def)[]
  apply(intro conjI)
  subgoal for trn apply(cases trn, auto simp: T.simps reachNT_reach)[] .
  by (metis T.elims(3) isChair_isPC reachNT_reach reach.Step tgtOf_simps)

lemma T_\<phi>_\<gamma>:
assumes 1: "reachNT s" and 2: "step s a = (ou,s')" "\<phi> (Trans s a ou s')"
shows "\<not> \<gamma> (Trans s a ou s')"
using reachNT_non_isPC_isChair[OF 1] 2 unfolding \<phi>_def2
by (fastforce simp add: uu_defs)

(* major *) lemma eqExcPID_step_out:
assumes s's1': "eqExcPID s s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and sT: "reachNT s" and s1: "reach s1"
and PID: "PID \<in>\<in> paperIDs s cid"
and UIDs: "userOfA a \<in> UIDs"
shows "ou = ou1"
proof-
  note Inv = reachNT_non_isPC_isChair[OF sT UIDs]
  note eqs = eqExcPID_imp[OF s's1']
  note eqs' = eqExcPID_imp1[OF s's1']
  note s = reachNT_reach[OF sT]

  note simps[simp] = c_defs u_defs uu_defs r_defs l_defs Paper_dest_conv eqExcPID_def eeqExcPID_def eqExcD
  note * = step step1 eqs eqs' s s1 PID UIDs paperIDs_equals[OF s] Inv

  show ?thesis
  proof (cases a)
    case (Cact x1)
    then show ?thesis using * by (cases x1) auto
  next
    case (Uact x2)
    then show ?thesis using * by (cases x2) auto
  next
    case (UUact x3)
    then show ?thesis using * by (cases x3) auto
  next
    case (Ract x4)
    show ?thesis
    proof (cases x4)
      case (rMyReview x81 x82 x83 x84)
      then show ?thesis using * Ract by (auto simp add: getNthReview_def)
    next
      case (rReviews x91 x92 x93 x94)
      then show ?thesis using * Ract by (clarsimp; metis eqExcPID_imp2 s's1')
    next
      case (rDis x111 x112 x113 x114)
      then show ?thesis using * Ract by (clarsimp; metis discussion.inject)
    qed (use * Ract in auto)
  next
    case (Lact x5)
    then show ?thesis using * by (cases x5; auto; presburger)
  qed
qed

definition \<Delta>1 :: "state \<Rightarrow> value list \<Rightarrow> state \<Rightarrow> value list \<Rightarrow> bool" where
"\<Delta>1 s vl s1 vl1 \<equiv>
 (\<forall> cid. PID \<in>\<in> paperIDs s cid \<longrightarrow> phase s cid < disPH) \<and> s = s1 \<and> B vl vl1"

(* main difference from the Paper_Confidentiality/Aut_PC: need to assume
that there are means to produce vl1 via iaction when disPH has been reached;
if not, this yields and exit *)
definition \<Delta>2 :: "state \<Rightarrow> value list \<Rightarrow> state \<Rightarrow> value list \<Rightarrow> bool" where
"\<Delta>2 s vl s1 vl1 \<equiv>
 \<exists> cid uid.
    PID \<in>\<in> paperIDs s cid \<and> phase s cid = disPH \<and>
    isPC s cid uid \<and> pref s uid PID \<noteq> Conflict
    \<and> eqExcPID s s1"

definition \<Delta>3 :: "state \<Rightarrow> value list \<Rightarrow> state \<Rightarrow> value list \<Rightarrow> bool" where
"\<Delta>3 s vl s1 vl1 \<equiv>
 \<exists> cid. PID \<in>\<in> paperIDs s cid \<and> phase s cid > disPH \<and> eqExcPID s s1 \<and> vl1 = []"

definition \<Delta>e :: "state \<Rightarrow> value list \<Rightarrow> state \<Rightarrow> value list \<Rightarrow> bool" where
"\<Delta>e s vl s1 vl1 \<equiv>
 vl \<noteq> [] \<and>
 (\<exists> cid. PID \<in>\<in> paperIDs s cid \<and> phase s cid \<ge> disPH \<and>
         \<not> (\<exists> uid. isPC s cid uid \<and> pref s uid PID \<noteq> Conflict)
 )"

lemma init_\<Delta>1:
assumes B: "B vl vl1"
shows "\<Delta>1 istate vl istate vl1"
using B unfolding \<Delta>1_def B_def istate_def by auto

lemma unwind_cont_\<Delta>1: "unwind_cont \<Delta>1 {\<Delta>1,\<Delta>2,\<Delta>e}"
proof(rule, simp)
  let ?\<Delta> = "\<lambda>s vl s1 vl1. \<Delta>1 s vl s1 vl1 \<or> \<Delta>2 s vl s1 vl1 \<or> \<Delta>e s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and "\<Delta>1 s vl s1 vl1"
  hence rs: "reach s" and ss1: "s1 = s" and vl: "vl \<noteq> []"
  and PID_ph: "\<And> cid. PID \<in>\<in> paperIDs s cid \<Longrightarrow> phase s cid < disPH"
  using reachNT_reach unfolding \<Delta>1_def B_def by auto
  show "iaction ?\<Delta> s vl s1 vl1 \<or>
        ((vl = [] \<longrightarrow> vl1 = []) \<and> reaction ?\<Delta> s vl s1 vl1)" (is "?iact \<or> (_ \<and> ?react)")
  proof-
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"  let ?trn1 = "Trans s1 a ou s'"
      assume step: "step s a = (ou, s')" and T: "\<not> T ?trn" and c: "consume ?trn vl vl'"
      have \<phi>: "\<not> \<phi> ?trn"
      proof (cases a)
        case (UUact x3)
        then show ?thesis
          using step PID_ph
          by (cases x3; fastforce simp: uu_defs)
      qed auto
      hence vl': "vl' = vl" using c unfolding consume_def by auto
      show "match ?\<Delta> s s1 vl1 a ou s' vl' \<or> ignore ?\<Delta> s s1 vl1 a ou s' vl'" (is "?match \<or> ?ignore")
      proof-
        have ?match proof
          show "validTrans ?trn1" unfolding ss1 using step by simp
        next
          show "consume ?trn1 vl1 vl1" unfolding consume_def ss1 using \<phi> by auto
        next
          show "\<gamma> ?trn = \<gamma> ?trn1" unfolding ss1 by simp
        next
          assume "\<gamma> ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
        next
          show "?\<Delta> s' vl' s' vl1"
          proof(cases "\<exists> cid. PID \<in>\<in> paperIDs s cid")
            case False note PID = False
            have ph_PID': "\<And> cid. PID \<in>\<in> paperIDs s' cid \<Longrightarrow> phase s' cid < disPH" using PID step rs
            subgoal apply(cases a)
              subgoal for x1 apply(cases x1) apply(fastforce simp: c_defs)+ .
              subgoal for x2 apply(cases x2) apply(fastforce simp: u_defs)+ .
              subgoal for x3 apply(cases x3) apply(fastforce simp: uu_defs)+ .
              by auto
            done
            hence "\<Delta>1 s' vl' s' vl1" unfolding \<Delta>1_def B_def vl' using ph_PID' vl by auto
            thus ?thesis by auto
          next
            case True then obtain CID where PID: "PID \<in>\<in> paperIDs s CID" by auto
            hence ph: "phase s CID < disPH" (is "?ph < _") using PID_ph by auto
            show ?thesis
            proof(cases "phase s' CID < disPH")
              case True note ph' = True
              show ?thesis proof(cases "PID \<in>\<in> paperIDs s' CID")
                case False
                hence "\<Delta>1 s' vl' s' vl1" unfolding \<Delta>1_def B_def vl' using vl ph' apply auto
                by (metis PID paperIDs_mono step)(* safety crucially used *)
                thus ?thesis by auto
              next
                case True
                hence "\<Delta>1 s' vl' s' vl1" unfolding \<Delta>1_def B_def vl' using vl ph' apply auto
                by (metis reach_PairI paperIDs_equals rs step) (* safety crucially used *)
                thus ?thesis by auto
              qed
            next
              case False
              hence ph': "phase s' CID = disPH \<and> PID \<in>\<in> paperIDs s' CID"
              using PID ph step rs
              subgoal apply(cases a)
                subgoal for x1 apply(cases x1) apply(fastforce simp: c_defs)+ .
                subgoal for x2 apply(cases x2) apply(fastforce simp: u_defs)+ .
                subgoal for x3 apply(cases x3) apply(fastforce simp: uu_defs)+ .
              by auto
            done
              show ?thesis
              proof(cases "\<exists>uid. isPC s' CID uid \<and> pref s' uid PID \<noteq> Conflict")
                case True
                hence "\<Delta>2 s' vl' s' vl1" unfolding \<Delta>2_def vl' using vl ph' by auto
                thus ?thesis by auto
              next
                case False
                hence "\<Delta>e s' vl' s' vl1" unfolding \<Delta>e_def vl' using vl ph' by auto
                thus ?thesis by auto
              qed
            qed
          qed
        qed
        thus ?thesis by simp
      qed
    qed
    thus ?thesis using vl by auto
  qed
qed

lemma unwind_cont_\<Delta>2: "unwind_cont \<Delta>2 {\<Delta>2,\<Delta>3,\<Delta>e}"
proof(rule, simp)
  let ?\<Delta> = "\<lambda>s vl s1 vl1. \<Delta>2 s vl s1 vl1 \<or> \<Delta>3 s vl s1 vl1 \<or> \<Delta>e s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and "\<Delta>2 s vl s1 vl1"
  then obtain CID uid where uid: "isPC s CID uid" "pref s uid PID \<noteq> Conflict"
  and rs: "reach s" and ph: "phase s CID = disPH" (is "?ph = _")
  and PID: "PID \<in>\<in> paperIDs s CID" and ss1: "eqExcPID s s1"
  using reachNT_reach unfolding \<Delta>2_def by auto
  hence uid_notin: "uid \<notin> UIDs" using ph reachNT_non_isPC_isChair[OF rsT] by force
  show "iaction ?\<Delta> s vl s1 vl1 \<or>
        ((vl = [] \<longrightarrow> vl1 = []) \<and> reaction ?\<Delta> s vl s1 vl1)" (is "?iact \<or> (_ \<and> ?react)")
  proof(cases vl1)
    case (Cons v1 vl1') note vl1 = Cons
    have uid1: "isPC s1 CID uid" "pref s1 uid PID \<noteq> Conflict"
    using ss1 uid unfolding eqExcPID_def by auto
    define a1 where "a1 \<equiv> UUact (uuDis CID uid (pass s uid) PID v1)"
    obtain s1' ou1 where step1: "step s1 a1 = (ou1,s1')" by (metis prod.exhaust)
    let ?trn1 = "Trans s1 a1 ou1 s1'"
    have s1s1': "eqExcPID s1 s1'" using a1_def step1 UUact_uuDis_step_eqExcPID by auto
    have ss1': "eqExcPID s s1'" using eqExcPID_trans[OF ss1 s1s1'] .
    hence many_s1': "PID \<in>\<in> paperIDs s1' CID" "isPC s1' CID uid"
    "pref s1' uid PID \<noteq> Conflict" "phase s1' CID = disPH"
    "pass s1' uid = pass s uid"
    using uid PID ph unfolding eqExcPID_def by auto
    hence more_s1': "uid \<in>\<in> userIDs s1'" "CID \<in>\<in> confIDs s1'"
    by (metis paperIDs_confIDs reach_PairI roles_userIDs rs1 step1 many_s1'(1))+
    have f: "f ?trn1 = v1" unfolding a1_def by simp
    have rs1': "reach s1'" using rs1 step1 by (auto intro: reach_PairI)
    have ou1: "ou1 = outOK"
    using step1 uid1 ph unfolding a1_def by (auto simp add: uu_defs many_s1' more_s1')
    have ?iact proof
      show "step s1 a1 = (ou1,s1')" by fact
    next
      show \<phi>: "\<phi> ?trn1" using ou1 unfolding a1_def by simp
      thus "consume ?trn1 vl1 vl1'" using f unfolding consume_def vl1 by simp
    next
      show "\<not> \<gamma> ?trn1" by (simp add: a1_def uid_notin)
    next
      have "\<Delta>2 s vl s1' vl1'" unfolding \<Delta>2_def using ph PID ss1' uid by auto
      thus "?\<Delta> s vl s1' vl1'" by simp
    qed
    thus ?thesis by auto
  next
    case Nil note vl1 = Nil
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"
      let ?ph' = "phase s' CID"
      assume step: "step s a = (ou, s')" and T: "\<not> T ?trn" and c: "consume ?trn vl vl'"
      have PID': "PID \<in>\<in> paperIDs s' CID" using PID rs by (metis paperIDs_mono step)
      have uid': "isPC s' CID uid \<and> pref s' uid PID \<noteq> Conflict"
      using uid step rs ph PID pref_Conflict_disPH isPC_persistent by auto
      show "match ?\<Delta> s s1 vl1 a ou s' vl' \<or> ignore ?\<Delta> s s1 vl1 a ou s' vl'" (is "?match \<or> ?ignore")
      proof(cases "\<phi> ?trn")
        case False note \<phi> = False
        have vl: "vl' = vl" using c \<phi> unfolding consume_def by (cases vl) auto
        obtain ou1 and s1' where step1: "step s1 a = (ou1,s1')" by (metis prod.exhaust)
        let ?trn1 = "Trans s1 a ou1 s1'"
        have s's1': "eqExcPID s' s1'" using eqExcPID_step[OF ss1 step step1] .
        have \<phi>1: "\<not> \<phi> ?trn1" using \<phi> unfolding eqExcPID_step_\<phi>[OF ss1 step step1] .
        have ?match proof
          show "validTrans ?trn1" using step1 by simp
        next
          show "consume ?trn1 vl1 vl1" unfolding consume_def using \<phi>1 by auto
        next
          show "\<gamma> ?trn = \<gamma> ?trn1" unfolding ss1 by simp
        next
          assume "\<gamma> ?trn" thus "g ?trn = g ?trn1"
          using eqExcPID_step_out[OF ss1 step step1 rsT rs1 PID] by simp
        next
          show "?\<Delta> s' vl' s1' vl1"
          proof(cases "?ph' = disPH")
            case True
            hence "\<Delta>2 s' vl' s1' vl1" using PID' s's1' uid' unfolding \<Delta>2_def by auto
            thus ?thesis by auto
          next
            case False hence "?ph' > disPH"
            using ph rs step by (metis le_less phase_increases)
            hence "\<Delta>3 s' vl' s1' vl1" using s's1' PID' unfolding \<Delta>3_def vl1 by auto
            thus ?thesis by auto
          qed
        qed
        thus ?thesis by simp
      next
        case True note \<phi> = True
        have s's: "eqExcPID s' s" using eqExcPID_sym[OF \<phi>_step_eqExcPID[OF \<phi> step]] .
        have s's1: "eqExcPID s' s1" using eqExcPID_trans[OF s's ss1] .
        have ?ignore proof
          show "\<not> \<gamma> ?trn" using T_\<phi>_\<gamma> \<phi> rsT step by auto
        next
          show "?\<Delta> s' vl' s1 vl1"
          proof(cases "?ph' = disPH")
            case True
            hence "\<Delta>2 s' vl' s1 vl1" using s's1 PID' uid' unfolding \<Delta>2_def by auto
            thus ?thesis by auto
          next
            case False hence "?ph' > disPH"
            using ph rs step by (metis le_less phase_increases)
            hence "\<Delta>3 s' vl' s1 vl1" using s's1 PID' unfolding \<Delta>3_def vl1 by auto
            thus ?thesis by auto
          qed
        qed
        thus ?thesis by auto
      qed
    qed
    thus ?thesis using vl1 by auto
  qed
qed

lemma unwind_cont_\<Delta>3: "unwind_cont \<Delta>3 {\<Delta>3,\<Delta>e}"
proof(rule, simp)
  let ?\<Delta> = "\<lambda>s vl s1 vl1. \<Delta>3 s vl s1 vl1 \<or> \<Delta>e s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and "\<Delta>3 s vl s1 vl1"
  then obtain CID where rs: "reach s" and ph: "phase s CID > disPH" (is "?ph < _")
  and PID: "PID \<in>\<in> paperIDs s CID"
  and ss1: "eqExcPID s s1" and vl1: "vl1 = []"
  using reachNT_reach unfolding \<Delta>3_def by auto
  show "iaction ?\<Delta> s vl s1 vl1 \<or>
        ((vl = [] \<longrightarrow> vl1 = []) \<and> reaction ?\<Delta> s vl s1 vl1)" (is "?iact \<or> (_ \<and> ?react)")
  proof-
    have "?react"
    proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"
      let ?ph' = "phase s' CID"
      assume step: "step s a = (ou, s')" and T: "\<not> T ?trn" and c: "consume ?trn vl vl'"
      have PID': "PID \<in>\<in> paperIDs s' CID" using PID rs by (metis paperIDs_mono step)
      have ph': "phase s' CID > disPH" using ph rs by (meson less_le_trans local.step phase_increases)
      show "match ?\<Delta> s s1 vl1 a ou s' vl' \<or> ignore ?\<Delta> s s1 vl1 a ou s' vl'" (is "?match \<or> ?ignore")
      proof-
        have \<phi>: "\<not> \<phi> ?trn" using ph step unfolding \<phi>_def2 apply (auto simp: uu_defs)
        using PID less_not_refl2 paperIDs_equals rs by blast (* safety crucialy used *)
        have vl: "vl' = vl" using c \<phi> unfolding consume_def by (cases vl) auto
        obtain ou1 and s1' where step1: "step s1 a = (ou1,s1')" by (metis prod.exhaust)
        let ?trn1 = "Trans s1 a ou1 s1'"
        have s's1': "eqExcPID s' s1'" using eqExcPID_step[OF ss1 step step1] .
        have \<phi>1: "\<not> \<phi> ?trn1" using \<phi> unfolding eqExcPID_step_\<phi>[OF ss1 step step1] .
        have ?match proof
          show "validTrans ?trn1" using step1 by simp
        next
          show "consume ?trn1 vl1 vl1" unfolding consume_def using \<phi>1 by auto
        next
          show "\<gamma> ?trn = \<gamma> ?trn1" unfolding ss1 by simp
        next
          assume "\<gamma> ?trn" thus "g ?trn = g ?trn1"
          using eqExcPID_step_out[OF ss1 step step1 rsT rs1 PID] by simp
        next
          have "\<Delta>3 s' vl' s1' vl1" using ph' PID' s's1' unfolding \<Delta>3_def vl1 by auto
          thus "?\<Delta> s' vl' s1' vl1" by simp
        qed
        thus ?thesis by simp
      qed
    qed
    thus ?thesis using vl1 by simp
  qed
qed

(* Exit arguments: *)
definition K1exit where
"K1exit cid s \<equiv>
 (PID \<in>\<in> paperIDs s cid \<and> phase s cid \<ge> disPH \<and>
  \<not> (\<exists> uid. isPC s cid uid \<and> pref s uid PID \<noteq> Conflict))"

lemma invarNT_K1exit: "invarNT (K1exit cid)"
unfolding invarNT_def apply (safe dest!: reachNT_reach)
  subgoal for _ a apply(cases a)
    subgoal for x1 apply(cases x1) apply (fastforce simp add: c_defs K1exit_def geq_noPH_confIDs)+ .
    subgoal for x2
      apply(cases x2)
            apply (fastforce simp add: u_defs K1exit_def paperIDs_equals)
           apply (fastforce simp add: u_defs K1exit_def paperIDs_equals)
          apply (fastforce simp add: u_defs K1exit_def paperIDs_equals)
         apply (fastforce simp add: u_defs K1exit_def paperIDs_equals)
        apply (fastforce simp add: u_defs K1exit_def paperIDs_equals)
        subgoal for x61 apply(cases "x61 = cid")
           apply (fastforce simp add: u_defs K1exit_def paperIDs_equals)+ .
        apply (fastforce simp add: u_defs K1exit_def paperIDs_equals) .
    subgoal for x3 apply(cases x3) apply (fastforce simp add: uu_defs K1exit_def)+ .
    by auto
  done

lemma noVal_K1exit: "noVal (K1exit cid) v"
apply(rule no\<phi>_noVal)
unfolding no\<phi>_def apply safe
  subgoal for _ a apply(cases a)
        apply (fastforce simp add: c_defs K1exit_def)
       apply (fastforce simp add: c_defs K1exit_def)
    subgoal for x3
      apply(cases x3) apply (auto simp add: uu_defs K1exit_def)
      apply (metis paperIDs_equals reachNT_reach) (* crucial use of safety *) .
    by auto
  done

lemma unwind_exit_\<Delta>e: "unwind_exit \<Delta>e"
proof
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and \<Delta>e: "\<Delta>e s vl s1 vl1"
  hence vl: "vl \<noteq> []" using reachNT_reach unfolding \<Delta>e_def by auto
  then obtain CID where "K1exit CID s" using \<Delta>e unfolding K1exit_def \<Delta>e_def by auto
  thus "vl \<noteq> [] \<and> exit s (hd vl)" apply(simp add: vl)
  by (metis rsT exitI2 invarNT_K1exit noVal_K1exit)
qed

theorem secure: secure
apply(rule unwind_decomp3_secure[of \<Delta>1 \<Delta>2 \<Delta>e \<Delta>3])
using
init_\<Delta>1
unwind_cont_\<Delta>1 unwind_cont_\<Delta>2 unwind_cont_\<Delta>3
unwind_exit_\<Delta>e
by auto

end


(*  Title:      HOL/Auth/n_mutualEx_lemma_inv__3_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_mutualEx Protocol Case Study*}

theory n_mutualEx_lemma_inv__3_on_rules imports n_mutualEx_lemma_on_inv__3
begin
section{*All lemmas on causal relation between inv__3*}
lemma lemma_inv__3_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__3  p__Inv0 p__Inv1)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Crit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Exit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Idle  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_TryVsinv__3) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Crit  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_CritVsinv__3) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Exit  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_ExitVsinv__3) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Idle  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_IdleVsinv__3) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


(*  Title:      HOL/Auth/n_mutualExOnI_lemma_inv__4_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_mutualExOnI Protocol Case Study*}

theory n_mutualExOnI_lemma_inv__4_on_rules imports n_mutualExOnI_lemma_on_inv__4
begin
section{*All lemmas on causal relation between inv__4*}
lemma lemma_inv__4_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__4  p__Inv0 p__Inv1)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Crit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Exit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Idle  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_TryVsinv__4) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Crit  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_CritVsinv__4) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Exit  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_ExitVsinv__4) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Idle  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_IdleVsinv__4) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


(*  Title:      JinjaDCI/J/WellTypeRT.thy

    Author:     Tobias Nipkow, Susannah Mansky
    Copyright   2003 Technische Universitaet Muenchen, 2019-20 UIUC

    Based on the Jinja theory J/WellTypeRT.thy by Tobias Nipkow
*)

section \<open> Runtime Well-typedness \<close>

theory WellTypeRT
imports WellType
begin

inductive
  WTrt :: "J_prog \<Rightarrow> heap \<Rightarrow> sheap \<Rightarrow> env \<Rightarrow> expr \<Rightarrow> ty \<Rightarrow> bool"
  and WTrts :: "J_prog \<Rightarrow> heap \<Rightarrow> sheap \<Rightarrow> env \<Rightarrow> expr list \<Rightarrow> ty list \<Rightarrow> bool"
  and WTrt2 :: "[J_prog,env,heap,sheap,expr,ty] \<Rightarrow> bool"
        ("_,_,_,_ \<turnstile> _ : _"   [51,51,51,51]50)
  and WTrts2 :: "[J_prog,env,heap,sheap,expr list, ty list] \<Rightarrow> bool"
        ("_,_,_,_ \<turnstile> _ [:] _" [51,51,51,51]50)
  for P :: J_prog and h :: heap and sh :: sheap
where

  "P,E,h,sh \<turnstile> e : T \<equiv> WTrt P h sh E e T"
| "P,E,h,sh \<turnstile> es[:]Ts \<equiv> WTrts P h sh E es Ts"

| WTrtNew:
  "is_class P C  \<Longrightarrow>
  P,E,h,sh \<turnstile> new C : Class C"

| WTrtCast:
  "\<lbrakk> P,E,h,sh \<turnstile> e : T; is_refT T; is_class P C \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile> Cast C e : Class C"

| WTrtVal:
  "typeof\<^bsub>h\<^esub> v = Some T \<Longrightarrow>
  P,E,h,sh \<turnstile> Val v : T"

| WTrtVar:
  "E V = Some T  \<Longrightarrow>
  P,E,h,sh \<turnstile> Var V : T"

| WTrtBinOpEq:
  "\<lbrakk> P,E,h,sh \<turnstile> e\<^sub>1 : T\<^sub>1;  P,E,h,sh \<turnstile> e\<^sub>2 : T\<^sub>2 \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile> e\<^sub>1 \<guillemotleft>Eq\<guillemotright> e\<^sub>2 : Boolean"

| WTrtBinOpAdd:
  "\<lbrakk> P,E,h,sh \<turnstile> e\<^sub>1 : Integer;  P,E,h,sh \<turnstile> e\<^sub>2 : Integer \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile> e\<^sub>1 \<guillemotleft>Add\<guillemotright> e\<^sub>2 : Integer"

| WTrtLAss:
  "\<lbrakk> E V = Some T;  P,E,h,sh \<turnstile> e : T';  P \<turnstile> T' \<le> T \<rbrakk>
   \<Longrightarrow> P,E,h,sh \<turnstile> V:=e : Void"

| WTrtFAcc:
  "\<lbrakk> P,E,h,sh \<turnstile> e : Class C; P \<turnstile> C has F,NonStatic:T in D \<rbrakk> \<Longrightarrow>
  P,E,h,sh \<turnstile> e\<bullet>F{D} : T"

| WTrtFAccNT:
  "P,E,h,sh \<turnstile> e : NT \<Longrightarrow>
  P,E,h,sh \<turnstile> e\<bullet>F{D} : T"

| WTrtSFAcc:
  "\<lbrakk> P \<turnstile> C has F,Static:T in D \<rbrakk> \<Longrightarrow>
  P,E,h,sh \<turnstile> C\<bullet>\<^sub>sF{D} : T"

| WTrtFAss:
  "\<lbrakk> P,E,h,sh \<turnstile> e\<^sub>1 : Class C;  P \<turnstile> C has F,NonStatic:T in D; P,E,h,sh \<turnstile> e\<^sub>2 : T\<^sub>2;  P \<turnstile> T\<^sub>2 \<le> T \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile> e\<^sub>1\<bullet>F{D}:=e\<^sub>2 : Void"

| WTrtFAssNT:
  "\<lbrakk> P,E,h,sh \<turnstile> e\<^sub>1:NT; P,E,h,sh \<turnstile> e\<^sub>2 : T\<^sub>2 \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile> e\<^sub>1\<bullet>F{D}:=e\<^sub>2 : Void"

| WTrtSFAss:
  "\<lbrakk> P,E,h,sh \<turnstile> e\<^sub>2 : T\<^sub>2; P \<turnstile> C has F,Static:T in D; P \<turnstile> T\<^sub>2 \<le> T \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile> C\<bullet>\<^sub>sF{D}:=e\<^sub>2 : Void"

| WTrtCall:
  "\<lbrakk> P,E,h,sh \<turnstile> e : Class C; P \<turnstile> C sees M,NonStatic:Ts \<rightarrow> T = (pns,body) in D;
     P,E,h,sh \<turnstile> es [:] Ts'; P \<turnstile> Ts' [\<le>] Ts \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile> e\<bullet>M(es) : T"

| WTrtCallNT:
  "\<lbrakk> P,E,h,sh \<turnstile> e : NT; P,E,h,sh \<turnstile> es [:] Ts \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile> e\<bullet>M(es) : T"

| WTrtSCall:
  "\<lbrakk> P \<turnstile> C sees M,Static:Ts \<rightarrow> T = (pns,body) in D;
     P,E,h,sh \<turnstile> es [:] Ts'; P \<turnstile> Ts' [\<le>] Ts;
     M = clinit \<longrightarrow> sh D = \<lfloor>(sfs,Processing)\<rfloor> \<and> es = map Val vs \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile> C\<bullet>\<^sub>sM(es) : T"

| WTrtBlock:
  "P,E(V\<mapsto>T),h,sh \<turnstile> e : T'  \<Longrightarrow>
  P,E,h,sh \<turnstile> {V:T; e} : T'"

| WTrtSeq:
  "\<lbrakk> P,E,h,sh \<turnstile> e\<^sub>1:T\<^sub>1;  P,E,h,sh \<turnstile> e\<^sub>2:T\<^sub>2 \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile> e\<^sub>1;;e\<^sub>2 : T\<^sub>2"

| WTrtCond:
  "\<lbrakk> P,E,h,sh \<turnstile> e : Boolean;  P,E,h,sh \<turnstile> e\<^sub>1:T\<^sub>1;  P,E,h,sh \<turnstile> e\<^sub>2:T\<^sub>2;
     P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<or> P \<turnstile> T\<^sub>2 \<le> T\<^sub>1; P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<longrightarrow> T = T\<^sub>2; P \<turnstile> T\<^sub>2 \<le> T\<^sub>1 \<longrightarrow> T = T\<^sub>1 \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile> if (e) e\<^sub>1 else e\<^sub>2 : T"

| WTrtWhile:
  "\<lbrakk> P,E,h,sh \<turnstile> e : Boolean;  P,E,h,sh \<turnstile> c:T \<rbrakk>
  \<Longrightarrow>  P,E,h,sh \<turnstile> while(e) c : Void"

| WTrtThrow:
  "\<lbrakk> P,E,h,sh \<turnstile> e : T\<^sub>r; is_refT T\<^sub>r \<rbrakk> \<Longrightarrow>
  P,E,h,sh \<turnstile> throw e : T"

| WTrtTry:
  "\<lbrakk> P,E,h,sh \<turnstile> e\<^sub>1 : T\<^sub>1;  P,E(V \<mapsto> Class C),h,sh \<turnstile> e\<^sub>2 : T\<^sub>2; P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile> try e\<^sub>1 catch(C V) e\<^sub>2 : T\<^sub>2"

| WTrtInit:
  "\<lbrakk> P,E,h,sh \<turnstile> e : T; \<forall>C' \<in> set (C#Cs). is_class P C'; \<not>sub_RI e;
     \<forall>C' \<in> set (tl Cs). \<exists>sfs. sh C' = \<lfloor>(sfs,Processing)\<rfloor>;
     b \<longrightarrow> (\<forall>C' \<in> set Cs. \<exists>sfs. sh C' = \<lfloor>(sfs,Processing)\<rfloor>);
     distinct Cs; supercls_lst P Cs \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile> INIT C (Cs, b) \<leftarrow> e : T"

| WTrtRI:
  "\<lbrakk> P,E,h,sh \<turnstile> e : T; P,E,h,sh \<turnstile> e' : T'; \<forall>C' \<in> set (C#Cs). is_class P C'; \<not>sub_RI e';
     \<forall>C' \<in> set (C#Cs). not_init C' e;
     \<forall>C' \<in> set Cs. \<exists>sfs. sh C' = \<lfloor>(sfs,Processing)\<rfloor>;
     \<exists>sfs. sh C = \<lfloor>(sfs, Processing)\<rfloor> \<or> (sh C = \<lfloor>(sfs, Error)\<rfloor> \<and> e = THROW NoClassDefFoundError);
     distinct (C#Cs); supercls_lst P (C#Cs) \<rbrakk>
  \<Longrightarrow> P,E,h,sh \<turnstile> RI(C, e);Cs \<leftarrow> e' : T'"

\<comment> \<open>well-typed expression lists\<close>

| WTrtNil:
  "P,E,h,sh \<turnstile> [] [:] []"

| WTrtCons:
  "\<lbrakk> P,E,h,sh \<turnstile> e : T;  P,E,h,sh \<turnstile> es [:] Ts \<rbrakk>
  \<Longrightarrow>  P,E,h,sh \<turnstile> e#es [:] T#Ts"

(*<*)
declare WTrt_WTrts.intros[intro!] WTrtNil[iff]
declare
  WTrtFAcc[rule del] WTrtFAccNT[rule del] WTrtSFAcc[rule del]
  WTrtFAss[rule del] WTrtFAssNT[rule del] WTrtSFAss[rule del]
  WTrtCall[rule del] WTrtCallNT[rule del] WTrtSCall[rule del]

lemmas WTrt_induct = WTrt_WTrts.induct [split_format (complete)]
  and WTrt_inducts = WTrt_WTrts.inducts [split_format (complete)]
(*>*)

subsection\<open>Easy consequences\<close>

lemma [iff]: "(P,E,h,sh \<turnstile> e#es [:] T#Ts) = (P,E,h,sh \<turnstile> e : T \<and> P,E,h,sh \<turnstile> es [:] Ts)"
(*<*)by(rule iffI) (auto elim: WTrts.cases)(*>*)

lemma [iff]: "(P,E,h,sh \<turnstile> (e#es) [:] Ts) =
  (\<exists>U Us. Ts = U#Us \<and> P,E,h,sh \<turnstile> e : U \<and> P,E,h,sh \<turnstile> es [:] Us)"
(*<*)by(rule iffI) (auto elim: WTrts.cases)(*>*)

lemma [iff]: "P,E,h,sh \<turnstile> Val v : T = (typeof\<^bsub>h\<^esub> v = Some T)"
(*<*)proof(rule iffI) qed (auto elim: WTrt.cases)(*>*)

lemma [iff]: "P,E,h,sh \<turnstile> Var v : T = (E v = Some T)"
(*<*)proof(rule iffI) qed (auto elim: WTrt.cases)(*>*)

lemma [iff]: "P,E,h,sh \<turnstile> e\<^sub>1;;e\<^sub>2 : T\<^sub>2 = (\<exists>T\<^sub>1. P,E,h,sh \<turnstile> e\<^sub>1:T\<^sub>1 \<and> P,E,h,sh \<turnstile> e\<^sub>2:T\<^sub>2)"
(*<*)proof(rule iffI) qed (auto elim: WTrt.cases)(*>*)

lemma [iff]: "P,E,h,sh \<turnstile> {V:T; e} : T'  =  (P,E(V\<mapsto>T),h,sh \<turnstile> e : T')"
(*<*)proof(rule iffI) qed (auto elim: WTrt.cases)(*>*)

(*<*)
inductive_cases WTrt_elim_cases[elim!]:
  "P,E,h,sh \<turnstile> v :=e : T"
  "P,E,h,sh \<turnstile> if (e) e\<^sub>1 else e\<^sub>2 : T"
  "P,E,h,sh \<turnstile> while(e) c : T"
  "P,E,h,sh \<turnstile> throw e : T"
  "P,E,h,sh \<turnstile> try e\<^sub>1 catch(C V) e\<^sub>2 : T"
  "P,E,h,sh \<turnstile> Cast D e : T"
  "P,E,h,sh \<turnstile> e\<bullet>F{D} : T"
  "P,E,h,sh \<turnstile> C\<bullet>\<^sub>sF{D} : T"
  "P,E,h,sh \<turnstile> e\<bullet>F{D} := v : T"
  "P,E,h,sh \<turnstile> C\<bullet>\<^sub>sF{D} := v : T"
  "P,E,h,sh \<turnstile> e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2 : T"
  "P,E,h,sh \<turnstile> new C : T"
  "P,E,h,sh \<turnstile> e\<bullet>M{D}(es) : T"
  "P,E,h,sh \<turnstile> C\<bullet>\<^sub>sM{D}(es) : T"
  "P,E,h,sh \<turnstile> INIT C (Cs,b) \<leftarrow> e : T"
  "P,E,h,sh \<turnstile> RI(C,e);Cs \<leftarrow> e' : T"
(*>*)

subsection\<open>Some interesting lemmas\<close>

lemma WTrts_Val[simp]:
 "\<And>Ts. (P,E,h,sh \<turnstile> map Val vs [:] Ts) = (map (typeof\<^bsub>h\<^esub>) vs = map Some Ts)"
(*<*)
proof(induct vs)
  case (Cons a vs)
  then show ?case by(case_tac Ts; simp)
qed simp
(*>*)

lemma WTrt_env_mono:
  "P,E,h,sh \<turnstile> e : T \<Longrightarrow> (\<And>E'. E \<subseteq>\<^sub>m E' \<Longrightarrow> P,E',h,sh \<turnstile> e : T)" and
  "P,E,h,sh \<turnstile> es [:] Ts \<Longrightarrow> (\<And>E'. E \<subseteq>\<^sub>m E' \<Longrightarrow> P,E',h,sh \<turnstile> es [:] Ts)"
(*<*)
proof(induct rule: WTrt_inducts)
  case WTrtVar then show ?case by(simp add: map_le_def dom_def)
next
  case WTrtLAss then show ?case by(force simp:map_le_def)
qed(fastforce intro: WTrt_WTrts.intros)+
(*>*)

lemma WTrt_hext_mono: "P,E,h,sh \<turnstile> e : T \<Longrightarrow> h \<unlhd> h' \<Longrightarrow> P,E,h',sh \<turnstile> e : T"
and WTrts_hext_mono: "P,E,h,sh \<turnstile> es [:] Ts \<Longrightarrow> h \<unlhd> h' \<Longrightarrow> P,E,h',sh \<turnstile> es [:] Ts"
(*<*)
proof(induct rule: WTrt_inducts)
  case WTrtVal then show ?case by(simp add: hext_typeof_mono)
qed(fastforce intro: WTrt_WTrts.intros)+
(*>*)

lemma WTrt_shext_mono: "P,E,h,sh \<turnstile> e : T \<Longrightarrow> sh \<unlhd>\<^sub>s sh' \<Longrightarrow> \<not>sub_RI e \<Longrightarrow> P,E,h,sh' \<turnstile> e : T"
and WTrts_shext_mono: "P,E,h,sh \<turnstile> es [:] Ts \<Longrightarrow> sh \<unlhd>\<^sub>s sh' \<Longrightarrow> \<not>sub_RIs es \<Longrightarrow> P,E,h,sh' \<turnstile> es [:] Ts"
(*<*)
by(induct rule: WTrt_inducts)
  (auto simp add: WTrt_WTrts.intros)
(*>*)

lemma WTrt_hext_shext_mono: "P,E,h,sh \<turnstile> e : T
   \<Longrightarrow> h \<unlhd> h' \<Longrightarrow> sh \<unlhd>\<^sub>s sh' \<Longrightarrow> \<not>sub_RI e \<Longrightarrow> P,E,h',sh' \<turnstile> e : T"
 by(auto intro: WTrt_hext_mono WTrt_shext_mono)

lemma WTrts_hext_shext_mono: "P,E,h,sh \<turnstile> es [:] Ts
   \<Longrightarrow> h \<unlhd> h' \<Longrightarrow> sh \<unlhd>\<^sub>s sh' \<Longrightarrow> \<not>sub_RIs es \<Longrightarrow> P,E,h',sh' \<turnstile> es [:] Ts"
 by(auto intro: WTrts_hext_mono WTrts_shext_mono)

lemma WT_implies_WTrt: "P,E \<turnstile> e :: T \<Longrightarrow> P,E,h,sh \<turnstile> e : T"
and WTs_implies_WTrts: "P,E \<turnstile> es [::] Ts \<Longrightarrow> P,E,h,sh \<turnstile> es [:] Ts"
(*<*)
proof(induct rule: WT_WTs_inducts)
  case WTVal then show ?case by(fastforce dest: typeof_lit_typeof)
next
  case WTFAcc
  then show ?case by(fastforce simp: WTrtFAcc has_visible_field)
next
  case WTSFAcc
  then show ?case by(fastforce simp: WTrtSFAcc has_visible_field)
next
  case WTFAss
  then show ?case by(fastforce simp: WTrtFAss dest: has_visible_field)
next
  case WTSFAss
  then show ?case by(fastforce simp: WTrtSFAss dest: has_visible_field)
qed(fastforce intro: WTrt_WTrts.intros)+
(*>*)

end


theory IICF_MS_Array_List
imports
  "../Intf/IICF_List"
  Separation_Logic_Imperative_HOL.Array_Blit
  Separation_Logic_Imperative_HOL.Default_Insts
begin

  type_synonym 'a ms_array_list = "'a Heap.array \<times> nat"

  definition "is_ms_array_list ms l \<equiv> \<lambda>(a,n). \<exists>\<^sub>Al'. a \<mapsto>\<^sub>a l' * \<up>(n \<le> length l' \<and> l = take n l' \<and> ms=length l')"

  lemma is_ms_array_list_prec[safe_constraint_rules]: "precise (is_ms_array_list ms)"
    unfolding is_ms_array_list_def[abs_def]
    apply(rule preciseI)
    apply(simp split: prod.splits)
  	using preciseD snga_prec by fastforce

  definition "marl_empty_sz maxsize \<equiv> do {
    a \<leftarrow> Array.new maxsize default;
    return (a,0)
  }"

  definition "marl_append \<equiv> \<lambda>(a,n) x. do {
      a \<leftarrow> Array.upd n x a;
      return (a,n+1)
  }"

  definition marl_length :: "'a::heap ms_array_list \<Rightarrow> nat Heap" where
    "marl_length \<equiv> \<lambda>(a,n). return (n)"

  definition marl_is_empty :: "'a::heap ms_array_list \<Rightarrow> bool Heap" where
    "marl_is_empty \<equiv> \<lambda>(a,n). return (n=0)"

  definition marl_last :: "'a::heap ms_array_list \<Rightarrow> 'a Heap" where
    "marl_last \<equiv> \<lambda>(a,n). do {
      Array.nth a (n - 1)
    }"

  definition marl_butlast :: "'a::heap ms_array_list \<Rightarrow> 'a ms_array_list Heap" where
    "marl_butlast \<equiv> \<lambda>(a,n). do {
      return (a,n - 1)
    }"

  definition marl_get :: "'a::heap ms_array_list \<Rightarrow> nat \<Rightarrow> 'a Heap" where
    "marl_get \<equiv> \<lambda>(a,n) i. Array.nth a i"

  definition marl_set :: "'a::heap ms_array_list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a ms_array_list Heap" where
    "marl_set \<equiv> \<lambda>(a,n) i x. do { a \<leftarrow> Array.upd i x a; return (a,n)}"

  lemma marl_empty_sz_rule[sep_heap_rules]: "< emp > marl_empty_sz N <is_ms_array_list N []>"
    by (sep_auto simp: marl_empty_sz_def is_ms_array_list_def)

  lemma marl_append_rule[sep_heap_rules]: "length l < N \<Longrightarrow>
    < is_ms_array_list N l a >
      marl_append a x
    <\<lambda>a. is_ms_array_list N (l@[x]) a >\<^sub>t"
    by (sep_auto
      simp: marl_append_def is_ms_array_list_def take_update_last
      split: prod.splits)

  lemma marl_length_rule[sep_heap_rules]: "
    <is_ms_array_list N l a>
      marl_length a
    <\<lambda>r. is_ms_array_list N l a * \<up>(r=length l)>"
    by (sep_auto simp: marl_length_def is_ms_array_list_def)

  lemma marl_is_empty_rule[sep_heap_rules]: "
    <is_ms_array_list N l a>
      marl_is_empty a
    <\<lambda>r. is_ms_array_list N l a * \<up>(r\<longleftrightarrow>(l=[]))>"
    by (sep_auto simp: marl_is_empty_def is_ms_array_list_def)

  lemma marl_last_rule[sep_heap_rules]: "
    l\<noteq>[] \<Longrightarrow>
    <is_ms_array_list N l a>
      marl_last a
    <\<lambda>r. is_ms_array_list N l a * \<up>(r=last l)>"
    by (sep_auto simp: marl_last_def is_ms_array_list_def last_take_nth_conv)

  lemma marl_butlast_rule[sep_heap_rules]: "
    l\<noteq>[] \<Longrightarrow>
    <is_ms_array_list N l a>
      marl_butlast a
    <is_ms_array_list N (butlast l)>\<^sub>t"
    by (sep_auto
      split: prod.splits
      simp: marl_butlast_def is_ms_array_list_def butlast_take)

  lemma marl_get_rule[sep_heap_rules]: "
    i<length l \<Longrightarrow>
    <is_ms_array_list N l a>
      marl_get a i
    <\<lambda>r. is_ms_array_list N l a * \<up>(r=l!i)>"
    by (sep_auto simp: marl_get_def is_ms_array_list_def split: prod.split)

  lemma marl_set_rule[sep_heap_rules]: "
    i<length l \<Longrightarrow>
    <is_ms_array_list N l a>
      marl_set a i x
    <is_ms_array_list N (l[i:=x])>"
    by (sep_auto simp: marl_set_def is_ms_array_list_def split: prod.split)

  definition "marl_assn N A \<equiv> hr_comp (is_ms_array_list N) (\<langle>the_pure A\<rangle>list_rel)"
  lemmas [safe_constraint_rules] = CN_FALSEI[of is_pure "marl_assn N A" for N A]

context
  notes [fcomp_norm_unfold] = marl_assn_def[symmetric]
  notes [intro!] = hfrefI hn_refineI[THEN hn_refine_preI]
  notes [simp] = pure_def hn_ctxt_def invalid_assn_def
begin

  definition [simp]: "op_marl_empty_sz (N::nat) \<equiv> op_list_empty"
  context fixes N :: nat begin
    sepref_register "PR_CONST (op_marl_empty_sz N)"
  end

  lemma marl_fold_custom_empty_sz:
    "op_list_empty = op_marl_empty_sz N"
    "mop_list_empty = RETURN (op_marl_empty_sz N)"
    "[] = op_marl_empty_sz N"
    by auto

  lemma marl_empty_hnr_aux: "(uncurry0 (marl_empty_sz N), uncurry0 (RETURN op_list_empty)) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a is_ms_array_list N"
    by sep_auto
  lemmas marl_empty_hnr = marl_empty_hnr_aux[FCOMP op_list_empty.fref[of "the_pure A" for A]]
  lemmas marl_empty_hnr_mop = marl_empty_hnr[FCOMP mk_mop_rl0_np[OF mop_list_empty_alt]]

  lemma marl_empty_sz_hnr[sepref_fr_rules]:
    "(uncurry0 (marl_empty_sz N), uncurry0 (RETURN (PR_CONST (op_marl_empty_sz N)))) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a marl_assn N A"
    using marl_empty_hnr
    by simp

  lemma marl_append_hnr_aux: "(uncurry marl_append,uncurry (RETURN oo op_list_append)) \<in> [\<lambda>(l,_). length l<N]\<^sub>a ((is_ms_array_list N)\<^sup>d *\<^sub>a id_assn\<^sup>k) \<rightarrow> is_ms_array_list N"
    by sep_auto
  lemmas marl_append_hnr[sepref_fr_rules] = marl_append_hnr_aux[FCOMP op_list_append.fref]
  lemmas marl_append_hnr_mop[sepref_fr_rules] = marl_append_hnr[FCOMP mk_mop_rl2_np[OF mop_list_append_alt]]

  lemma marl_length_hnr_aux: "(marl_length,RETURN o op_list_length) \<in> (is_ms_array_list N)\<^sup>k \<rightarrow>\<^sub>a nat_assn"
    by sep_auto
  lemmas marl_length_hnr[sepref_fr_rules] = marl_length_hnr_aux[FCOMP op_list_length.fref[of "the_pure A" for A]]
  lemmas marl_length_hnr_mop[sepref_fr_rules] = marl_length_hnr[FCOMP mk_mop_rl1_np[OF mop_list_length_alt]]

  lemma marl_is_empty_hnr_aux: "(marl_is_empty,RETURN o op_list_is_empty) \<in> (is_ms_array_list N)\<^sup>k \<rightarrow>\<^sub>a bool_assn"
    by sep_auto
  lemmas marl_is_empty_hnr[sepref_fr_rules] = marl_is_empty_hnr_aux[FCOMP op_list_is_empty.fref[of "the_pure A" for A]]
  lemmas marl_is_empty_hnr_mop[sepref_fr_rules] = marl_is_empty_hnr[FCOMP mk_mop_rl1_np[OF mop_list_is_empty_alt]]

  lemma marl_last_hnr_aux: "(marl_last,RETURN o op_list_last) \<in> [\<lambda>x. x\<noteq>[]]\<^sub>a (is_ms_array_list N)\<^sup>k \<rightarrow> id_assn"
    by sep_auto
  lemmas marl_last_hnr[sepref_fr_rules] = marl_last_hnr_aux[FCOMP op_list_last.fref]
  lemmas marl_last_hnr_mop[sepref_fr_rules] = marl_last_hnr[FCOMP mk_mop_rl1[OF mop_list_last_alt]]

  lemma marl_butlast_hnr_aux: "(marl_butlast,RETURN o op_list_butlast) \<in> [\<lambda>x. x\<noteq>[]]\<^sub>a (is_ms_array_list N)\<^sup>d \<rightarrow> (is_ms_array_list N)"
    by sep_auto
  lemmas marl_butlast_hnr[sepref_fr_rules] = marl_butlast_hnr_aux[FCOMP op_list_butlast.fref[of "the_pure A" for A]]
  lemmas marl_butlast_hnr_mop[sepref_fr_rules] = marl_butlast_hnr[FCOMP mk_mop_rl1[OF mop_list_butlast_alt]]

  lemma marl_get_hnr_aux: "(uncurry marl_get,uncurry (RETURN oo op_list_get)) \<in> [\<lambda>(l,i). i<length l]\<^sub>a ((is_ms_array_list N)\<^sup>k *\<^sub>a nat_assn\<^sup>k) \<rightarrow> id_assn"
    by sep_auto
  lemmas marl_get_hnr[sepref_fr_rules] = marl_get_hnr_aux[FCOMP op_list_get.fref]
  lemmas marl_get_hnr_mop[sepref_fr_rules] = marl_get_hnr[FCOMP mk_mop_rl2[OF mop_list_get_alt]]

  lemma marl_set_hnr_aux: "(uncurry2 marl_set,uncurry2 (RETURN ooo op_list_set)) \<in> [\<lambda>((l,i),_). i<length l]\<^sub>a ((is_ms_array_list N)\<^sup>d *\<^sub>a nat_assn\<^sup>k *\<^sub>a id_assn\<^sup>k) \<rightarrow> (is_ms_array_list N)"
    by sep_auto
  lemmas marl_set_hnr[sepref_fr_rules] = marl_set_hnr_aux[FCOMP op_list_set.fref]
  lemmas marl_set_hnr_mop[sepref_fr_rules] = marl_set_hnr[FCOMP mk_mop_rl3[OF mop_list_set_alt]]

end

context
  fixes N :: nat
  assumes N_sz: "N>10"
begin

schematic_goal "hn_refine (emp) (?c::?'c Heap) ?\<Gamma>' ?R (do {
  let x = op_marl_empty_sz N;
  RETURN (x@[1::nat])
})"
  using N_sz
  by sepref

end

schematic_goal "hn_refine (emp) (?c::?'c Heap) ?\<Gamma>' ?R (do {
  let x = op_list_empty;
  RETURN (x@[1::nat])
})"
  apply (subst marl_fold_custom_empty_sz[where N=10])
  apply sepref
  done

end


section\<open>Least Upper Bound\<close>
text\<open>The simplest way to merge a pair of transitions with identical outputs and updates is to
simply take the least upper bound of their \emph{guards}. This theory presents several variants on
this theme.\<close>

theory Least_Upper_Bound
  imports "../Inference"
begin

fun literal_args :: "'a gexp \<Rightarrow> bool" where
  "literal_args (Bc v) = False" |
  "literal_args (Eq (V _) (L _)) = True" |
  "literal_args (In _ _) = True" |
  "literal_args (Eq _ _) = False" |
  "literal_args (Gt va v) = False" |
  "literal_args (Nor v va) = (literal_args v \<and> literal_args va)"

lemma literal_args_eq:
  "literal_args (Eq a b) \<Longrightarrow> \<exists>v l. a = (V v) \<and> b = (L l)"
  apply (cases a)
     apply simp
      apply (cases b)
  by auto

definition "all_literal_args t = (\<forall>g \<in> set (Guards t). literal_args g)"

fun merge_in_eq :: "vname \<Rightarrow> value \<Rightarrow> vname gexp list \<Rightarrow> vname gexp list" where
  "merge_in_eq v l [] = [Eq (V v) (L l)]" |
  "merge_in_eq v l ((Eq (V v') (L l'))#t) = (if v = v' \<and> l \<noteq> l' then (In v [l, l'])#t else (Eq (V v') (L l'))#(merge_in_eq v l t))" |
  "merge_in_eq v l ((In v' l')#t) = (if v = v' then (In v (remdups (l#l')))#t else (In v' l')#(merge_in_eq v l t))" |
  "merge_in_eq v l (h#t) = h#(merge_in_eq v l t)"

fun merge_in_in :: "vname \<Rightarrow> value list \<Rightarrow> vname gexp list \<Rightarrow> vname gexp list" where
  "merge_in_in v l [] = [In v l]" |
  "merge_in_in v l ((Eq (V v') (L l'))#t) = (if v = v' then (In v (List.insert l' l))#t else (Eq (V v') (L l'))#(merge_in_in v l t))" |
  "merge_in_in v l ((In v' l')#t) = (if v = v' then (In v (List.union l l'))#t else (In v' l')#(merge_in_in v l t))" |
  "merge_in_in v l (h#t) = h#(merge_in_in v l t)"

fun merge_guards :: "vname gexp list \<Rightarrow> vname gexp list \<Rightarrow> vname gexp list" where
  "merge_guards [] g2 = g2" |
  "merge_guards ((Eq (V v) (L l))#t) g2 =  merge_guards t (merge_in_eq v l g2)" |
  "merge_guards ((In v l)#t) g2 = merge_guards t (merge_in_in v l g2)" |
  "merge_guards (h#t) g2 = h#(merge_guards t g2)"

text\<open>The ``least upper bound'' (lob) heuristic simply disjoins the guards of two transitions with
identical outputs and updates.\<close>
definition lob_aux :: "transition \<Rightarrow> transition \<Rightarrow> transition option" where
  "lob_aux t1 t2 = (if Outputs t1 = Outputs t2 \<and> Updates t1 = Updates t2 \<and> all_literal_args t1 \<and> all_literal_args t2 then
      Some \<lparr>Label = Label t1, Arity = Arity t1, Guards = remdups (merge_guards (Guards t1) (Guards t2)), Outputs = Outputs t1, Updates = Updates t1\<rparr>
     else None)"

fun lob :: update_modifier where
  "lob t1ID t2ID s new _ old _ = (let
     t1 = (get_by_ids new t1ID);
     t2 = (get_by_ids new t2ID) in
     case lob_aux t1 t2 of
       None \<Rightarrow> None |
       Some lob_t \<Rightarrow>
           Some (replace_transitions new [(t1ID, lob_t), (t2ID, lob_t)])
   )"

lemma lob_aux_some: "Outputs t1 = Outputs t2 \<Longrightarrow>
       Updates t1 = Updates t2 \<Longrightarrow>
       all_literal_args t1 \<Longrightarrow>
       all_literal_args t2 \<Longrightarrow>
       Label t = Label t1 \<Longrightarrow>
       Arity t = Arity t1 \<Longrightarrow>
       Guards t = remdups (merge_guards (Guards t1) (Guards t2)) \<Longrightarrow>
       Outputs t = Outputs t1 \<Longrightarrow>
       Updates t = Updates t1 \<Longrightarrow>
       lob_aux t1 t2 = Some t"
  by (simp add: lob_aux_def)

fun has_corresponding :: "vname gexp \<Rightarrow> vname gexp list \<Rightarrow> bool" where
  "has_corresponding g [] = False" |
  "has_corresponding (Eq (V v) (L l)) ((Eq (V v') (L l'))#t) = (if v = v' \<and> l = l' then True else has_corresponding (Eq (V v) (L l)) t)" |
  "has_corresponding (In v' l') ((Eq (V v) (L l))#t) = (if v = v' \<and> l \<in> set l' then True else has_corresponding (In v' l') t)" |
  "has_corresponding (In v l) ((In v' l')#t) = (if v = v' \<and> set l' \<subseteq> set l then True else has_corresponding (In v l) t)" |
  "has_corresponding g (h#t) = has_corresponding g t"

lemma no_corresponding_bc: "\<not>has_corresponding (Bc x1) G1"
  apply (induct G1)
  by auto

lemma no_corresponding_gt: "\<not>has_corresponding (Gt x1 y1) G1"
  apply (induct G1)
  by auto

lemma no_corresponding_nor: "\<not>has_corresponding (Nor x1 y1) G1"
  apply (induct G1)
  by auto

lemma has_corresponding_eq: "has_corresponding (Eq x21 x22) G1 \<Longrightarrow> (Eq x21 x22) \<in> set G1"
proof(induct G1)
  case (Cons a G1)
  then show ?case
    apply (cases a)
        apply simp
    subgoal for x21a x22a
      apply (case_tac "x21a")
          apply simp
         apply (case_tac "x22a")
             apply clarify
             apply simp
             apply (case_tac "x21")
                 apply simp
                apply (case_tac "x22")
                    apply (metis has_corresponding.simps(2))
      by auto
    by auto
qed auto

lemma has_corresponding_In: "has_corresponding (In v l) G1 \<Longrightarrow> (\<exists>l'. (In v l') \<in> set G1 \<and> set l' \<subseteq> set l) \<or> (\<exists>l' \<in> set l. (Eq (V v) (L l')) \<in> set G1)"
proof(induct G1)
  case (Cons a G1)
  then show ?case
    apply (cases a)
        apply simp
       defer
       apply simp
      apply simp
      defer
      apply simp
     apply simp
    subgoal for x21 x22 apply (case_tac x21)
          apply simp
         apply (case_tac x22)
             apply fastforce
            apply simp+
      done
    by metis
qed auto

lemma gval_each_one: "g \<in> set G \<Longrightarrow> apply_guards G s \<Longrightarrow> gval g s = true"
  using apply_guards_cons apply_guards_rearrange by blast

lemma has_corresponding_apply_guards:
  "\<forall>g\<in>set G2. has_corresponding g G1 \<Longrightarrow>
   apply_guards G1 s \<Longrightarrow>
   apply_guards G2 s"
proof(induct G2)
  case (Cons a G2)
  then show ?case
    apply (cases a)
        apply (simp add: no_corresponding_bc)
       apply simp
       apply (metis (full_types) has_corresponding_eq append_Cons append_self_conv2 apply_guards_append apply_guards_rearrange)
      apply (simp add: no_corresponding_gt)
     apply simp
    subgoal for v l
      apply (insert has_corresponding_In[of v l G1])
      apply simp
      apply (erule disjE)
       apply clarsimp
      subgoal for l'
        apply (insert apply_guards_rearrange[of "In v l'" G1 s])
        apply simp
        apply (simp only: apply_guards_cons[of "In v l" G2])
        apply (simp only: apply_guards_cons[of "In v l'" G1])
        apply simp
        apply (cases "s v")
         apply simp
        by force
      apply clarsimp
      subgoal for l'
        apply (insert apply_guards_rearrange[of "Eq (V v) (L l')" G1 s])
        apply simp
        apply (simp only: apply_guards_cons[of "In v l" G2])
        apply (simp only: apply_guards_cons[of "Eq (V v) (L l')" G1])
        apply (cases "s v")
         apply simp
        apply simp
        using trilean.distinct(1) by presburger
      done
    by (simp add: no_corresponding_nor)
qed auto

lemma correspondence_subsumption:
  "Label t1 = Label t2 \<Longrightarrow>
   Arity t1 = Arity t2 \<Longrightarrow>
   Outputs t1 = Outputs t2 \<Longrightarrow>
   Updates t1 = Updates t2 \<Longrightarrow>
   \<forall>g \<in> set (Guards t2). has_corresponding g (Guards t1) \<Longrightarrow>
   subsumes t2 c t1"
  by (simp add: can_take_def can_take_transition_def has_corresponding_apply_guards subsumption)

definition "is_lob t1 t2 = (
  Label t1 = Label t2 \<and>
  Arity t1 = Arity t2 \<and>
  Outputs t1 = Outputs t2 \<and>
  Updates t1 = Updates t2 \<and>
  (\<forall>g \<in> set (Guards t2). has_corresponding g (Guards t1)))"

lemma is_lob_direct_subsumption:
  "is_lob t1 t2 \<Longrightarrow> directly_subsumes e1 e2 s s' t2 t1"
  apply (rule subsumes_in_all_contexts_directly_subsumes)
  by (simp add: is_lob_def correspondence_subsumption)

fun has_distinguishing :: "vname gexp \<Rightarrow> vname gexp list \<Rightarrow> bool" where
  "has_distinguishing g [] = False" |
  "has_distinguishing (Eq (V v) (L l)) ((Eq (V v') (L l'))#t) = (if v = v' \<and> l \<noteq> l' then True else has_distinguishing (Eq (V v) (L l)) t)" |
  "has_distinguishing (In (I v') l') ((Eq (V (I v)) (L l))#t) = (if v = v' \<and> l \<notin> set l' then True else has_distinguishing (In (I v') l') t)" |
  "has_distinguishing (In (I v) l) ((In (I v') l')#t) = (if v = v' \<and> set l' \<supset> set l then True else has_distinguishing (In (I v) l) t)" |
  "has_distinguishing g (h#t) = has_distinguishing g t"

lemma has_distinguishing: "has_distinguishing g G \<Longrightarrow> (\<exists>v l. g = (Eq (V v) (L l))) \<or> (\<exists>v l. g = In v l)"
proof(induct G)
  case (Cons a G)
  then show ?case
    apply (cases g)
         apply simp
        apply (case_tac x21)
           apply simp
          apply (case_tac x22)
    by auto
qed auto

lemma has_distinguishing_Eq: "has_distinguishing (Eq (V v) (L l)) G \<Longrightarrow> \<exists>l'. (Eq (V v) (L l')) \<in> set G \<and> l \<noteq> l'"
proof (induct G)
  case (Cons a G)
  then show ?case
    apply (cases a)
         apply simp
        apply (case_tac x21)
           apply simp
          apply (case_tac x22)
             apply (metis has_distinguishing.simps(2) list.set_intros(1) list.set_intros(2))
    by auto
qed auto

lemma ex_mutex: "Eq (V v) (L l) \<in> set G1 \<Longrightarrow>
       Eq (V v) (L l') \<in> set G2 \<Longrightarrow>
       l \<noteq> l' \<Longrightarrow>
       apply_guards G1 s \<Longrightarrow>
       \<not> apply_guards G2 s"
  apply (simp add: apply_guards_def Bex_def)
  apply (rule_tac x="Eq (V v) (L l')" in exI)
  apply simp
  apply (case_tac "s v")
  by auto

lemma has_distinguishing_In:
  "has_distinguishing (In v l) G \<Longrightarrow>
   (\<exists>l' i. v = I i \<and> Eq (V v) (L l') \<in> set G \<and> l' \<notin> set l) \<or> (\<exists>l' i. v = I i \<and> In v l' \<in> set G \<and> set l' \<supset> set l)"
proof(induct G)
  case (Cons a G)
  then show ?case
    apply (case_tac v)
    subgoal for x
      apply simp
      apply (cases a)
          apply simp
      subgoal for x21 x22
        apply (case_tac x21)
            apply simp
           apply (case_tac x22)
               apply (case_tac x2)
                apply fastforce
               apply simp+
        done
      subgoal by simp
      subgoal for x41
        apply (case_tac x41)
         apply (simp, metis)
        by auto
      by auto
    by auto
qed auto

lemma Eq_apply_guards:
  "Eq (V v) (L l) \<in> set G1 \<Longrightarrow>
   apply_guards G1 s \<Longrightarrow>
   s v = Some l"
  apply (simp add: apply_guards_rearrange)
  apply (simp add: apply_guards_cons)
  apply (cases "s v")
   apply simp
  apply simp
  using trilean.distinct(1) by presburger

lemma In_neq_apply_guards:
  "In v l \<in> set G2 \<Longrightarrow>
   Eq (V v) (L l') \<in> set G1 \<Longrightarrow>
   l' \<notin> set l \<Longrightarrow>
   apply_guards G1 s \<Longrightarrow>
   \<not>apply_guards G2 s"
proof(induct G1)
  case (Cons a G1)
  then show ?case
    apply (simp add: apply_guards_def Bex_def)
    apply (rule_tac x="In v l" in exI)
    using Eq_apply_guards[of v l' "a#G1" s]
    by (simp add: Cons.prems(4) image_iff)
qed auto

lemma In_apply_guards: "In v l \<in> set G1 \<Longrightarrow> apply_guards G1 s \<Longrightarrow> \<exists>v' \<in> set l. s v = Some v'"
  apply (simp add: apply_guards_rearrange)
  apply (simp add: apply_guards_cons)
  apply (cases "s v")
   apply simp
  apply simp
  by (meson image_iff trilean.simps(2))

lemma input_not_constrained_aval_swap_inputs:
  "\<not> aexp_constrains a (V (I v)) \<Longrightarrow>
   aval a (join_ir i c) = aval a (join_ir (list_update i v x) c)"
  apply(induct a rule: aexp_induct_separate_V_cases)
       apply simp
      apply (metis aexp_constrains.simps(2) aval.simps(2) input2state_nth input2state_out_of_bounds join_ir_def length_list_update not_le nth_list_update_neq vname.simps(5))
  using join_ir_def by auto

lemma input_not_constrained_gval_swap_inputs:
  "\<not> gexp_constrains a (V (I v)) \<Longrightarrow>
   gval a (join_ir i c) = gval a (join_ir (i[v := x]) c)"
proof(induct a)
  case (Bc x)
  then show ?case
    by (metis (full_types) gval.simps(1) gval.simps(2))
next
  case (Eq x1a x2)
  then show ?case
    using input_not_constrained_aval_swap_inputs by auto
next
  case (Gt x1a x2)
  then show ?case
    using input_not_constrained_aval_swap_inputs by auto
next
  case (In x1a x2)
  then show ?case
    apply simp
    apply (case_tac "join_ir i c x1a")
     apply (case_tac "join_ir (i[v := x]) c x1a")
      apply simp
     apply (metis In.prems aval.simps(2) gexp_constrains.simps(5) input_not_constrained_aval_swap_inputs option.discI)
    apply (case_tac "join_ir (i[v := x]) c x1a")
     apply (metis In.prems aval.simps(2) gexp_constrains.simps(5) input_not_constrained_aval_swap_inputs option.discI)
    by (metis In.prems aval.simps(2) gexp_constrains.simps(5) input_not_constrained_aval_swap_inputs)
qed auto

lemma test_aux: "\<forall>g\<in>set (removeAll (In (I v) l) G1). \<not> gexp_constrains g (V (I v)) \<Longrightarrow>
      apply_guards G1 (join_ir i c) \<Longrightarrow>
      x \<in> set l \<Longrightarrow>
      apply_guards G1 (join_ir (i[v := x]) c)"
proof(induct G1)
  case (Cons a G1)
  then show ?case
    apply (simp only: apply_guards_cons)
    apply (case_tac "a = In (I v) l")
     apply simp
     apply (case_tac "join_ir i c (I v)")
      apply simp
     apply (case_tac "join_ir (i[v := x]) c (I v)")
      apply (metis join_ir_nth le_less_linear length_list_update list_update_beyond option.discI)
     apply simp
     apply (metis join_ir_nth le_less_linear length_list_update list_update_beyond nth_list_update_eq option.inject trilean.distinct(1))
    apply (case_tac "join_ir (i[v := x]) c (I v)")
     apply (metis join_ir_nth le_less_linear length_list_update list_update_beyond option.discI)
    apply simp
    using input_not_constrained_gval_swap_inputs by auto
qed auto

lemma test:
  assumes
    p1: "In (I v) l \<in> set G2" and
    p2: "In (I v) l' \<in> set G1" and
    p3: "x \<in> set l'" and
    p4: "x \<notin> set l" and
    p5: "apply_guards G1 (join_ir i c)" and
    p6: "length i = a" and
    p7: "\<forall>g \<in> set (removeAll (In (I v) l') G1). \<not> gexp_constrains g (V (I v))"
  shows "\<exists>i. length i = a \<and> apply_guards G1 (join_ir i c) \<and> (length i = a \<longrightarrow> \<not> apply_guards G2 (join_ir i c))"
  apply (rule_tac x="list_update i v x" in exI)
  apply standard
   apply (simp add: p6)
  apply standard
  using p3 p5 p7 test_aux apply blast
  using p1 p4
  apply (simp add: apply_guards_rearrange)
  apply (simp add: apply_guards_cons join_ir_def)
  apply (case_tac "input2state (i[v := x]) $ v")
   apply simp
  apply simp
  by (metis input2state_nth input2state_within_bounds length_list_update nth_list_update_eq option.inject)

definition get_Ins :: "vname gexp list \<Rightarrow> (nat \<times> value list) list" where
  "get_Ins G = map (\<lambda>g. case g of (In (I v) l) \<Rightarrow> (v, l)) (filter (\<lambda>g. case g of (In (I _) _ ) \<Rightarrow> True | _ \<Rightarrow> False) G)"

lemma get_Ins_Cons_equiv: "\<nexists>v l. a = In (I v) l \<Longrightarrow> get_Ins (a # G) = get_Ins G"
  apply (simp add: get_Ins_def)
  apply (cases a)
       apply simp+
   apply (metis (full_types) vname.exhaust vname.simps(6))
  by simp

lemma Ball_Cons: "(\<forall>x \<in> set (a#l). P x) = (P a \<and> (\<forall>x \<in> set l. P x))"
  by simp

lemma In_in_get_Ins: "(In (I v) l \<in> set G) = ((v, l) \<in> set (get_Ins G))"
proof(induct G)
  case Nil
  then show ?case
    by (simp add: get_Ins_def)
next
  case (Cons a G)
  then show ?case
    apply (simp add: get_Ins_def)
    apply (cases a)
        apply simp+
    subgoal for x by (case_tac x, auto)
    apply auto
    done
qed

definition "check_get_Ins G = (\<forall>(v, l') \<in> set (get_Ins G). \<forall>g \<in> set (removeAll (In (I v) l') G). \<not> gexp_constrains g (V (I v)))"

lemma no_Ins: "[] = get_Ins G \<Longrightarrow> set G - {In (I i) l} = set G"
proof(induct G)
  case (Cons a G)
  then show ?case
    apply (cases a)
        apply (simp add: get_Ins_Cons_equiv insert_Diff_if)+
    subgoal for x41 x42
      apply (case_tac x41)
       apply simp
       apply (metis In_in_get_Ins equals0D list.set(1) list.set_intros(1))
      apply (simp add: get_Ins_Cons_equiv)
      done
    by (simp add: get_Ins_Cons_equiv insert_Diff_if)
qed auto

lemma test2: "In (I i) l \<in> set (Guards t2) \<Longrightarrow>
       In (I i) l' \<in> set (Guards t1) \<Longrightarrow>
       length ia = Arity t1 \<Longrightarrow>
       apply_guards (Guards t1) (join_ir ia c) \<Longrightarrow>
       x \<in> set l' \<Longrightarrow>
       x \<notin> set l \<Longrightarrow>
       \<forall>(v, l')\<in>insert (0, []) (set (get_Ins (Guards t1))). \<forall>g\<in>set (removeAll (In (I v) l') (Guards t1)). \<not> gexp_constrains g (V (I v)) \<Longrightarrow>
       Arity t1 = Arity t2 \<Longrightarrow>
       \<exists>i. length i = Arity t2 \<and> apply_guards (Guards t1) (join_ir i c) \<and> (length i = Arity t2 \<longrightarrow> \<not> apply_guards (Guards t2) (join_ir i c))"
  using test[of i l "Guards t2" l' "Guards t1" x ia  c "Arity t2"]
  apply simp
  apply (case_tac "\<forall>g\<in>set (Guards t1) - {In (I i) l'}. \<not> gexp_constrains g (V (I i))")
   apply simp
  apply simp
  using In_in_get_Ins by blast

lemma distinguishing_subsumption:
  assumes
    p1: "\<exists>g \<in> set (Guards t2). has_distinguishing g (Guards t1)" and
    p2: "Arity t1 = Arity t2" and
    p3: "\<exists>i. can_take_transition t1 i c" and
    p4: "(\<forall>(v, l') \<in> insert (0, []) (set (get_Ins (Guards t1))). \<forall>g \<in> set (removeAll (In (I v) l') (Guards t1)). \<not> gexp_constrains g (V (I v)))"
  shows
   "\<not> subsumes t2 c t1"
proof-
  show ?thesis
    apply (rule bad_guards)
    apply (simp add: can_take_transition_def can_take_def p2)
    apply (insert p1, simp add: Bex_def)
    apply (erule exE)
    apply (case_tac "\<exists>v l. x = (Eq (V v) (L l))")
     apply (metis can_take_def can_take_transition_def ex_mutex p2 p3 has_distinguishing_Eq)
    apply (case_tac "\<exists>v l. x = In v l")
     defer
    using has_distinguishing apply blast
    apply clarify
    apply (case_tac "\<exists>l' i. v = I i \<and> Eq (V v) (L l') \<in> set (Guards t1) \<and> l' \<notin> set l")
     apply (metis In_neq_apply_guards can_take_def can_take_transition_def p2 p3)
    apply (case_tac "(\<exists>l' i. v = I i \<and> In v l' \<in> set (Guards t1) \<and> set l' \<supset> set l)")
     defer
    using has_distinguishing_In apply blast
    apply simp
    apply (erule conjE)
    apply (erule exE)+
    apply (erule conjE)
    apply (insert p3, simp only: can_take_transition_def can_take_def)
    apply (case_tac "\<exists>x. x \<in> set l' \<and> x \<notin> set l")
    apply (erule exE)+
    apply (erule conjE)+
    apply (insert p4 p2)
    using test2
     apply blast
    by auto
qed

definition "lob_distinguished t1 t2 = (
(\<exists>g \<in> set (Guards t2). has_distinguishing g (Guards t1)) \<and>
Arity t1 = Arity t2 \<and>
(\<forall>(v, l') \<in> insert (0, []) (set (get_Ins (Guards t1))). \<forall>g \<in> set (removeAll (In (I v) l') (Guards t1)). \<not> gexp_constrains g (V (I v))))"

lemma must_be_another:
  "1 < size (fset_of_list b) \<Longrightarrow>
   x \<in> set b \<Longrightarrow>
   \<exists>x' \<in> set b. x \<noteq> x'"
proof(induct b)
  case (Cons a b)
  then show ?case
    apply (simp add: Bex_def)
    by (metis List.finite_set One_nat_def card.insert card_gt_0_iff card_mono fset_of_list.rep_eq insert_absorb le_0_eq less_nat_zero_code less_numeral_extra(4) not_less_iff_gr_or_eq set_empty2 subsetI)
qed auto

lemma another_swap_inputs:
  "apply_guards G (join_ir i c) \<Longrightarrow>
  filter (\<lambda>g. gexp_constrains g (V (I a))) G = [In (I a) b] \<Longrightarrow>
  xa \<in> set b \<Longrightarrow>
  apply_guards G (join_ir (i[a := xa]) c)"
proof(induct G)
  case (Cons g G)
  then show ?case
    apply (simp add: apply_guards_cons)
    apply (case_tac "gexp_constrains g (V (I a))")
     defer
    using input_not_constrained_gval_swap_inputs apply auto[1]
     apply simp
    apply (case_tac "join_ir i c (I a) \<in> Some ` set b")
     defer
     apply simp
    apply clarify
    apply standard
    using apply_guards_def input_not_constrained_gval_swap_inputs
      apply (simp add: filter_empty_conv)
      apply (case_tac "join_ir i c (I a)")
       apply simp
      apply (case_tac "join_ir (i[a := xa]) c (I a)")
       apply simp
       apply (metis image_eqI trilean.distinct(1))
      apply simp
      apply (metis image_eqI trilean.distinct(1))
     apply (case_tac "join_ir i c (I a)")
      apply simp
     apply simp
     apply (metis image_eqI trilean.distinct(1))
    apply (case_tac "join_ir i c (I a)")
     apply simp
    apply (case_tac "join_ir (i[a := xa]) c (I a)")
     apply simp
     apply (metis join_ir_nth le_less_linear length_list_update list_update_beyond option.discI)
    apply simp
    apply standard
     apply (metis (no_types, lifting) Cons.hyps Cons.prems(2) filter_empty_conv removeAll_id set_ConsD test_aux)
    by (metis in_these_eq join_ir_nth le_less_linear length_list_update list_update_beyond nth_list_update_eq these_image_Some_eq)
qed auto

lemma lob_distinguished_2_not_subsumes:
  "\<exists>(i, l) \<in> set (get_Ins (Guards t2)). filter (\<lambda>g. gexp_constrains g (V (I i))) (Guards t2) = [(In (I i) l)] \<and>
    (\<exists>l' \<in> set l. i < Arity t1 \<and> Eq (V (I i)) (L l') \<in> set (Guards t1) \<and> size (fset_of_list l) > 1) \<Longrightarrow>
   Arity t1 = Arity t2 \<Longrightarrow>
   \<exists>i. can_take_transition t2 i c \<Longrightarrow>
   \<not> subsumes t1 c t2"
  apply (rule bad_guards)
  apply simp
  apply (simp add: can_take_def can_take_transition_def Bex_def)
  apply clarify
  apply (case_tac "\<exists>x' \<in> set b. x \<noteq> x'")
   defer
   apply (simp add: must_be_another)
  apply (simp add: Bex_def)
  apply (erule exE)
  apply (rule_tac x="list_update i a xa" in exI)
  apply simp
  apply standard
   apply (simp add: another_swap_inputs)
  by (metis Eq_apply_guards input2state_nth join_ir_def length_list_update nth_list_update_eq option.inject vname.simps(5))

definition "lob_distinguished_2 t1 t2 =
  (\<exists>(i, l) \<in> set (get_Ins (Guards t2)). filter (\<lambda>g. gexp_constrains g (V (I i))) (Guards t2) = [(In (I i) l)] \<and>
    (\<exists>l' \<in> set l. i < Arity t1 \<and> Eq (V (I i)) (L l') \<in> set (Guards t1) \<and> size (fset_of_list l) > 1) \<and>
  Arity t1 = Arity t2)"

lemma lob_distinguished_3_not_subsumes:
  "\<exists>(i, l) \<in> set (get_Ins (Guards t2)). filter (\<lambda>g. gexp_constrains g (V (I i))) (Guards t2) = [(In (I i) l)] \<and>
    (\<exists>(i', l') \<in> set (get_Ins (Guards t1)). i = i' \<and> set l' \<subset> set l) \<Longrightarrow>
   Arity t1 = Arity t2 \<Longrightarrow>
   \<exists>i. can_take_transition t2 i c \<Longrightarrow>
   \<not> subsumes t1 c t2"
  apply (rule bad_guards)
  apply simp
  apply (simp add: can_take_def can_take_transition_def Bex_def)
  apply (erule exE)+
  apply (erule conjE)+
  apply (erule exE)+
  apply (erule conjE)+
  apply (case_tac "\<exists>x. x \<in> set b \<and> x \<notin> set ba")
   defer
  apply auto[1]
  apply (erule exE)+
  apply (erule conjE)+
  apply (rule_tac x="list_update i a x" in exI)
  apply simp
  apply standard
  using another_swap_inputs apply blast
  by (metis In_apply_guards In_in_get_Ins input2state_not_None input2state_nth join_ir_def nth_list_update_eq option.distinct(1) option.inject vname.simps(5))

definition "lob_distinguished_3 t1 t2 = (\<exists>(i, l) \<in> set (get_Ins (Guards t2)). filter (\<lambda>g. gexp_constrains g (V (I i))) (Guards t2) = [(In (I i) l)] \<and>
    (\<exists>(i', l') \<in> set (get_Ins (Guards t1)). i = i' \<and> set l' \<subset> set l) \<and>
   Arity t1 = Arity t2)"

fun is_In :: "'a gexp \<Rightarrow> bool" where
  "is_In (In _ _) = True" |
  "is_In _ = False"

text\<open>The ``greatest upper bound'' (gob) heuristic is similar to \texttt{lob} but applies a more
intellegent approach to guard merging.\<close>

definition gob_aux :: "transition \<Rightarrow> transition \<Rightarrow> transition option" where
  "gob_aux t1 t2 = (if Outputs t1 = Outputs t2 \<and> Updates t1 = Updates t2 \<and> all_literal_args t1 \<and> all_literal_args t2 then
      Some \<lparr>Label = Label t1, Arity = Arity t1, Guards = remdups (filter (Not \<circ> is_In) (merge_guards (Guards t1) (Guards t2))), Outputs = Outputs t1, Updates = Updates t1\<rparr>
     else None)"

fun gob :: update_modifier where
  "gob t1ID t2ID s new _ old _ = (let
     t1 = (get_by_ids new t1ID);
     t2 = (get_by_ids new t2ID) in
     case gob_aux t1 t2 of
       None \<Rightarrow> None |
       Some gob_t \<Rightarrow>
           Some (replace_transitions new [(t1ID, gob_t), (t2ID, gob_t)])
   )"

text\<open>The ``Gung Ho'' heuristic simply drops the guards of both transitions, making them identical.\<close>
definition gung_ho_aux :: "transition \<Rightarrow> transition \<Rightarrow> transition option" where
  "gung_ho_aux t1 t2 = (if Outputs t1 = Outputs t2 \<and> Updates t1 = Updates t2 \<and> all_literal_args t1 \<and> all_literal_args t2 then
      Some \<lparr>Label = Label t1, Arity = Arity t1, Guards = [], Outputs = Outputs t1, Updates = Updates t1\<rparr>
     else None)"

fun gung_ho :: update_modifier where
  "gung_ho t1ID t2ID s new _ old _ = (let
     t1 = (get_by_ids new t1ID);
     t2 = (get_by_ids new t2ID) in
     case gung_ho_aux t1 t2 of
       None \<Rightarrow> None |
       Some gob_t \<Rightarrow>
           Some (replace_transitions new [(t1ID, gob_t), (t2ID, gob_t)])
   )"

lemma guard_subset_eq_outputs_updates_direct_subsumption:
  "Label t1 = Label t2 \<Longrightarrow>
   Arity t1 = Arity t2 \<Longrightarrow>
   Outputs t1 = Outputs t2 \<Longrightarrow>
   Updates t1 = Updates t2 \<Longrightarrow>
   set (Guards t2) \<subseteq> set (Guards t1) \<Longrightarrow>
   directly_subsumes m1 m2 s1 s2 t2 t1"
  apply (rule subsumes_in_all_contexts_directly_subsumes)
  by (simp add: guard_subset_eq_outputs_updates_subsumption)

lemma unconstrained_input:
  "\<forall>g\<in>set G. \<not> gexp_constrains g (V (I i)) \<Longrightarrow>
   apply_guards G (join_ir ia c) \<Longrightarrow>
   apply_guards G (join_ir (ia[i := x']) c)"
proof(induct G)
  case (Cons a G)
  then show ?case
    apply (simp add: apply_guards_cons)
    using input_not_constrained_gval_swap_inputs[of a i ia c x']
    by simp
qed auto

lemma each_input_guarded_once_cons:
   "\<forall>i\<in>\<Union> (enumerate_gexp_inputs ` set (a # G)). length (filter (\<lambda>g. gexp_constrains g (V (I i))) (a # G)) \<le> 1 \<Longrightarrow>
    \<forall>i\<in>\<Union> (enumerate_gexp_inputs ` set G). length (filter (\<lambda>g. gexp_constrains g (V (I i))) G) \<le> 1"
  apply (simp add: Ball_def)
  apply clarify
proof -
  fix x :: nat and xa :: "vname gexp"
  assume a1: "\<forall>x. (x \<in> enumerate_gexp_inputs a \<longrightarrow> length (if gexp_constrains a (V (I x)) then a # filter (\<lambda>g. gexp_constrains g (V (I x))) G else filter (\<lambda>g. gexp_constrains g (V (I x))) G) \<le> 1) \<and> ((\<exists>xa\<in>set G. x \<in> enumerate_gexp_inputs xa) \<longrightarrow> length (if gexp_constrains a (V (I x)) then a # filter (\<lambda>g. gexp_constrains g (V (I x))) G else filter (\<lambda>g. gexp_constrains g (V (I x))) G) \<le> 1)"
  assume a2: "xa \<in> set G"
  assume "x \<in> enumerate_gexp_inputs xa"
  then have "if gexp_constrains a (V (I x)) then length (a # filter (\<lambda>g. gexp_constrains g (V (I x))) G) \<le> 1 else length (filter (\<lambda>g. gexp_constrains g (V (I x))) G) \<le> 1"
    using a2 a1 by fastforce
  then show "length (filter (\<lambda>g. gexp_constrains g (V (I x))) G) \<le> 1"
    by (metis (no_types) impossible_Cons le_cases order.trans)
qed

lemma literal_args_can_take:
  "\<forall>g\<in>set G. \<exists>i v s. g = Eq (V (I i)) (L v) \<or> g = In (I i) s \<and> s \<noteq> [] \<Longrightarrow>
   \<forall>i\<in>\<Union> (enumerate_gexp_inputs ` set G). i < a \<Longrightarrow>
   \<forall>i\<in>\<Union> (enumerate_gexp_inputs ` set G). length (filter (\<lambda>g. gexp_constrains g (V (I i))) G) \<le> 1 \<Longrightarrow>
   \<exists>i. length i = a \<and> apply_guards G (join_ir i c)"
proof(induct G)
  case Nil
  then show ?case
    using Ex_list_of_length
    by auto
next
  case (Cons a G)
  then show ?case
    apply simp
    apply (case_tac "\<forall>y\<in>set G. \<forall>i\<in>enumerate_gexp_inputs y. length (filter (\<lambda>g. gexp_constrains g (V (I i))) G) \<le> 1")
     defer
    using each_input_guarded_once_cons apply auto[1]
    apply (simp add: ball_Un)
    apply clarsimp
    apply (induct a)
        apply simp
       apply simp
    subgoal for x2 i ia
      apply (case_tac x2)
          apply (rule_tac x="list_update i ia x1" in exI)
          apply (simp add: apply_guards_cons unconstrained_input filter_empty_conv)
         apply simp+
      done
      apply simp
    subgoal for _ x2 i ia
      apply (case_tac x2)
       apply simp
      subgoal for aa
        apply (rule_tac x="list_update i ia aa" in exI)
        apply (simp add: apply_guards_cons unconstrained_input filter_empty_conv)
        done
      done
    by simp
qed

lemma "(SOME x'. x' \<noteq> (v::value)) \<noteq> v"
proof(induct v)
  case (Num x)
  then show ?case
    by (metis (full_types) someI_ex value.simps(4))
next
  case (Str x)
  then show ?case
    by (metis (full_types) someI_ex value.simps(4))
qed

lemma opposite_gob_subsumption: "\<forall>g \<in> set (Guards t1). \<exists>i v s. g = Eq (V (I i)) (L v) \<or> (g = In (I i) s \<and> s \<noteq> []) \<Longrightarrow>
       \<forall>g \<in> set (Guards t2). \<exists>i v s. g = Eq (V (I i)) (L v) \<or> (g = In (I i) s \<and> s \<noteq> []) \<Longrightarrow>
       \<exists> i. \<exists>v. Eq (V (I i)) (L v) \<in> set (Guards t1) \<and>
         (\<forall>g \<in> set (Guards t2). \<not> gexp_constrains g (V (I i))) \<Longrightarrow>
       Arity t1 = Arity t2 \<Longrightarrow>
       \<forall>i \<in> enumerate_inputs t2. i < Arity t2 \<Longrightarrow>
       \<forall>i \<in> enumerate_inputs t2. length (filter (\<lambda>g. gexp_constrains g (V (I i))) (Guards t2)) \<le> 1 \<Longrightarrow>
       \<not> subsumes t1 c t2"
  apply (rule bad_guards)
  apply (simp add: enumerate_inputs_def can_take_transition_def can_take_def Bex_def)
  using literal_args_can_take[of "Guards t2" "Arity t2" c]
  apply simp
  apply clarify
  subgoal for i ia v
    apply (rule_tac x="list_update ia i (Eps (\<lambda>x'. x' \<noteq> v))" in exI)
    apply simp
    apply standard
     apply (simp add: apply_guards_def)
    using input_not_constrained_gval_swap_inputs apply simp
    apply (simp add: apply_guards_def Bex_def)
    apply (rule_tac x="Eq (V (I i)) (L v)" in exI)
    apply (simp add: join_ir_def)
    apply (case_tac "input2state (ia[i := SOME x'. x' \<noteq> v]) $ i")
     apply simp
    apply simp
    apply (case_tac "i < length ia")
     apply (simp add: input2state_nth)
     apply (case_tac v)
      apply (metis (mono_tags) someI_ex value.simps(4))
     apply (metis (mono_tags) someI_ex value.simps(4))
    by (metis input2state_within_bounds length_list_update)
  done

fun is_lit_eq :: "vname gexp \<Rightarrow> nat \<Rightarrow> bool" where
  "is_lit_eq (Eq (V (I i)) (L v)) i' = (i = i')" |
  "is_lit_eq _ _ = False"

lemma "(\<exists>v. Eq (V (I i)) (L v) \<in> set G) = (\<exists>g \<in> set G. is_lit_eq g i)"
  by (metis is_lit_eq.elims(2) is_lit_eq.simps(1))

fun is_lit_eq_general :: "vname gexp \<Rightarrow> bool" where
  "is_lit_eq_general (Eq (V (I _)) (L _)) = True" |
  "is_lit_eq_general _ = False"

fun is_input_in :: "vname gexp \<Rightarrow> bool" where
  "is_input_in (In (I i) s) = (s \<noteq> [])" |
  "is_input_in _ = False"

definition "opposite_gob t1 t2 = (
       (\<forall>g \<in> set (Guards t1). is_lit_eq_general g \<or> is_input_in g) \<and>
       (\<forall>g \<in> set (Guards t2). is_lit_eq_general g \<or> is_input_in g) \<and>
       (\<exists> i \<in> (enumerate_inputs t1 \<union> enumerate_inputs t2). (\<exists>g \<in> set (Guards t1). is_lit_eq g i) \<and>
         (\<forall>g \<in> set (Guards t2). \<not> gexp_constrains g (V (I i)))) \<and>
       Arity t1 = Arity t2 \<and>
       (\<forall>i \<in> enumerate_inputs t2. i < Arity t2) \<and>
       (\<forall>i \<in> enumerate_inputs t2. length (filter (\<lambda>g. gexp_constrains g (V (I i))) (Guards t2)) \<le> 1))"

lemma "is_lit_eq_general g \<or> is_input_in g \<Longrightarrow>
       \<exists>i v s. g = Eq (V (I i)) (L v) \<or> g = In (I i) s \<and> s \<noteq> []"
  by (meson is_input_in.elims(2) is_lit_eq_general.elims(2))

lemma opposite_gob_directly_subsumption:
  "opposite_gob t1 t2 \<Longrightarrow> \<not> subsumes t1 c t2"
  apply (rule opposite_gob_subsumption)
  unfolding opposite_gob_def
       apply (meson is_input_in.elims(2) is_lit_eq_general.elims(2))+
     apply (metis is_lit_eq.elims(2))
  by auto

fun get_in :: "'a gexp \<Rightarrow> ('a \<times> value list) option" where
  "get_in (In v s) = Some (v, s)" |
  "get_in _ = None"

lemma not_subset_not_in: "(\<not> s1 \<subseteq> s2) = (\<exists>i. i \<in> s1 \<and> i \<notin> s2)"
  by auto

lemma get_in_is: "(get_in x = Some (v, s1)) = (x = In v s1)"
  by (induct x, auto)

lemma gval_rearrange:
  "g \<in> set G \<Longrightarrow>
   gval g s = true \<Longrightarrow>
   apply_guards (removeAll g G) s \<Longrightarrow>
   apply_guards G s"
proof(induct G)
  case (Cons a G)
  then show ?case
    apply (simp only: apply_guards_cons)
    apply standard
     apply (metis apply_guards_cons removeAll.simps(2))
    by (metis apply_guards_cons removeAll.simps(2) removeAll_id)
qed auto

lemma singleton_list: "(length l = 1) = (\<exists>e. l = [e])"
  by (induct l, auto)

lemma remove_restricted:
  "g \<in> set G \<Longrightarrow>
   gexp_constrains g (V v) \<Longrightarrow>
   restricted_once v G \<Longrightarrow>
   not_restricted v (removeAll g G)"
  apply (simp add: restricted_once_def not_restricted_def singleton_list)
  apply clarify
  subgoal for e
    apply (case_tac "e = g")
     defer
     apply (metis (no_types, lifting) DiffE Diff_insert_absorb Set.set_insert empty_set filter.simps(2) filter_append in_set_conv_decomp insert_iff list.set(2))
    apply (simp add: filter_empty_conv)
  proof -
    fix e :: "'a gexp"
    assume "filter (\<lambda>g. gexp_constrains g (V v)) G = [g]"
    then have "{g \<in> set G. gexp_constrains g (V v)} = {g}"
      by (metis (no_types) empty_set list.simps(15) set_filter)
    then show "\<forall>g\<in>set G - {g}. \<not> gexp_constrains g (V v)"
      by blast
  qed
  done

lemma unrestricted_input_swap:
  "not_restricted (I i) G \<Longrightarrow>
   apply_guards G (join_ir iaa c) \<Longrightarrow>
   apply_guards (removeAll g G) (join_ir (iaa[i := ia]) c)"
proof(induct G)
  case (Cons a G)
  then show ?case
    apply (simp add: apply_guards_cons not_restricted_def)
    apply safe
      apply (meson neq_Nil_conv)
     apply (metis input_not_constrained_gval_swap_inputs list.distinct(1))
    by (metis list.distinct(1))
qed auto

lemma apply_guards_remove_restricted:
  "g \<in> set G \<Longrightarrow>
   gexp_constrains g (V (I i)) \<Longrightarrow>
   restricted_once (I i) G \<Longrightarrow>
   apply_guards G (join_ir iaa c) \<Longrightarrow>
   apply_guards (removeAll g G) (join_ir (iaa[i := ia]) c)"
proof(induct G)
  case (Cons a G)
  then show ?case
    apply simp
    apply safe
      apply (rule unrestricted_input_swap)
       apply (simp add: not_restricted_def restricted_once_def)
      apply (meson apply_guards_subset set_subset_Cons)
     apply (simp add: apply_guards_rearrange not_restricted_def restricted_once_def unrestricted_input_swap)
    by (metis apply_guards_cons filter.simps(2) filter_empty_conv input_not_constrained_gval_swap_inputs list.inject restricted_once_def singleton_list)
qed auto

lemma In_swap_inputs:
  "In (I i) s2 \<in> set G \<Longrightarrow>
   restricted_once (I i) G \<Longrightarrow>
   ia \<in> set s2 \<Longrightarrow>
   apply_guards G (join_ir iaa c) \<Longrightarrow>
   apply_guards G (join_ir (iaa[i := ia]) c)"
  using apply_guards_remove_restricted[of "In (I i) s2" G i iaa c ia]
  apply simp
  apply (rule gval_rearrange[of "In (I i) s2"])
    apply simp
   apply (metis filter_empty_conv gval_each_one input_not_constrained_gval_swap_inputs length_0_conv not_restricted_def remove_restricted test_aux)
  by blast

definition these :: "'a option list \<Rightarrow> 'a list" where
  "these as = map (\<lambda>x. case x of Some y \<Rightarrow> y) (filter (\<lambda>x. x \<noteq> None) as)"

lemma these_cons: "these (a#as) = (case a of None \<Rightarrow> these as | Some x \<Rightarrow> x#(these as))"
  apply (cases a)
   apply (simp add: these_def)
  by (simp add: these_def)

definition get_ins :: "vname gexp list \<Rightarrow> (nat \<times> value list) list" where
  "get_ins g = map (\<lambda>(v, s). case v of I i \<Rightarrow> (i, s)) (filter (\<lambda>(v, _). case v of I _ \<Rightarrow> True | R _ \<Rightarrow> False) (these (map get_in g)))"

lemma in_get_ins:
  "(I x1a, b) \<in> set (these (map get_in G)) \<Longrightarrow>
   In (I x1a) b \<in> set G"
proof(induct G)
  case Nil
  then show ?case
    by (simp add: these_def)
next
  case (Cons a G)
  then show ?case
    apply simp
    apply (simp add: these_cons)
    apply (cases a)
    by auto
qed

lemma restricted_head: "\<forall>v. restricted_once v (Eq (V x2) (L x1) # G) \<or> not_restricted v (Eq (V x2) (L x1) # G) \<Longrightarrow>
      not_restricted x2 G"
  apply (erule_tac x=x2 in allE)
  by (simp add: restricted_once_def not_restricted_def)

fun atomic :: "'a gexp \<Rightarrow> bool" where
  "atomic (Eq (V _) (L _)) = True" |
  "atomic (In _ _) = True" |
  "atomic _ = False"

lemma restricted_max_once_cons: "\<forall>v. restricted_once v (g#gs) \<or> not_restricted v (g#gs) \<Longrightarrow>
       \<forall>v. restricted_once v gs \<or> not_restricted v gs"
  apply (simp add: restricted_once_def not_restricted_def)
  apply safe
  subgoal for v
    by (erule_tac x=v in allE)
      (metis (mono_tags, lifting) list.distinct(1) list.inject singleton_list)
  done

lemma not_restricted_swap_inputs:
  "not_restricted (I x1a) G \<Longrightarrow>
   apply_guards G (join_ir i r) \<Longrightarrow>
   apply_guards G (join_ir (i[x1a := x1]) r)"
proof(induct G)
  case (Cons a G)
  then show ?case
    apply (simp add: apply_guards_cons not_restricted_cons)
    using input_not_constrained_gval_swap_inputs by auto
qed auto
end