(*<*)
(* An abstract completeness theorem *)
theory Abstract_Completeness
imports
  "../Collections/ICF/tools/Locale_Code"
  "~~/src/HOL/Library/Countable_Set"
  "~~/src/HOL/Library/FSet"
  "~~/src/HOL/Library/Code_Target_Nat"
  "~~/src/HOL/Library/Linear_Temporal_Logic_on_Streams"
begin
(*>*)

section{* General Tree Concepts *}

codatatype 'a tree = Node (root: 'a) (cont: "'a tree fset")

inductive tfinite where
  tfinite: "(\<And> t'. t' |\<in>| cont t \<Longrightarrow> tfinite t') \<Longrightarrow> tfinite t"

(*<*)(* Infinite paths in trees. *)(*>*)
coinductive ipath where
  ipath: "\<lbrakk>root t = shd steps; t' |\<in>| cont t; ipath t' (stl steps)\<rbrakk> \<Longrightarrow> ipath t steps"

(*<*)(* Finite trees have no infinite paths. *)
lemma ftree_no_ipath: "tfinite t \<Longrightarrow> \<not> ipath t steps"
  by (induct t arbitrary: steps rule: tfinite.induct) (auto elim: ipath.cases)
(*>*)

primcorec konig where
  "shd (konig t) = root t"
| "stl (konig t) = konig (SOME t'. t' |\<in>| cont t \<and> \<not> tfinite t')"

lemma Konig: "\<not> tfinite t \<Longrightarrow> ipath t (konig t)"
  by (coinduction arbitrary: t) (metis (lifting) tfinite.simps konig.simps someI_ex)

section{* Rule Systems *}

(*<*)(* A step consists of a pair (s,r) such that the rule r is taken in state s. *)(*>*)
type_synonym ('state, 'rule) step = "'state \<times> 'rule"
(*<*)(* A derivation tree is a tree of steps: *)(*>*)
type_synonym ('state, 'rule) dtree = "('state, 'rule) step tree"

locale RuleSystem_Defs =
fixes eff :: "'rule \<Rightarrow> 'state \<Rightarrow> 'state fset \<Rightarrow> bool"
(* The countable set of rules is initially provided as a stream: *)
and rules :: "'rule stream"
begin

abbreviation "R \<equiv> sset rules"

lemma countable_R: "countable R" by (metis countableI_type countable_image sset_range)
lemma NE_R: "R \<noteq> {}" by (metis UNIV_witness all_not_in_conv empty_is_image sset_range)

definition "enabled r s \<equiv> \<exists> sl. eff r s sl"
definition "pickEff r s \<equiv> if enabled r s then (SOME sl. eff r s sl) else the None"

lemma pickEff: "enabled r s \<Longrightarrow> eff r s (pickEff r s)"
  by (metis enabled_def pickEff_def tfl_some)

abbreviation "effStep step \<equiv> eff (snd step) (fst step)"
abbreviation "enabledAtStep r step \<equiv> enabled r (fst step)"
abbreviation "takenAtStep r step \<equiv> snd step = r"

text {* Saturation is a very strong notion of fairness:
  If a rule is enabled at some point, it will eventually be taken. *}
definition "saturated r \<equiv> alw (holds (enabledAtStep r) impl ev (holds (takenAtStep r)))"
definition "Saturated steps \<equiv> \<forall> r \<in> R. saturated r steps"

(*<*)(* Well-formed derivation trees *)(*>*)
coinductive wf where
  wf: "\<lbrakk>snd (root t) \<in> R; effStep (root t) (fimage (fst o root) (cont t));
    \<And>t'. t' |\<in>| cont t \<Longrightarrow> wf t'\<rbrakk> \<Longrightarrow> wf t"

(*<*)(* Escape paths *)(*>*)
coinductive epath where
  epath: "\<lbrakk>snd (shd steps) \<in> R; fst (shd (stl steps)) |\<in>| sl; effStep (shd steps) sl;
    epath (stl steps)\<rbrakk> \<Longrightarrow> epath steps"

lemma wf_ipath_epath:
  assumes "wf t" "ipath t steps"
  shows "epath steps"
proof -
  have *: "\<And>t st. ipath t st \<Longrightarrow> root t = shd st" by (auto elim: ipath.cases)
  show ?thesis using assms
  proof (coinduction arbitrary: t steps)
    case epath
    then show ?case by (cases rule: wf.cases[case_product ipath.cases]) (metis * o_apply fimageI)
  qed
qed

definition "fair rs \<equiv> sset rs \<subseteq> R \<and> (\<forall> r \<in> R. alw (ev (holds (op= r))) rs)"

lemma fair_stl: "fair rs \<Longrightarrow> fair (stl rs)"
  unfolding fair_def by (metis alw.simps set_mp stl_sset subsetI)

section{* A Fair Enumeration of the Rules *}

(*<*)(* The fair enumeration of rules *)(*>*)
definition "fenum \<equiv> flat (smap (\<lambda>n. stake n rules) (fromN 1))"

lemma sset_fenum: "sset fenum = R"
  unfolding fenum_def by (subst sset_flat)
   (auto simp: stream.set_map in_set_conv_nth sset_range[of rules],
     metis atLeast_Suc_greaterThan greaterThan_0 lessI range_eqI stake_nth)

lemma fair_fenum: "fair fenum"
proof -
  { fix r assume "r \<in> R"
    then obtain m where r: "r = rules !! m" unfolding sset_range by blast
    { fix n :: nat and rs let ?fenum = "\<lambda>n. flat (smap (\<lambda>n. stake n rules) (fromN n))"
      assume "n > 0"
      hence "alw (ev (holds (op= r))) (rs @- ?fenum n)"
      proof (coinduction arbitrary: n rs)
        case alw
        show ?case
        proof (rule exI[of _ "rs @- ?fenum n"], safe)
          show "\<exists>n' rs'. stl (rs @- ?fenum n) = rs' @- ?fenum n' \<and> n' > 0"
          proof(cases rs)
            case Nil thus ?thesis unfolding alw by (intro exI) auto
          qed (auto simp: alw intro: exI[of _ n])
        qed (insert alw, cases "m < n",
          auto simp: ev_holds_sset r stream.set_map in_set_conv_nth, auto)
     qed
    }
  }
  thus "fair fenum" unfolding fair_def sset_fenum
    by (metis fenum_def alw_shift le_less zero_less_one)
qed

definition "trim rs s = sdrop_while (\<lambda>r. Not (enabled r s)) rs"

(*<*)(* The fair tree associated to a stream of rules and a state *)(*>*)
primcorec mkTree where
  "root (mkTree rs s) = (s, (shd (trim rs s)))"
| "cont (mkTree rs s) = fimage (mkTree (stl (trim rs s))) (pickEff (shd (trim rs s)) s)"

(*<*)(* More efficient code equation for mkTree *)(*>*)
lemma mkTree_unfold[code]: "mkTree rs s =
  (case trim rs s of SCons r s' \<Rightarrow> Node (s, r) (fimage (mkTree s') (pickEff r s)))"
  by (subst mkTree.ctr) (simp split: stream.splits)

end

locale RuleSystem = RuleSystem_Defs eff rules
for eff :: "'rule \<Rightarrow> 'state \<Rightarrow> 'state fset \<Rightarrow> bool" and rules :: "'rule stream" +
fixes S :: "'state set"
assumes eff_S: "\<And> s r sl s'. \<lbrakk>s \<in> S; r \<in> R; eff r s sl; s' |\<in>| sl\<rbrakk> \<Longrightarrow> s' \<in> S"
and enabled_R: "\<And> s. s \<in> S \<Longrightarrow> \<exists> r \<in> R. \<exists> sl. eff r s sl"
begin

(*<*)(* The minimum waiting time in a stream for the enabled rules in a given state: *)(*>*)
definition "minWait rs s \<equiv> LEAST n. enabled (shd (sdrop n rs)) s"

lemma trim_alt:
  assumes s: "s \<in> S" and rs: "fair rs"
  shows "trim rs s = sdrop (minWait rs s) rs"
proof (unfold trim_def minWait_def sdrop_simps, rule sdrop_while_sdrop_LEAST[unfolded o_def])
  from enabled_R[OF s] obtain r sl where r: "r \<in> R" and sl: "eff r s sl" by blast
  from bspec[OF conjunct2[OF rs[unfolded fair_def]] r] obtain m where "r = rs !! m"
    by atomize_elim (erule alw.cases, auto simp only: ev_holds_sset sset_range)
  with r sl show "\<exists>n. enabled (rs !! n) s" unfolding enabled_def by auto
qed

lemma minWait_ex:
  assumes s: "s \<in> S" and rs: "fair rs"
  shows "\<exists> n. enabled (shd (sdrop n rs)) s"
proof -
  obtain r where r: "r \<in> R" and e: "enabled r s" using enabled_R s unfolding enabled_def by blast
  then obtain n where "shd (sdrop n rs) = r" using sdrop_fair[OF rs]
    by (metis (full_types) alw_nxt holds.simps sdrop.simps(1) fair_def sdrop_wait)
  thus ?thesis using r e by auto
qed

lemma assumes "s \<in> S" and "fair rs"
  shows trim_in_R: "shd (trim rs s) \<in> R"
  and trim_enabled: "enabled (shd (trim rs s)) s"
  and trim_fair: "fair (trim rs s)"
  unfolding trim_alt[OF assms] minWait_def
  using LeastI_ex[OF minWait_ex[OF assms]] sdrop_fair[OF assms(2)]
    conjunct1[OF assms(2)[unfolded fair_def]] by simp_all (metis set_mp snth_sset)

lemma minWait_least: "\<lbrakk>enabled (shd (sdrop n rs)) s\<rbrakk> \<Longrightarrow> minWait rs s \<le> n"
  unfolding minWait_def by (intro Least_le conjI)

lemma in_cont_mkTree:
  assumes s: "s \<in> S" and rs: "fair rs" and t': "t' |\<in>| cont (mkTree rs s)"
  shows "\<exists> sl' s'. s' \<in> S \<and> eff (shd (trim rs s)) s sl' \<and>
                 s' |\<in>| sl' \<and> t' = mkTree (stl (trim rs s)) s'"
proof -
  def sl' \<equiv> "pickEff (shd (trim rs s)) s"
  obtain s' where s': "s' |\<in>| sl'" and "t' = mkTree (stl (trim rs s)) s'"
    using t' unfolding sl'_def by auto
  moreover have 1: "enabled (shd (trim rs s)) s" using trim_enabled[OF s rs] .
  moreover with trim_in_R pickEff eff_S s rs s'[unfolded sl'_def] have "s' \<in> S" by blast
  ultimately show ?thesis unfolding sl'_def using pickEff by blast
qed

lemma ipath_mkTree_sdrop:
  assumes s: "s \<in> S" and rs: "fair rs" and i: "ipath (mkTree rs s) steps"
  shows "\<exists> n s'. s' \<in> S \<and> ipath (mkTree (sdrop n rs) s') (sdrop m steps)"
using s rs i proof (induct m arbitrary: steps rs)
  case (Suc m)
  then obtain n s' where s': "s' \<in> S"
    and ip: "ipath (mkTree (sdrop n rs) s') (sdrop m steps)" (is "ipath ?t _") by blast
  from ip obtain t' where r: "root ?t = shd (sdrop m steps)" and t': "t' |\<in>| cont ?t"
    and i: "ipath t' (sdrop (Suc m) steps)" by (cases, simp)
  from in_cont_mkTree[OF s' sdrop_fair[OF Suc.prems(2)] t'] obtain sl'' s'' where
    e: "eff (shd (trim (sdrop n rs) s')) s' sl''" and
    s'': "s'' |\<in>| sl''" and t'_def: "t' = mkTree (stl (trim (sdrop n rs) s')) s''" by blast
  have "shd (trim (sdrop n rs) s') \<in> R" by (metis sdrop_fair Suc.prems(2) trim_in_R s')
  thus ?case using i s'' e s' unfolding sdrop_stl t'_def sdrop_add add.commute[of n]
    trim_alt[OF s' sdrop_fair[OF Suc.prems(2)]]
    by (intro exI[of _ "minWait (sdrop n rs) s' + Suc n"] exI[of _ s'']) (simp add: eff_S)
qed (auto intro!: exI[of _ 0] exI[of _ s])

lemma wf_mkTree:
  assumes s: "s \<in> S" and "fair rs"
  shows "wf (mkTree rs s)"
using assms proof (coinduction arbitrary: rs s)
  case (wf rs s) let ?t = "mkTree rs s"
  have "snd (root ?t) \<in> R" using trim_in_R[OF wf] by simp
  moreover have "fst \<circ> root \<circ> mkTree (stl (trim rs s)) = id" by auto
  hence "effStep (root ?t) (fimage (fst \<circ> root) (cont ?t))"
    using trim_enabled[OF wf] by (simp add: pickEff)
  ultimately show ?case using fair_stl[OF trim_fair[OF wf]] in_cont_mkTree[OF wf]
    by (auto intro!: exI[of _ "stl (trim rs s)"])
qed

(*<*)(* The position of a rule in a rule stream *)(*>*)
definition "pos rs r \<equiv> LEAST n. shd (sdrop n rs) = r"

lemma pos: "\<lbrakk>fair rs; r \<in> R\<rbrakk> \<Longrightarrow> shd (sdrop (pos rs r) rs) = r"
  unfolding pos_def
  by (rule LeastI_ex) (metis (full_types) alw.cases assms fair_def holds.simps sdrop_wait)

lemma pos_least: "shd (sdrop n rs) = r \<Longrightarrow> pos rs r \<le> n"
  unfolding pos_def by (metis (full_types) Least_le)

lemma minWait_le_pos: "\<lbrakk>fair rs; r \<in> R; enabled r s\<rbrakk> \<Longrightarrow> minWait rs s \<le> pos rs r"
  by (auto simp del: sdrop_simps intro: minWait_least simp: pos)

lemma stake_pos_minWait:
  assumes rs: "fair rs" and m: "minWait rs s < pos rs r" and r: "r \<in> R" and s: "s \<in> S"
  shows "pos (stl (trim rs s)) r = pos rs r - Suc (minWait rs s)"
proof -
  have "pos rs r - Suc (minWait rs s) + minWait rs s = pos rs r - Suc 0" using m by auto
  moreover have "shd (stl (sdrop (pos rs r - Suc 0) rs)) = shd (sdrop (pos rs r) rs)"
    by (metis Suc_pred gr_implies_not0 m neq0_conv sdrop.simps(2) sdrop_stl)
  ultimately have "pos (stl (trim rs s)) r \<le> pos rs r - Suc (minWait rs s)"
    using pos[OF rs r] by (auto simp: add.commute trim_alt[OF s rs] intro: pos_least)
  moreover
  have "pos rs r \<le> pos (stl (trim rs s)) r + Suc (minWait rs s)"
    using pos[OF sdrop_fair[OF fair_stl[OF rs]] r, of "minWait rs s"]
    by (auto simp: trim_alt[OF s rs] add.commute intro: pos_least)
  hence "pos rs r - Suc (minWait rs s) \<le> pos (stl (trim rs s)) r" by linarith
  ultimately show ?thesis by simp
qed

lemma ipath_mkTree_ev:
  assumes s: "s \<in> S" and rs: "fair rs"
  and i: "ipath (mkTree rs s) steps" and r: "r \<in> R"
  and alw: "alw (holds (enabledAtStep r)) steps"
  shows "ev (holds (takenAtStep r)) steps"
using s rs i alw proof (induction "pos rs r" arbitrary: rs s steps rule: less_induct)
  case (less rs s steps) note s = `s \<in> S` and trim_def' = trim_alt[OF s `fair rs`]
  let ?t = "mkTree rs s"
  from less(4,3) s in_cont_mkTree obtain t' :: "('state, 'rule) step tree" and s' where
    rt: "root ?t = shd steps" and i: "ipath (mkTree (stl (trim rs s)) s') (stl steps)" and
    s': "s' \<in> S" by cases fast
  show ?case
  proof(cases "pos rs r = minWait rs s")
    case True
    with pos[OF less.prems(2) r] rt[symmetric] show ?thesis by (auto simp: trim_def' ev.base)
  next
    case False
    have e: "enabled r s" using less.prems(4) rt  by (subst (asm) alw_nxt, cases steps) auto
    with False r less.prems(2) have 2: "minWait rs s < pos rs r" using minWait_le_pos by force
    let ?m1 = "pos rs r - Suc (minWait rs s)"
    have "Suc ?m1 \<le> pos rs r" using 2 by auto
    moreover have "?m1 = pos (stl (trim rs s)) r" using e `fair rs` 2 r s
      by (auto intro: stake_pos_minWait[symmetric])
    moreover have "fair (stl (trim rs s))" "alw (holds (enabledAtStep r)) (stl steps)"
      using less.prems by (metis fair_stl trim_fair, metis alw.simps)
    ultimately show "?thesis" by (auto intro: ev.step[OF less.hyps[OF _ s' _ i]])
  qed
qed

section{* Persistent rules *}

definition
  "per r \<equiv>
    \<forall>s r1 sl' s'. s \<in> S \<and> enabled r s \<and> r1 \<in> R - {r} \<and> eff r1 s sl' \<and> s' |\<in>| sl' \<longrightarrow> enabled r s'"

lemma per_alw:
  assumes p: "per r" and e: "epath steps \<and> fst (shd steps) \<in> S"
  shows "alw (holds (enabledAtStep r) impl
    (holds (takenAtStep r) or nxt (holds (enabledAtStep r)))) steps"
using e proof coinduct
  case (alw steps)
  moreover
  { let ?s = "fst (shd steps)"  let ?r1 = "snd (shd steps)"
    let ?s' = "fst (shd (stl steps))"
    assume "?s \<in> S" and "enabled r ?s" and "?r1 \<noteq> r"
    moreover have "?r1 \<in> R" using alw by (auto elim: epath.cases)
    moreover obtain sl' where "eff ?r1 ?s sl' \<and> ?s' |\<in>| sl'" using alw by (auto elim: epath.cases)
    ultimately have "enabled r ?s'" using p unfolding per_def by blast
  }
  ultimately show ?case by (auto intro: eff_S elim: epath.cases)
qed

end -- {* context RuleSystem *}

(*<*) (* Rule-persistent rule system *) (*>*)
locale PersistentRuleSystem = RuleSystem eff rules S
for eff :: "'rule \<Rightarrow> 'state \<Rightarrow> 'state fset \<Rightarrow> bool" and rules :: "'rule stream" and S +
assumes per: "\<And> r. r \<in> R \<Longrightarrow> per r"
begin

lemma ipath_mkTree_saturated:
  assumes s: "s \<in> S" and rs: "fair rs"
  and i: "ipath (mkTree rs s) steps" and r: "r \<in> R"
  shows "saturated r steps"
unfolding saturated_def using s rs i proof (coinduction arbitrary: rs s steps)
  case (alw rs s steps)
  show ?case
  proof (intro exI[of _ steps], safe)
    assume "holds (enabledAtStep r) steps"
    hence "alw (holds (enabledAtStep r)) steps \<or> ev (holds (takenAtStep r)) steps"
      by (rule variance[OF _ per_alw[OF per[OF r]]])
        (metis wf_ipath_epath wf_mkTree alw mkTree.simps(1) ipath.simps fst_conv)
    thus "ev (holds (takenAtStep r)) steps" by (metis ipath_mkTree_ev[OF alw r])
  next
    from alw show "\<exists>rs' s' steps'.
      stl steps = steps' \<and> s' \<in> S \<and> fair rs' \<and> ipath (mkTree rs' s') steps'"
      using ipath_mkTree_sdrop[where m=1, simplified] trim_in_R sdrop_fair by fast
  qed
qed

theorem ipath_mkTree_Saturated:
  assumes "s \<in> S" and "fair rs" and "ipath (mkTree rs s) steps"
  shows "Saturated steps"
  unfolding Saturated_def using ipath_mkTree_saturated[OF assms] by blast

theorem epath_completeness_Saturated:
  assumes "s \<in> S"
  shows
  "(\<exists> t. fst (root t) = s \<and> wf t \<and> tfinite t) \<or>
   (\<exists> steps. fst (shd steps) = s \<and> epath steps \<and> Saturated steps)" (is "?A \<or> ?B")
proof -
  { assume "\<not> ?A"
    with assms have "\<not> tfinite (mkTree fenum s)" using wf_mkTree fair_fenum by auto
    then obtain steps where "ipath (mkTree fenum s) steps" using Konig by blast
    with assms have "fst (shd steps) = s \<and> epath steps \<and> Saturated steps"
      by (metis wf_ipath_epath ipath.simps ipath_mkTree_Saturated
        wf_mkTree fair_fenum mkTree.simps(1) fst_conv)
    hence ?B by blast
  }
  thus ?thesis by blast
qed

end -- {* context PersistentRuleSystem *}

section{* Code generation *}

(* Here we assume a deterministic effect eff': *)

locale RuleSystem_Code =
fixes eff' :: "'rule \<Rightarrow> 'state \<Rightarrow> 'state fset option"
and rules :: "'rule stream" -- {* countably many rules *}
begin

definition "eff r s sl \<equiv> eff' r s = Some sl"

end (* context RuleSystem_Code *)

definition [code del]: "effG eff' r s sl \<equiv> RuleSystem_Code.eff eff' r s sl"

sublocale RuleSystem_Code < RuleSystem_Defs
  where eff = "effG eff'" and rules = rules .

context RuleSystem_Code
begin

lemma enabled_eff': "enabled r s \<longleftrightarrow> eff' r s \<noteq> None"
unfolding enabled_def effG_def eff_def by auto

lemma pickEff_the[code]: "pickEff r s = the (eff' r s)"
unfolding pickEff_def enabled_def effG_def eff_def by auto

lemmas [code_unfold] = trim_def enabled_eff' pickEff_the

(*<*)
end (* context RuleSystem_Code *)
(*>*)

setup Locale_Code.open_block
interpretation i!: RuleSystem_Code eff' rules for eff' and rules .
declare [[lc_delete "RuleSystem_Defs.mkTree (effG ?eff')"]]
declare [[lc_delete RuleSystem_Defs.trim]]
declare [[lc_delete RuleSystem_Defs.enabled]]
declare [[lc_delete RuleSystem_Defs.pickEff]]
declare [[lc_add "RuleSystem_Defs.mkTree (effG ?eff')" i.mkTree_unfold]]
setup Locale_Code.close_block

code_printing
  constant the \<rightharpoonup> (Haskell) "fromJust"
| constant Option.is_none \<rightharpoonup> (Haskell) "isNothing"

export_code mkTree_effG_uu in Haskell module_name Tree (*file "."*)

(*<*)
end
(*>*)


theory BLP_RM
imports BLP_Monitor "../Reference_Monitor/Reference_Monitor"
begin

context BLP_Monitor
begin

text \<open>We show that a Bell/LaPadula monitor satisfies the reference monitor assumptions of Rushby.
Hence, in a specific sense, a Bell/LaPadula monitor satisfies a noninterference policy.\<close>

definition contents :: "('obj, 'val) state \<Rightarrow> 'obj \<Rightarrow> 'val" where
  [simp]: "contents s obj = s obj"

definition observe :: "'level \<Rightarrow> 'obj set" where
  [simp]: "observe l = {obj. oc obj \<le> l}"

definition alter :: "'level \<Rightarrow> 'obj set" where
  [simp]: "alter l = {obj. l \<le> oc obj}"

sublocale Structured_State init step out contents .

text \<open>The lattice of security levels of a Bell/LaPadula policy can be interpreted as a flow policy
in the sense of Goguen-Meseguer: @{text "(l \<leadsto> l') \<longleftrightarrow> (l \<le> l')"}\<close>

definition FP :: "'level rel" where
  "FP = {(l, l'). l \<le> l'}"

text \<open>We now have to define the labeling of actions with security domains/levels.

In the following, we choose the labeling according to subject. The intuition is that an observer on
level @{text l} may see the actions (and outputs of those actions) of all users with a clearance of
@{text l} and below, while the observer must not learn anything about actions of users in other
security levels.\<close>

primrec dom :: "('subj, 'obj, 'val) act \<Rightarrow> 'level" where
  "dom (R subj obj) = sc subj"
| "dom (W subj obj val) = sc subj"

text \<open>We now instantiate the Reference_Monitor locale, proving the reference monitor assumptions.\<close>

text \<open>We first show that @{text observe} and @{text alter} are consistent with the flow policy
@{text FP}:\<close>

sublocale FP_Implementation init step out contents FP dom observe alter
proof
  show "refl FP" and "trans FP"
    by (auto simp add: FP_def refl_on_def trans_def)
next
  fix u v
  assume "(u, v) \<in> FP"
  then show "observe u \<subseteq> observe v"
    by (auto simp add: FP_def)
next
  fix n u v
  assume "n \<in> alter u" and "n \<in> observe v"
  then show "(u, v) \<in> FP"
    by (auto simp add: FP_def)
qed

notation view'' ("_ \<sim>\<^bsub>_\<^esub> _")

text \<open>We then show the remaining reference monitor assumptions:\<close>

sublocale Reference_Monitor init step out contents FP dom observe alter
proof
  fix s t a
  assume "s \<sim>\<^bsub>dom a\<^esub> t"
  with read_secure show "out s a = out t a"
    by (cases a) (auto simp add: view_def)
next
  fix s t a n
  assume "contents (step s a) n \<noteq> contents s n \<or> contents (step t a) n \<noteq> contents t n"
  then show "contents (step s a) n = contents (step t a) n"
    by (cases a) (auto split: if_splits)
next
  fix s a n
  assume "contents (step s a) n \<noteq> contents s n"
  with write_secure show "n \<in> alter (dom a)"
    by (cases a) (auto split: if_splits)
qed

notation flow ("_ \<leadsto> _")

lemma "(l \<leadsto> l') \<longleftrightarrow> (l \<le> l')"
by (auto simp add: FP_def)

thm dom.simps

thm monitor_secure

end

end


(*<*)
theory QML
imports Relations
begin
nitpick_params[user_axioms=true, show_all, expect=genuine, format = 3, atoms e = a b c d]
(*>*)

section \<open>Embedding of Quantified Modal Logic\<close>
text\<open>\noindent{As is well known, the Isabelle proof assistant @{cite "Isabelle"} does not natively support modal logics, so
we have used a technique known as \emph{shallow semantic embedding}, which allows us
to take advantage of the expressive power of higher-order logic in order to embed the semantics
of an object language. We draw on previous work on the embedding of multimodal logics in HOL @{cite "J23"},
which has successfully been applied to the analysis and verification of ontological arguments
(e.g. @{cite C55 and J32 and J35}).}\<close>

subsection \<open>Type Declarations\<close>

typedecl e                        \<comment> \<open>Type for entities\<close>
typedecl w                        \<comment> \<open>Type for worlds\<close>
type_synonym wo = "w\<Rightarrow>bool" \<comment> \<open>Type for world-dependent formulas\<close>

subsection \<open>Logical Constants as Truth-Sets\<close>
text\<open>\noindent{Using the technique of \emph{shallow semantic embedding} each operator gets defined as a function
on world-dependent formulas or \emph{truth sets}.}\<close>

abbreviation mand::"wo\<Rightarrow>wo\<Rightarrow>wo" (infixr "\<^bold>\<and>"(*<*)51(*>*))
  where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. (\<phi> w)\<and>(\<psi> w)"
abbreviation mor::"wo\<Rightarrow>wo\<Rightarrow>wo" (infixr "\<^bold>\<or>"(*<*)50(*>*))
  where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. (\<phi> w)\<or>(\<psi> w)"
abbreviation mimp::"wo\<Rightarrow>wo\<Rightarrow>wo" (infixr "\<^bold>\<rightarrow>"(*<*)49(*>*))
  where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. (\<phi> w)\<longrightarrow>(\<psi> w)"
abbreviation mequ::"wo\<Rightarrow>wo\<Rightarrow>wo" (infix "\<^bold>\<leftrightarrow>"(*<*)48(*>*))
  where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w. (\<phi> w)\<longleftrightarrow>(\<psi> w)"
abbreviation mnot::"wo\<Rightarrow>wo" ("\<^bold>\<not>_"(*<*)[52]53(*>*))
  where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>(\<phi> w)"
(*<*)
abbreviation xor:: "bool\<Rightarrow>bool\<Rightarrow>bool" (infix"\<oplus>"50) where "\<phi>\<oplus>\<psi> \<equiv>  (\<phi>\<or>\<psi>) \<and> \<not>(\<phi>\<and>\<psi>)"
abbreviation mxor::"wo\<Rightarrow>wo\<Rightarrow>wo" (infix"\<^bold>\<oplus>"50) where "\<phi>\<^bold>\<oplus>\<psi> \<equiv> \<lambda>w. (\<phi> w)\<oplus>(\<psi> w)"
(*>*)

text\<open>\noindent{We embed a modal logic \emph{K} by defining the box and diamond operators using restricted quantification
over the set of `accessible' worlds (using an \emph{accessibility} relation \emph{R} as a guard).}\<close>

consts R::"w\<Rightarrow>w\<Rightarrow>bool" (infix "r"(*<*)70(*>*)) \<comment> \<open>Accessibility relation\<close>
abbreviation mbox :: "wo\<Rightarrow>wo" ("\<^bold>\<box>_"(*<*)[52]53(*>*))
  where "\<^bold>\<box>\<phi> \<equiv> \<lambda>w.\<forall>v. (w r v)\<longrightarrow>(\<phi> v)"
abbreviation mdia :: "wo\<Rightarrow>wo" ("\<^bold>\<diamond>_"(*<*)[52]53(*>*))
  where "\<^bold>\<diamond>\<phi> \<equiv> \<lambda>w.\<exists>v. (w r v)\<and>(\<phi> v)"

subsection \<open>Quantification\<close>
text\<open>\noindent{Quantifiers are defined analogously.}\<close>

abbreviation mforall::"('t\<Rightarrow>wo)\<Rightarrow>wo" ("\<^bold>\<forall>")
  where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w.\<forall>x. (\<Phi> x w)"
abbreviation mexists::"('t\<Rightarrow>wo)\<Rightarrow>wo" ("\<^bold>\<exists>")
  where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>w.\<exists>x. (\<Phi> x w)"
abbreviation mforallB  :: "('t\<Rightarrow>wo)\<Rightarrow>wo" (binder "\<^bold>\<forall>"(*<*)[8]9(*>*))
  where "\<^bold>\<forall>x. (\<phi> x) \<equiv> \<^bold>\<forall>\<phi>"
abbreviation mexistsB  :: "('t\<Rightarrow>wo)\<Rightarrow>wo" (binder "\<^bold>\<exists>"(*<*)[8]9(*>*))
  where "\<^bold>\<exists>x. (\<phi> x) \<equiv> \<^bold>\<exists>\<phi>"

subsection \<open>Equality\<close>
text\<open>\noindent{Two different definitions of equality are given. The first one is an extension of standard
equality for use in world-dependent formulas. The second is the well-known Leibniz equality.}\<close>
abbreviation meq:: "'t\<Rightarrow>'t\<Rightarrow>wo" (infix "\<^bold>\<approx>"(*<*)60(*>*))
  where "x \<^bold>\<approx> y \<equiv> \<lambda>w. x = y"
abbreviation meqL:: "e\<Rightarrow>e\<Rightarrow>wo" (infix "\<^bold>\<approx>\<^sup>L"(*<*)52(*>*))
  where "x \<^bold>\<approx>\<^sup>L y \<equiv> \<lambda>w. \<forall>\<phi>. (\<phi> x w)\<longrightarrow>(\<phi> y w)"

subsection \<open>Validity\<close>
text\<open>\noindent{Validity is defined as truth in \emph{all} worlds and represented by wrapping the formula
in special brackets (\<open>\<lfloor>-\<rfloor>\<close>).}\<close>
abbreviation valid::"wo\<Rightarrow>bool" ("\<lfloor>_\<rfloor>") where "\<lfloor>\<psi>\<rfloor> \<equiv>  \<forall>w.(\<psi> w)"

subsection \<open>Verifying the Embedding\<close>
text\<open>\noindent{The above definitions introduce modal logic \emph{K} with quantification,
as evidenced by the following tests.}\<close>

text\<open>\noindent{(Converse-)Barcan formulas are validated in this embedding.}\<close>
lemma "\<lfloor>(\<^bold>\<forall>x.\<^bold>\<box>(\<phi> x)) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x.(\<phi> x))\<rfloor>" by simp
lemma "\<lfloor>\<^bold>\<box>(\<^bold>\<forall>x.(\<phi> x)) \<^bold>\<rightarrow> (\<^bold>\<forall>x.\<^bold>\<box>(\<phi> x))\<rfloor>" by simp

text\<open>\noindent{\<open>\<beta>\<close>-redex is valid.}\<close>
lemma "\<lfloor>(\<lambda>\<alpha>. \<phi> \<alpha>) (\<tau>::w\<Rightarrow>e) \<^bold>\<leftrightarrow> (\<phi>  \<tau>)\<rfloor>" by simp
lemma "\<lfloor>(\<lambda>\<alpha>. \<phi> \<alpha>) (\<tau>::e) \<^bold>\<leftrightarrow> (\<phi>  \<tau>)\<rfloor>" by simp
lemma "\<lfloor>(\<lambda>\<alpha>. \<^bold>\<box>\<phi> \<alpha>) (\<tau>::w\<Rightarrow>e) \<^bold>\<leftrightarrow> (\<^bold>\<box>\<phi> \<tau>)\<rfloor>" by simp
lemma "\<lfloor>(\<lambda>\<alpha>. \<^bold>\<box>\<phi> \<alpha>) (\<tau>::e) \<^bold>\<leftrightarrow> (\<^bold>\<box>\<phi> \<tau>)\<rfloor>" by simp

text\<open>\noindent{Modal collapse is countersatisfiable, as shown by Nitpick @{cite "Nitpick"}.}\<close>
lemma "\<lfloor>\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<phi>\<rfloor>" nitpick oops

subsection \<open>Axiomatization of Further Logics\<close>

text\<open>\noindent{The best-known normal logics (\emph{K4, K5, KB, K45, KB5, D, D4, D5, ...}) can be obtained by
combinations of the following axioms.}\<close>
abbreviation T  where "T \<equiv> \<^bold>\<forall>\<phi>. \<^bold>\<box>\<phi> \<^bold>\<rightarrow> \<phi>"
abbreviation B  where "B \<equiv> \<^bold>\<forall>\<phi>. \<phi> \<^bold>\<rightarrow>  \<^bold>\<box>\<^bold>\<diamond>\<phi>"
abbreviation D  where "D \<equiv> \<^bold>\<forall>\<phi>. \<^bold>\<box>\<phi> \<^bold>\<rightarrow> \<^bold>\<diamond>\<phi>"
abbreviation IV where "IV \<equiv> \<^bold>\<forall>\<phi>. \<^bold>\<box>\<phi> \<^bold>\<rightarrow>  \<^bold>\<box>\<^bold>\<box>\<phi>"
abbreviation V  where "V \<equiv> \<^bold>\<forall>\<phi>. \<^bold>\<diamond>\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<diamond>\<phi>"

text\<open>\noindent{Instead of postulating combinations of the above  axioms we make use of
the well-known \emph{Sahlqvist correspondence}, which links axioms to constraints on a model's accessibility
relation (cf. @{cite "J23"} for further details).
We show  that  reflexivity, symmetry, seriality, transitivity and euclideanness imply
axioms \emph{T, B, D, IV, V} respectively.\footnote{Implication can also be proven in the reverse direction
(which is not needed for our purposes).
Using these definitions, we can derive axioms for the most common modal logics (see also @{cite "C47"}).
Thereby we are free to use either the semantic constraints or the related \emph{Sahlqvist} axioms. Here we provide
both versions. In what follows we use the semantic constraints for improved performance.}}\<close>
lemma "reflexive R  \<Longrightarrow>  \<lfloor>T\<rfloor>" by blast
lemma "symmetric R \<Longrightarrow> \<lfloor>B\<rfloor>" by blast
lemma "serial R  \<Longrightarrow> \<lfloor>D\<rfloor>" by blast
lemma "transitive R  \<Longrightarrow> \<lfloor>IV\<rfloor>" by blast
lemma "euclidean R \<Longrightarrow> \<lfloor>V\<rfloor>" by blast
lemma "preorder R \<Longrightarrow> \<lfloor>T\<rfloor> \<and> \<lfloor>IV\<rfloor>" by blast \<comment> \<open>S4: reflexive + transitive\<close>
lemma "equivalence R \<Longrightarrow> \<lfloor>T\<rfloor> \<and> \<lfloor>V\<rfloor>" by blast \<comment> \<open>S5: preorder + symmetric\<close>
(*<*)
end
(*>*)


(*
  Author:     Jeremy Dawson and Gerwin Klein, NICTA

  Consequences of type definition theorems, and of extended type definition.
*)

section \<open>Type Definition Theorems\<close>

theory Misc_Typedef
imports Main
begin

section "More lemmas about normal type definitions"

lemma
  tdD1: "type_definition Rep Abs A \<Longrightarrow> \<forall>x. Rep x \<in> A" and
  tdD2: "type_definition Rep Abs A \<Longrightarrow> \<forall>x. Abs (Rep x) = x" and
  tdD3: "type_definition Rep Abs A \<Longrightarrow> \<forall>y. y \<in> A \<longrightarrow> Rep (Abs y) = y"
  by (auto simp: type_definition_def)

lemma td_nat_int:
  "type_definition int nat (Collect (op <= 0))"
  unfolding type_definition_def by auto

context type_definition
begin

declare Rep [iff] Rep_inverse [simp] Rep_inject [simp]

lemma Abs_eqD: "Abs x = Abs y ==> x \<in> A ==> y \<in> A ==> x = y"
  by (simp add: Abs_inject)

lemma Abs_inverse':
  "r : A ==> Abs r = a ==> Rep a = r"
  by (safe elim!: Abs_inverse)

lemma Rep_comp_inverse:
  "Rep o f = g ==> Abs o g = f"
  using Rep_inverse by auto

lemma Rep_eqD [elim!]: "Rep x = Rep y ==> x = y"
  by simp

lemma Rep_inverse': "Rep a = r ==> Abs r = a"
  by (safe intro!: Rep_inverse)

lemma comp_Abs_inverse:
  "f o Abs = g ==> g o Rep = f"
  using Rep_inverse by auto

lemma set_Rep:
  "A = range Rep"
proof (rule set_eqI)
  fix x
  show "(x \<in> A) = (x \<in> range Rep)"
    by (auto dest: Abs_inverse [of x, symmetric])
qed

lemma set_Rep_Abs: "A = range (Rep o Abs)"
proof (rule set_eqI)
  fix x
  show "(x \<in> A) = (x \<in> range (Rep o Abs))"
    by (auto dest: Abs_inverse [of x, symmetric])
qed

lemma Abs_inj_on: "inj_on Abs A"
  unfolding inj_on_def
  by (auto dest: Abs_inject [THEN iffD1])

lemma image: "Abs ` A = UNIV"
  by (auto intro!: image_eqI)

lemmas td_thm = type_definition_axioms

lemma fns1:
  "Rep o fa = fr o Rep | fa o Abs = Abs o fr ==> Abs o fr o Rep = fa"
  by (auto dest: Rep_comp_inverse elim: comp_Abs_inverse simp: o_assoc)

lemmas fns1a = disjI1 [THEN fns1]
lemmas fns1b = disjI2 [THEN fns1]

lemma fns4:
  "Rep o fa o Abs = fr ==>
   Rep o fa = fr o Rep & fa o Abs = Abs o fr"
  by auto

end

interpretation nat_int: type_definition int nat "Collect (op <= 0)"
  by (rule td_nat_int)

declare
  nat_int.Rep_cases [cases del]
  nat_int.Abs_cases [cases del]
  nat_int.Rep_induct [induct del]
  nat_int.Abs_induct [induct del]

subsection "Extended form of type definition predicate"

lemma td_conds:
  "norm o norm = norm ==> (fr o norm = norm o fr) =
    (norm o fr o norm = fr o norm & norm o fr o norm = norm o fr)"
  apply safe
    apply (simp_all add: comp_assoc)
   apply (simp_all add: o_assoc)
  done

lemma fn_comm_power:
  "fa o tr = tr o fr ==> fa ^^ n o tr = tr o fr ^^ n"
  apply (rule ext)
  apply (induct n)
   apply (auto dest: fun_cong)
  done

lemmas fn_comm_power' =
  ext [THEN fn_comm_power, THEN fun_cong, unfolded o_def]

locale td_ext = type_definition +
  fixes norm
  assumes eq_norm: "\<And>x. Rep (Abs x) = norm x"
begin

lemma Abs_norm [simp]:
  "Abs (norm x) = Abs x"
  using eq_norm [of x] by (auto elim: Rep_inverse')

lemma td_th:
  "g o Abs = f ==> f (Rep x) = g x"
  by (drule comp_Abs_inverse [symmetric]) simp

lemma eq_norm': "Rep o Abs = norm"
  by (auto simp: eq_norm)

lemma norm_Rep [simp]: "norm (Rep x) = Rep x"
  by (auto simp: eq_norm' intro: td_th)

lemmas td = td_thm

lemma set_iff_norm: "w : A \<longleftrightarrow> w = norm w"
  by (auto simp: set_Rep_Abs eq_norm' eq_norm [symmetric])

lemma inverse_norm:
  "(Abs n = w) = (Rep w = norm n)"
  apply (rule iffI)
   apply (clarsimp simp add: eq_norm)
  apply (simp add: eq_norm' [symmetric])
  done

lemma norm_eq_iff:
  "(norm x = norm y) = (Abs x = Abs y)"
  by (simp add: eq_norm' [symmetric])

lemma norm_comps:
  "Abs o norm = Abs"
  "norm o Rep = Rep"
  "norm o norm = norm"
  by (auto simp: eq_norm' [symmetric] o_def)

lemmas norm_norm [simp] = norm_comps

lemma fns5:
  "Rep o fa o Abs = fr ==>
  fr o norm = fr & norm o fr = fr"
  by (fold eq_norm') auto

(* following give conditions for converses to td_fns1
  the condition (norm o fr o norm = fr o norm) says that
  fr takes normalised arguments to normalised results,
  (norm o fr o norm = norm o fr) says that fr
  takes norm-equivalent arguments to norm-equivalent results,
  (fr o norm = fr) says that fr
  takes norm-equivalent arguments to the same result, and
  (norm o fr = fr) says that fr takes any argument to a normalised result
  *)
lemma fns2:
  "Abs o fr o Rep = fa ==>
   (norm o fr o norm = fr o norm) = (Rep o fa = fr o Rep)"
  apply (fold eq_norm')
  apply safe
   prefer 2
   apply (simp add: o_assoc)
  apply (rule ext)
  apply (drule_tac x="Rep x" in fun_cong)
  apply auto
  done

lemma fns3:
  "Abs o fr o Rep = fa ==>
   (norm o fr o norm = norm o fr) = (fa o Abs = Abs o fr)"
  apply (fold eq_norm')
  apply safe
   prefer 2
   apply (simp add: comp_assoc)
  apply (rule ext)
  apply (drule_tac f="a o b" for a b in fun_cong)
  apply simp
  done

lemma fns:
  "fr o norm = norm o fr ==>
    (fa o Abs = Abs o fr) = (Rep o fa = fr o Rep)"
  apply safe
   apply (frule fns1b)
   prefer 2
   apply (frule fns1a)
   apply (rule fns3 [THEN iffD1])
     prefer 3
     apply (rule fns2 [THEN iffD1])
       apply (simp_all add: comp_assoc)
   apply (simp_all add: o_assoc)
  done

lemma range_norm:
  "range (Rep o Abs) = A"
  by (simp add: set_Rep_Abs)

end

lemmas td_ext_def' =
  td_ext_def [unfolded type_definition_def td_ext_axioms_def]

end


theory tut05
imports "~~/src/HOL/IMP/Big_Step"
begin

  abbreviation "Or b1 b2 \<equiv> Not (And (Not b1) (Not b2))"

  lemma "IF (And b1 b2) THEN c1 ELSE c2
      \<sim> IF b1 THEN IF b2 THEN c1 ELSE c2 ELSE c2"
    by (fastforce split: split_if_asm intro: IfTrue IfFalse)

  lemma "IF (And b1 b2) THEN c1 ELSE c2
      \<sim> IF b1 THEN IF b2 THEN c1 ELSE c2 ELSE c2"
    apply (auto split: split_if_asm)
    apply (rule IfTrue)
    apply assumption
    apply (rule IfTrue)
    apply assumption
    apply assumption

    apply (rule IfTrue)
    apply assumption
    apply (rule IfFalse)
    apply assumption
    apply assumption

    apply (rule IfFalse)
    apply assumption
    apply assumption
    done

  lemma aux:
    assumes "(WHILE (Bc True) DO c ,s) \<Rightarrow> s'"
    shows False
    using assms
    apply (induction "WHILE (Bc True) DO c" s s' rule: big_step_induct)
    apply auto
    done

  lemma
    defines "b1 \<equiv> Bc True" and "b2 \<equiv> Bc False" and "c\<equiv>SKIP"
    shows "\<not>(WHILE (And b1 b2) DO c \<sim> WHILE b1 DO WHILE b2 DO c)"
    unfolding b1_def b2_def
    apply auto
    apply (rule exI[where x="<>"])
    apply (rule exI[where x="<>"])
    apply (auto dest: aux)
    done

  lemma
    defines "b1 \<equiv> Bc True" and "b2 \<equiv> Bc False" and "c\<equiv>SKIP"
    shows "\<not>(WHILE (And b1 b2) DO c
      \<sim> WHILE b1 DO c;; WHILE (And b1 b2) DO c)"
    unfolding b1_def b2_def
    apply auto
    apply (rule exI[where x="<>"])
    apply (rule exI[where x="<>"])
    apply auto
    apply (auto dest: aux)
    done

  lemma aux2:
    assumes "(WHILE b DO c,s) \<Rightarrow> t"
    shows "\<not>bval b t"
    using assms
    apply (induction "WHILE b DO c" s t rule: big_step_induct)
    apply auto
    done

  lemma
    shows "WHILE (Or b1 b2) DO c
      \<sim> WHILE (Or b1 b2) DO c;; WHILE b1 DO c"
    apply (auto)
    apply (frule aux2) (* drule: delete assumption, frule: Keep assumption *)

    (* This: *)
    apply (rule Seq)
    apply assumption
    apply (rule WhileFalse)
    apply (simp split: split_if_asm)

    (* Or just: *)
    (*apply (auto split: split_if_asm) []*)

    apply (frule aux2)
    (* by auto, or isar-proof:*)
  proof -
    fix s t s\<^sub>2
    assume 1: "(WHILE Or b1 b2 DO c, s) \<Rightarrow> s\<^sub>2"
    assume 2: "(WHILE b1 DO c, s\<^sub>2) \<Rightarrow> t"
    assume 3: "\<not> bval (Or b1 b2) s\<^sub>2"

    from 2 3 have "s\<^sub>2 = t"
      apply cases
      apply auto
      done

    with 1 show "(WHILE Or b1 b2 DO c, s) \<Rightarrow> t" by simp
  qed

  term "op \<sim>"

end


(*
  File:     Real_Asymp_Approx.thy
  Author:   Manuel Eberl, TU München

  Integrates the approximation method into the real_asymp framework as a sign oracle
  to automatically prove positivity/negativity of real constants
*)
theory Real_Asymp_Approx
  imports Real_Asymp "HOL-Decision_Procs.Approximation"
begin

text \<open>
  For large enough constants (such as \<^term>\<open>exp (exp 10000 :: real)\<close>), the
  @{method approximation} method can require a huge amount of time and memory, effectively not
  terminating and causing the entire prover environment to crash.

  To avoid causing such situations, we first check the plausibility of the fact to prove using
  floating-point arithmetic and only run the approximation method if the floating point evaluation
  supports the claim. In particular, exorbitantly large numbers like the one above will lead to
  floating point overflow, which makes the check fail.
\<close>

ML \<open>
signature REAL_ASYMP_APPROX =
sig
  val real_asymp_approx : bool Config.T
  val sign_oracle_tac : Proof.context -> int -> tactic
  val eval : term -> real
end

structure Real_Asymp_Approx : REAL_ASYMP_APPROX =
struct

val real_asymp_approx =
  Attrib.setup_config_bool \<^binding>\<open>real_asymp_approx\<close> (K true)

val nan = Real.fromInt 0 / Real.fromInt 0
fun clamp n = if n < 0 then 0 else n

fun eval_nat (\<^term>\<open>(+) :: nat => _\<close> $ a $ b) = bin (op +) (a, b)
  | eval_nat (\<^term>\<open>(-) :: nat => _\<close> $ a $ b) = bin (clamp o op -) (a, b)
  | eval_nat (\<^term>\<open>(*) :: nat => _\<close> $ a $ b) = bin (op *) (a, b)
  | eval_nat (\<^term>\<open>(div) :: nat => _\<close> $ a $ b) = bin Int.div (a, b)
  | eval_nat (\<^term>\<open>(^) :: nat => _\<close> $ a $ b) = bin (fn (a,b) => Integer.pow a b) (a, b)
  | eval_nat (t as (\<^term>\<open>numeral :: _ => nat\<close> $ _)) = snd (HOLogic.dest_number t)
  | eval_nat (\<^term>\<open>0 :: nat\<close>) = 0
  | eval_nat (\<^term>\<open>1 :: nat\<close>) = 1
  | eval_nat (\<^term>\<open>Nat.Suc\<close> $ a) = un (fn n => n + 1) a
  | eval_nat _ = ~1
and un f a =
      let
        val a = eval_nat a
      in
        if a >= 0 then f a else ~1
      end
and bin f (a, b) =
      let
        val (a, b) = apply2 eval_nat (a, b)
      in
        if a >= 0 andalso b >= 0 then f (a, b) else ~1
      end

fun sgn n =
  if n < Real.fromInt 0 then Real.fromInt (~1) else Real.fromInt 1

fun eval (\<^term>\<open>(+) :: real => _\<close> $ a $ b) = eval a + eval b
  | eval (\<^term>\<open>(-) :: real => _\<close> $ a $ b) = eval a - eval b
  | eval (\<^term>\<open>(*) :: real => _\<close> $ a $ b) = eval a * eval b
  | eval (\<^term>\<open>(/) :: real => _\<close> $ a $ b) =
      let val a = eval a; val b = eval b in
        if Real.==(b, Real.fromInt 0) then nan else a / b
      end
  | eval (\<^term>\<open>inverse :: real => _\<close> $ a) = Real.fromInt 1 / eval a
  | eval (\<^term>\<open>uminus :: real => _\<close> $ a) = Real.~ (eval a)
  | eval (\<^term>\<open>exp :: real => _\<close> $ a) = Math.exp (eval a)
  | eval (\<^term>\<open>ln :: real => _\<close> $ a) =
      let val a = eval a in if a > Real.fromInt 0 then Math.ln a else nan end
  | eval (\<^term>\<open>(powr) :: real => _\<close> $ a $ b) =
      let
        val a = eval a; val b = eval b
      in
        if a < Real.fromInt 0 orelse not (Real.isFinite a) orelse not (Real.isFinite b) then
          nan
        else if Real.==(a, Real.fromInt 0) then
          Real.fromInt 0
        else
          Math.pow (a, b)
      end
  | eval (\<^term>\<open>(^) :: real => _\<close> $ a $ b) =
      let
        fun powr x y =
          if not (Real.isFinite x) orelse y < 0 then
            nan
          else if x < Real.fromInt 0 andalso y mod 2 = 1 then
            Real.~ (Math.pow (Real.~ x, Real.fromInt y))
          else
            Math.pow (Real.abs x, Real.fromInt y)
      in
        powr (eval a) (eval_nat b)
      end
  | eval (\<^term>\<open>root :: nat => real => _\<close> $ n $ a) =
      let val a = eval a; val n = eval_nat n in
        if n = 0 then Real.fromInt 0
          else sgn a * Math.pow (Real.abs a, Real.fromInt 1 / Real.fromInt n) end
  | eval (\<^term>\<open>sqrt :: real => _\<close> $ a) =
      let val a = eval a in sgn a * Math.sqrt (abs a) end
  | eval (\<^term>\<open>log :: real => _\<close> $ a $ b) =
      let
        val (a, b) = apply2 eval (a, b)
      in
        if b > Real.fromInt 0 andalso a > Real.fromInt 0 andalso Real.!= (a, Real.fromInt 1) then
          Math.ln b / Math.ln a
        else
          nan
      end
  | eval (t as (\<^term>\<open>numeral :: _ => real\<close> $ _)) =
      Real.fromInt (snd (HOLogic.dest_number t))
  | eval (\<^term>\<open>0 :: real\<close>) = Real.fromInt 0
  | eval (\<^term>\<open>1 :: real\<close>) = Real.fromInt 1
  | eval _ = nan

fun sign_oracle_tac ctxt i =
  let
    fun tac {context = ctxt, concl, ...} =
      let
        val b =
          case HOLogic.dest_Trueprop (Thm.term_of concl) of
            \<^term>\<open>(<) :: real \<Rightarrow> _\<close> $ lhs $ rhs =>
              let
                val (x, y) = apply2 eval (lhs, rhs)
              in
                Real.isFinite x andalso Real.isFinite y andalso x < y
              end
          | \<^term>\<open>HOL.Not\<close> $ (\<^term>\<open>(=) :: real \<Rightarrow> _\<close> $ lhs $ rhs) =>
              let
                val (x, y) = apply2 eval (lhs, rhs)
              in
                Real.isFinite x andalso Real.isFinite y andalso Real.!= (x, y)
              end
          | _ => false
     in
       if b then HEADGOAL (Approximation.approximation_tac 10 [] NONE ctxt) else no_tac
     end
  in
    if Config.get ctxt real_asymp_approx then
      Subgoal.FOCUS tac ctxt i
    else
      no_tac
  end

end
\<close>

setup \<open>
  Context.theory_map (
    Multiseries_Expansion.register_sign_oracle
      (\<^binding>\<open>approximation_tac\<close>, Real_Asymp_Approx.sign_oracle_tac))
\<close>

lemma "filterlim (\<lambda>n. (1 + (2 / 3 :: real) ^ (n + 1)) ^ 2 ^ n / 2 powr (4 / 3) ^ (n - 1))
         at_top at_top"
proof -
  have [simp]: "ln 4 = 2 * ln (2 :: real)"
    using ln_realpow[of 2 2] by simp
  show ?thesis by (real_asymp simp: field_simps ln_div)
qed

end


chapter \<open>Abstract Formulation of Gödel's Second Incompleteness Theorem\<close>

(*<*)
theory Abstract_Second_Goedel imports Abstract_First_Goedel Derivability_Conditions
begin
(*>*)

text \<open>We assume all three derivability conditions, and assumptions
behind Gödel formulas:\<close>
locale Goedel_Second_Assumptions =
HBL1_2_3
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv bprv
  enc
  P
+
Goedel_Form
  var trm fmla Var num FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  prv bprv
  enc
  S
  P
for
var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
and Var FvarsT substT Fvars subst
and num
and eql cnj imp all exi
and prv bprv
and enc ("\<langle>_\<rangle>")
and S
and P
and fls
begin

lemma P_G:
"bprv (imp (PP \<langle>\<phi>G\<rangle>) (PP \<langle>fls\<rangle>))"
proof-
  have 0: "prv (imp \<phi>G (neg (PP \<langle>\<phi>G\<rangle>)))"
  using prv_\<phi>G_eqv by (intro prv_imp_eqvEL) auto
  have 1: "bprv (PP \<langle>imp \<phi>G (neg (PP \<langle>\<phi>G\<rangle>))\<rangle>)"
  using HBL1_PP[OF _ _ 0] by simp
  have 2: "bprv (imp (PP \<langle>\<phi>G\<rangle>) (PP \<langle>neg (PP \<langle>\<phi>G\<rangle>)\<rangle>))"
  using HBL2_imp2[OF _ _  _ _ 1] by simp
  have 3: "bprv (imp (PP \<langle>\<phi>G\<rangle>) (PP \<langle>PP \<langle>\<phi>G\<rangle>\<rangle>))"
    using HBL3[OF \<phi>G] by simp
  have 23: "bprv (imp (PP \<langle>\<phi>G\<rangle>)
                      (cnj (PP \<langle>PP \<langle>\<phi>G\<rangle>\<rangle>)
                           (PP \<langle>neg (PP \<langle>\<phi>G\<rangle>)\<rangle>)))"
  using B.prv_imp_cnj[OF _ _ _ 3 2] by simp
  have 4: "bprv (imp (cnj (PP \<langle>PP \<langle>\<phi>G\<rangle>\<rangle>)
                          (PP \<langle>neg (PP \<langle>\<phi>G\<rangle>)\<rangle>))
                     (PP \<langle>fls\<rangle>))"
    using HBL2[of "PP \<langle>\<phi>G\<rangle>" fls] unfolding neg_def[symmetric] by simp
  show ?thesis using B.prv_prv_imp_trans[OF _ _ _ 23 4] by simp
qed

text \<open>First the "direct", positive formulation:\<close>
lemma goedel_second_pos:
assumes "prv (neg (PP \<langle>fls\<rangle>))"
shows "prv fls"
proof-
  note PG = bprv_prv[OF _ _ P_G, simplified]
  have "prv (neg (PP \<langle>\<phi>G\<rangle>))"
  using PG assms unfolding neg_def by (rule prv_prv_imp_trans[rotated 3]) auto
  hence "prv \<phi>G" using prv_\<phi>G_eqv by (rule prv_eqv_prv_rev[rotated 2]) auto
  thus ?thesis
  \<comment>\<open>The only part of Goedel's first theorem that is needed:\<close>
  using goedel_first_theEasyHalf_pos by simp
qed

text \<open>Then the more standard, counterpositive formulation:\<close>
theorem goedel_second:
"consistent \<Longrightarrow> \<not> prv (neg (PP \<langle>fls\<rangle>))"
using goedel_second_pos unfolding consistent_def by auto

text \<open>It is an immediate consequence of Gödel's Second HLB1, HLB2 that
(assuming consistency)  @{term "prv (neg (PP \<langle>\<phi>\<rangle>))"} holds for no sentence, be it
provable or not. The theory is omniscient about what it can prove
(thanks to HLB1), but completely ignorant about what it cannot prove.\<close>

corollary not_prv_neg_PP:
assumes c: "consistent" and [simp]: "\<phi> \<in> fmla" "Fvars \<phi> = {}"
shows "\<not> prv (neg (PP \<langle>\<phi>\<rangle>))"
proof
  assume 0: "prv (neg (PP \<langle>\<phi>\<rangle>))"
  have "prv (imp fls \<phi>)" by simp
  hence "bprv (PP \<langle>imp fls \<phi>\<rangle>)" by (intro HBL1_PP) auto
  hence "bprv (imp (PP \<langle>fls\<rangle>) (PP \<langle>\<phi>\<rangle>))" by (intro HBL2_imp2) auto
  hence "bprv (imp (neg (PP \<langle>\<phi>\<rangle>)) (neg (PP \<langle>fls\<rangle>)))" by (intro B.prv_imp_neg_rev) auto
  from prv_imp_mp[OF _ _ bprv_prv[OF _ _ this, simplified] 0, simplified]
  have "prv (neg (PP \<langle>fls\<rangle>))" .
  thus False using goedel_second[OF c] by simp
qed

end \<comment> \<open>context @{locale Goedel_Second_Assumptions}\<close>

(*<*)
end
(*>*)


section \<open>Tools for Implementing Push-Relabel Algorithms\<close>
theory Prpu_Common_Impl
imports
  Prpu_Common_Inst
  Flow_Networks.Network_Impl
  Flow_Networks.NetCheck
begin

subsection \<open>Basic Operations\<close>

type_synonym excess_impl = "node \<Rightarrow> capacity_impl"

context Network_Impl
begin

subsubsection \<open>Excess Map\<close>
text \<open>Obtain an excess map with all nodes mapped to zero.\<close>
definition x_init :: "excess_impl nres" where "x_init \<equiv> return (\<lambda>_. 0)"
text \<open>Get the excess of a node.\<close>
definition x_get :: "excess_impl \<Rightarrow> node \<Rightarrow> capacity_impl nres"
  where "x_get x u \<equiv> do {
    assert (u\<in>V);
    return (x u)
  }"
text \<open>Add a capacity to the excess of a node.\<close>
definition x_add :: "excess_impl \<Rightarrow> node \<Rightarrow> capacity_impl \<Rightarrow> excess_impl nres"
  where "x_add x u \<Delta> \<equiv> do {
    assert (u\<in>V);
    return (x(u := x u + \<Delta>))
  }"

subsubsection \<open>Labeling\<close>
text \<open>Obtain the initial labeling: All nodes are zero, except the
  source which is labeled by \<open>|V|\<close>. The exact cardinality of \<open>V\<close> is passed
  as a parameter.
\<close>
definition l_init :: "nat \<Rightarrow> (node \<Rightarrow> nat) nres"
  where "l_init C \<equiv> return ((\<lambda>_. 0)(s := C))"

text \<open>Get the label of a node.\<close>
definition l_get :: "(node \<Rightarrow> nat) \<Rightarrow> node \<Rightarrow> nat nres"
  where "l_get l u \<equiv> do {
    assert (u \<in> V);
    return (l u)
  }"

text \<open>Set the label of a node.\<close>
definition l_set :: "(node \<Rightarrow> nat) \<Rightarrow> node \<Rightarrow> nat \<Rightarrow> (node \<Rightarrow> nat) nres"
  where "l_set l u a \<equiv> do {
    assert (u\<in>V);
    assert (a < 2*card V);
    return (l(u := a))
  }"

subsubsection \<open>Label Frequency Counts for Gap Heuristics\<close>
text \<open>Obtain the frequency counts for the initial labeling.
  Again, the cardinality of \<open>|V|\<close>, which is required to determine the label
  of the source node, is passed as an explicit parameter.
\<close>
definition cnt_init :: "nat \<Rightarrow> (nat \<Rightarrow> nat) nres"
  where "cnt_init C \<equiv> do {
    assert (C<2*N);
    return ((\<lambda>_. 0)(0 := C - 1, C := 1))
  }"

text \<open>Get the count for a label value.\<close>
definition cnt_get :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat nres"
  where "cnt_get cnt lv \<equiv> do {
    assert (lv < 2*N);
    return (cnt lv)
  }"

text \<open>Increment the count for a label value by one.\<close>
definition cnt_incr :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> nat) nres"
  where "cnt_incr cnt lv \<equiv> do {
    assert (lv < 2*N);
    return (cnt ( lv := cnt lv + 1 ))
  }"

text \<open>Decrement the count for a label value by one.\<close>
definition cnt_decr :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> nat) nres"
  where "cnt_decr cnt lv \<equiv> do {
    assert (lv < 2*N \<and> cnt lv > 0);
    return (cnt ( lv := cnt lv - 1 ))
  }"

end \<comment> \<open>Network Implementation Locale\<close>

subsection \<open>Refinements to Basic Operations\<close>

context Network_Impl
begin
text \<open>In this section, we refine the algorithm to actually use the
 basic operations.
\<close>

subsubsection \<open>Explicit Computation of the Excess\<close>
definition "xf_rel \<equiv> { ((excess f,cf_of f),f) | f. True }"
lemma xf_rel_RELATES[refine_dref_RELATES]: "RELATES xf_rel"
  by (auto simp: RELATES_def)

definition "pp_init_x
  \<equiv> \<lambda>u. (if u=s then (\<Sum>(u,v)\<in>outgoing s. - c(u,v)) else c (s,u))"

lemma excess_pp_init_f[simp]: "excess pp_init_f = pp_init_x"
  apply (intro ext)
  subgoal for u
    unfolding excess_def pp_init_f_def pp_init_x_def
    apply (cases "u=s")
    subgoal
      unfolding outgoing_def incoming_def
      by (auto intro: sum.cong simp: sum_negf)
    subgoal proof -
      assume [simp]: "u\<noteq>s"
      have [simp]:
        "(case e of (u, v) \<Rightarrow> if u = s then c (u, v) else 0) = 0"
        if "e\<in>outgoing u" for e
        using that by (auto simp: outgoing_def)
      have [simp]: "(case e of (u, v) \<Rightarrow> if u = s then c (u, v) else 0)
        = (if e = (s,u) then c (s,u) else 0)"
        if "e\<in>incoming u" for e
        using that by (auto simp: incoming_def split: if_splits)
      show ?thesis by (simp add: sum.delta) (simp add: incoming_def)
    qed
    done
  done

definition "pp_init_cf
  \<equiv> \<lambda>(u,v). if (v=s) then c (v,u) else if u=s then 0 else c (u,v)"
lemma cf_of_pp_init_f[simp]: "cf_of pp_init_f = pp_init_cf"
  apply (intro ext)
  unfolding pp_init_cf_def pp_init_f_def residualGraph_def
  using no_parallel_edge
  by auto

lemma pp_init_x_rel: "((pp_init_x, pp_init_cf), pp_init_f) \<in> xf_rel"
  unfolding xf_rel_def by auto

subsubsection \<open>Algorithm to Compute Initial Excess and Flow\<close>
definition "pp_init_xcf2_aux \<equiv> do {
  let x=(\<lambda>_. 0);
  let cf=c;

  foreach (adjacent_nodes s) (\<lambda>v (x,cf). do {
    assert ((s,v)\<in>E);
    assert (s \<noteq> v);
    let a = cf (s,v);
    assert (x v = 0);
    let x = x( s := x s - a, v := a );
    let cf = cf( (s,v) := 0, (v,s) := a);
    return (x,cf)
  }) (x,cf)
}"

lemma pp_init_xcf2_aux_spec:
  shows "pp_init_xcf2_aux \<le> SPEC (\<lambda>(x,cf). x=pp_init_x \<and> cf = pp_init_cf)"
proof -
  have ADJ_S_AUX: "adjacent_nodes s = {v . (s,v)\<in>E}"
    unfolding adjacent_nodes_def using no_incoming_s by auto

  have CSU_AUX: "c (s,u) = 0" if "u\<notin>adjacent_nodes s" for u
    using that unfolding adjacent_nodes_def by auto

  show ?thesis
    unfolding pp_init_xcf2_aux_def
    apply (refine_vcg FOREACH_rule[where I="\<lambda>it (x,cf).
        x s = (\<Sum>v\<in>adjacent_nodes s - it. - c(s,v))
      \<and> (\<forall>v\<in>adjacent_nodes s. x v = (if v\<in>it then 0 else c (s,v)))
      \<and> (\<forall>v\<in>-insert s (adjacent_nodes s). x v = 0)
      \<and> (\<forall>v\<in>adjacent_nodes s.
            if v\<notin>it then cf (s,v) = 0 \<and> cf (v,s) = c (s,v)
            else cf (s,v) = c (s,v) \<and> cf (v,s) = c (v,s))
      \<and> (\<forall>u v. u\<noteq>s \<and> v\<noteq>s \<longrightarrow> cf (u,v) = c (u,v) )
      \<and> (\<forall>u. u\<notin>adjacent_nodes s \<longrightarrow> cf (u,s) = 0 \<and> cf (s,u) = 0)
    "])
    apply (vc_solve simp: it_step_insert_iff simp: CSU_AUX)
    subgoal for v it by (auto simp: ADJ_S_AUX)
    subgoal for u it _ v by (auto split: if_splits)
    subgoal by (auto simp: ADJ_S_AUX)
    subgoal by (auto simp: ADJ_S_AUX)
    subgoal by (auto split: if_splits)
    (* TODO: This proof is still a bit fragile *)
    subgoal for x
      unfolding pp_init_x_def
      apply (intro ext)
      subgoal for u
        apply (clarsimp simp: ADJ_S_AUX outgoing_def; intro conjI)
        applyS (auto intro!: sum.reindex_cong[where l=snd] intro: inj_onI)
        applyS (metis (mono_tags, lifting) Compl_iff Graph.zero_cap_simp insertE mem_Collect_eq)
        done
      done
    subgoal for x cf
      unfolding pp_init_cf_def
      apply (intro ext)
      apply (clarsimp; auto simp: CSU_AUX)
      done
    done
qed

definition "pp_init_xcf2 am \<equiv> do {
  x \<leftarrow> x_init;
  cf \<leftarrow> cf_init;

  assert (s\<in>V);
  adj \<leftarrow> am_get am s;
  nfoldli adj (\<lambda>_. True) (\<lambda>v (x,cf). do {
    assert ((s,v)\<in>E);
    assert (s \<noteq> v);
    a \<leftarrow> cf_get cf (s,v);
    x \<leftarrow> x_add x s (-a);
    x \<leftarrow> x_add x v a;
    cf \<leftarrow> cf_set cf (s,v) 0;
    cf \<leftarrow> cf_set cf (v,s) a;
    return (x,cf)
  }) (x,cf)
}"

lemma pp_init_xcf2_refine_aux:
  assumes AM: "is_adj_map am"
  shows "pp_init_xcf2 am \<le> \<Down>Id (pp_init_xcf2_aux)"
  unfolding pp_init_xcf2_def pp_init_xcf2_aux_def
  unfolding x_init_def cf_init_def am_get_def cf_get_def cf_set_def x_add_def
  apply (simp only: nres_monad_laws)
  supply LFO_refine[OF am_to_adj_nodes_refine[OF AM], refine]
  apply refine_rcg
  using E_ss_VxV
  by auto

lemma pp_init_xcf2_refine[refine2]:
  assumes AM: "is_adj_map am"
  shows "pp_init_xcf2 am \<le>\<Down>xf_rel (RETURN pp_init_f)"
  using pp_init_xcf2_refine_aux[OF AM] pp_init_xcf2_aux_spec pp_init_x_rel
  by (auto simp: pw_le_iff refine_pw_simps)

subsubsection \<open>Computing the Minimal Adjacent Label\<close>
definition (in Network) "min_adj_label_aux cf l u \<equiv> do {
  assert (u\<in>V);
  x \<leftarrow> foreach (adjacent_nodes u) (\<lambda>v x. do {
    assert ((u,v)\<in>E\<union>E\<inverse>);
    assert (v\<in>V);
    if (cf (u,v) \<noteq> 0) then
      case x of
        None \<Rightarrow> return (Some (l v))
      | Some xx \<Rightarrow> return (Some (min (l v) (xx)))
    else
      return x
  }) None;

  assert (x\<noteq>None);
  return (the x)
}"

lemma (in -) set_filter_xform_aux:
  "{ f x | x. ( x = a \<or> x\<in>S \<and> x\<notin>it ) \<and> P x }
  = (if P a then {f a} else {}) \<union> {f x | x. x\<in>S-it \<and> P x}"
  by auto

lemma (in Labeling) min_adj_label_aux_spec:
  assumes PRE: "relabel_precond f l u"
  shows "min_adj_label_aux cf l u \<le> SPEC (\<lambda>x. x = Min { l v | v. (u,v)\<in>cf.E })"
proof -
  have AUX: "cf (u,v) \<noteq> 0 \<longleftrightarrow> (u,v)\<in>cf.E" for v unfolding cf.E_def by auto

  have EQ: "{ l v | v. (u,v)\<in>cf.E }
    = { l v | v. v\<in>adjacent_nodes u \<and> cf (u,v)\<noteq>0 }"
    unfolding AUX
    using cfE_ss_invE
    by (auto simp: adjacent_nodes_def)

  define Min_option :: "nat set \<rightharpoonup> nat"
    where "Min_option X \<equiv> if X={} then None else Some (Min X)" for X

  from PRE active_has_cf_outgoing have "cf.outgoing u \<noteq> {}"
    unfolding relabel_precond_def by auto
  hence [simp]: "u\<in>V" unfolding cf.outgoing_def using cfE_of_ss_VxV by auto
  from \<open>cf.outgoing u \<noteq> {}\<close>
  have AUX2: "\<exists>v. v \<in> adjacent_nodes u \<and> cf (u, v) \<noteq> 0"
    by (smt AUX Collect_empty_eq Image_singleton_iff UnCI adjacent_nodes_def
            cf.outgoing_def cf_def converse_iff prod.simps(2))

  show ?thesis unfolding min_adj_label_aux_def EQ
    apply (refine_vcg
        FOREACH_rule[where
          I="\<lambda>it x. x = Min_option
                          { l v | v. v\<in>adjacent_nodes u - it \<and> cf (u,v)\<noteq>0 }"]
        )
    apply (vc_solve
        simp: Min_option_def it_step_insert_iff set_filter_xform_aux
        split: if_splits)
    subgoal unfolding adjacent_nodes_def by auto
    subgoal unfolding adjacent_nodes_def by auto
    subgoal using adjacent_nodes_ss_V by auto
    subgoal using adjacent_nodes_ss_V by auto
    subgoal by (auto simp: Min.insert_remove)
    subgoal using AUX2 by auto
    done
qed

definition "min_adj_label am cf l u \<equiv> do {
  assert (u\<in>V);
  adj \<leftarrow> am_get am u;
  x \<leftarrow> nfoldli adj (\<lambda>_. True) (\<lambda>v x. do {
    assert ((u,v)\<in> E \<union> E\<inverse>);
    assert (v\<in>V);
    cfuv \<leftarrow> cf_get cf (u,v);
    if (cfuv \<noteq> 0) then do {
      lv \<leftarrow> l_get l v;
      case x of
        None \<Rightarrow> return (Some lv)
      | Some xx \<Rightarrow> return (Some (min lv xx))
    } else
      return x
  }) None;

  assert (x\<noteq>None);
  return (the x)
}"

lemma min_adj_label_refine[THEN order_trans, refine_vcg]:
  assumes "Height_Bounded_Labeling c s t f l"
  assumes AM: "(am,adjacent_nodes)\<in>nat_rel\<rightarrow>\<langle>nat_rel\<rangle>list_set_rel"
  assumes PRE: "relabel_precond f l u"
  assumes [simp]: "cf = cf_of f"
  shows "min_adj_label am cf l u \<le> SPEC (\<lambda>x. x
        = Min { l v | v. (u,v)\<in>cfE_of f })"
proof -
  interpret Height_Bounded_Labeling c s t f l by fact

  have "min_adj_label am (cf_of f) l u \<le> \<Down>Id (min_adj_label_aux (cf_of f) l u)"
    unfolding min_adj_label_def min_adj_label_aux_def Let_def
    unfolding am_get_def cf_get_def l_get_def
    apply (simp only: nres_monad_laws)
    supply LFO_refine[OF fun_relD[OF AM IdI] _ IdI, refine]
    apply (refine_rcg)
    apply refine_dref_type
    by auto
  also note min_adj_label_aux_spec[OF PRE]
  finally show ?thesis by simp
qed

subsubsection \<open>Refinement of Relabel\<close>
text \<open>Utilities to Implement Relabel Operations\<close>

definition "relabel2 am cf l u \<equiv> do {
  assert (u\<in>V - {s,t});
  nl \<leftarrow> min_adj_label am cf l u;
  l \<leftarrow> l_set l u (nl+1);
  return l
}"

lemma relabel2_refine[refine]:
  assumes "((x,cf),f)\<in>xf_rel"
  assumes AM: "(am,adjacent_nodes)\<in>nat_rel\<rightarrow>\<langle>nat_rel\<rangle>list_set_rel"
  assumes [simplified,simp]: "(li,l)\<in>Id" "(ui,u)\<in>Id"
  shows "relabel2 am cf li ui \<le> \<Down>Id (relabel f l u)"
proof -
  have [simp]: "{l v |v. v \<in> V \<and> cf_of f (u, v) \<noteq> 0} = {l v |v. cf_of f (u, v) \<noteq> 0}"
    using cfE_of_ss_VxV[of f]
    by (auto simp: Graph.E_def)

  show ?thesis
    using assms
    unfolding relabel2_def relabel_def
    unfolding l_set_def
    apply (refine_vcg AM)
    apply (vc_solve (nopre) simp: xf_rel_def relabel_effect_def solve: asm_rl)
    subgoal premises prems for a proof -
      from prems interpret Height_Bounded_Labeling c s t f l by simp
      interpret l': Height_Bounded_Labeling c s t f "relabel_effect f l u"
        by (rule relabel_pres_height_bound) (rule prems)
      from prems have "u\<in>V" by simp
      from prems have "a + 1 = relabel_effect f l u u"
        by (auto simp: relabel_effect_def)
      also note l'.height_bound[THEN bspec, OF \<open>u\<in>V\<close>]
      finally show "a + 1 < 2 * card V" using card_V_ge2 by auto
    qed
    done
qed

subsubsection \<open>Refinement of Push\<close>
definition "push2_aux x cf \<equiv> \<lambda>(u,v). do {
  assert ( (u,v) \<in> E \<union> E\<inverse> );
  assert ( u \<noteq> v );
  let \<Delta> = min (x u) (cf (u,v));
  return ((x( u := x u - \<Delta>, v := x v + \<Delta> ),augment_edge_cf cf (u,v) \<Delta>))
}"

definition "push2 x cf \<equiv> \<lambda>(u,v). do {
  assert ( (u,v) \<in> E \<union> E\<inverse> );
  xu \<leftarrow> x_get x u;
  cfuv \<leftarrow> cf_get cf (u,v);
  cfvu \<leftarrow> cf_get cf (v,u);
  let \<Delta> = min xu cfuv;
  x \<leftarrow> x_add x u (-\<Delta>);
  x \<leftarrow> x_add x v \<Delta>;

  cf \<leftarrow> cf_set cf (u,v) (cfuv - \<Delta>);
  cf \<leftarrow> cf_set cf (v,u) (cfvu + \<Delta>);

  return (x,cf)
}"

lemma push2_refine[refine]:
  assumes "((x,cf),f)\<in>xf_rel" "(ei,e)\<in>Id\<times>\<^sub>rId"
  shows "push2 x cf ei \<le> \<Down>xf_rel (push f l e)"
proof -
  have "push2 x cf ei \<le> (push2_aux x cf ei)"
    unfolding push2_def push2_aux_def
    unfolding x_get_def x_add_def cf_get_def cf_set_def
    unfolding augment_edge_cf_def
    apply (simp only: nres_monad_laws)
    apply refine_vcg
    using E_ss_VxV
    by auto
  also note push2_aux_refine[OF assms]
  finally show ?thesis .
qed

subsubsection \<open>Adding frequency counters to labeling\<close>

definition "l_invar l \<equiv> \<forall>v. l v \<noteq> 0 \<longrightarrow> v\<in>V"

definition "clc_invar \<equiv> \<lambda>(cnt,l).
  (\<forall>lv. cnt lv = card { u\<in>V . l u = lv })
\<and> (\<forall>u. l u < 2*N) \<and> l_invar l"
definition "clc_rel \<equiv> br snd clc_invar"

definition "clc_init C \<equiv> do {
  l \<leftarrow> l_init C;
  cnt \<leftarrow> cnt_init C;
  return (cnt,l)
}"

definition "clc_get \<equiv> \<lambda>(cnt,l) u. l_get l u"
definition "clc_set \<equiv> \<lambda>(cnt,l) u a. do {
  assert (a<2*N);
  lu \<leftarrow> l_get l u;
  cnt \<leftarrow> cnt_decr cnt lu;
  l \<leftarrow> l_set l u a;
  lu \<leftarrow> l_get l u;
  cnt \<leftarrow> cnt_incr cnt lu;
  return (cnt,l)
}"

definition "clc_has_gap \<equiv> \<lambda>(cnt,l) lu. do {
  nlu \<leftarrow> cnt_get cnt lu;
  return (nlu = 0)
}"

lemma cardV_le_N: "card V \<le> N" using card_mono[OF _ V_ss] by auto
lemma N_not_Z: "N \<noteq> 0" using card_V_ge2 cardV_le_N by auto
lemma N_ge_2: "2\<le>N" using card_V_ge2 cardV_le_N by auto

lemma clc_init_refine[refine]:
  assumes [simplified,simp]: "(Ci,C)\<in>nat_rel"
  assumes [simp]: "C = card V"
  shows "clc_init Ci \<le>\<Down>clc_rel (l_init C)"
proof -
  have AUX: "{u. u \<noteq> s \<and> u \<in> V} = V-{s}" by auto

  show ?thesis
    unfolding clc_init_def l_init_def cnt_init_def
    apply refine_vcg
    unfolding clc_rel_def clc_invar_def
    using cardV_le_N N_not_Z
    by (auto simp: in_br_conv V_not_empty AUX l_invar_def)
qed

lemma clc_get_refine[refine]:
  "\<lbrakk> (clc,l)\<in>clc_rel; (ui,u)\<in>nat_rel \<rbrakk> \<Longrightarrow> clc_get clc ui \<le>\<Down>Id (l_get l u)"
  unfolding clc_get_def clc_rel_def
  by (auto simp: in_br_conv split: prod.split)

definition l_get_rlx :: "(node \<Rightarrow> nat) \<Rightarrow> node \<Rightarrow> nat nres"
  where "l_get_rlx l u \<equiv> do {
    assert (u < N);
    return (l u)
  }"
definition "clc_get_rlx \<equiv> \<lambda>(cnt,l) u. l_get_rlx l u"

lemma clc_get_rlx_refine[refine]:
  "\<lbrakk> (clc,l)\<in>clc_rel; (ui,u)\<in>nat_rel \<rbrakk>
  \<Longrightarrow> clc_get_rlx clc ui \<le>\<Down>Id (l_get_rlx l u)"
  unfolding clc_get_rlx_def clc_rel_def
  by (auto simp: in_br_conv split: prod.split)

lemma card_insert_disjointI:
  "\<lbrakk> finite Y; X = insert x Y; x\<notin>Y \<rbrakk> \<Longrightarrow> card X = Suc (card Y)"
  by auto

lemma clc_set_refine[refine]:
  "\<lbrakk> (clc,l) \<in> clc_rel; (ui,u)\<in>nat_rel; (ai,a)\<in>nat_rel \<rbrakk> \<Longrightarrow>
    clc_set clc ui ai \<le>\<Down>clc_rel (l_set l u a)"
  unfolding clc_set_def l_set_def l_get_def cnt_decr_def cnt_incr_def
  apply refine_vcg
  apply vc_solve
  unfolding clc_rel_def in_br_conv clc_invar_def l_invar_def
  subgoal using cardV_le_N by auto
  applyS auto
  applyS (auto simp: simp: card_gt_0_iff)

  subgoal for cnt ll
    apply clarsimp
    apply (intro impI conjI; clarsimp?)
    subgoal
      apply (subst le_imp_diff_is_add; simp)
      apply (rule card_insert_disjointI[where x=u])
      by auto
    subgoal
      apply (rule card_insert_disjointI[where x=u, symmetric])
      by auto
    subgoal
      by (auto intro!: arg_cong[where f=card])
    done
  done

lemma clc_has_gap_correct[THEN order_trans, refine_vcg]:
  "\<lbrakk>(clc,l)\<in>clc_rel; k<2*N\<rbrakk>
  \<Longrightarrow> clc_has_gap clc k \<le> (spec r. r \<longleftrightarrow> gap_precond l k)"
  unfolding clc_has_gap_def cnt_get_def gap_precond_def
  apply refine_vcg
  unfolding clc_rel_def clc_invar_def in_br_conv
  by auto

subsubsection \<open>Refinement of Gap-Heuristics\<close>
text \<open>Utilities to Implement Gap-Heuristics\<close>

definition "gap_aux C l k \<equiv> do {
  nfoldli [0..<N] (\<lambda>_. True) (\<lambda>v l. do {
    lv \<leftarrow> l_get_rlx l v;
    if (k < lv \<and> lv < C) then do {
      assert (C+1 < 2*N);
      l \<leftarrow> l_set l v (C+1);
      return l
    } else return l
  }) l
}"

lemma gap_effect_invar[simp]: "l_invar l \<Longrightarrow> l_invar (gap_effect l k)"
  unfolding gap_effect_def l_invar_def
  by auto

lemma relabel_effect_invar[simp]: "\<lbrakk>l_invar l; u\<in>V\<rbrakk> \<Longrightarrow> l_invar (relabel_effect f l u)"
  unfolding relabel_effect_def l_invar_def by auto

lemma gap_aux_correct[THEN order_trans, refine_vcg]:
  "\<lbrakk>l_invar l; C=card V\<rbrakk> \<Longrightarrow> gap_aux C l k \<le> SPEC (\<lambda>r. r=gap_effect l k)"
  unfolding gap_aux_def l_get_rlx_def l_set_def
  apply (simp only: nres_monad_laws)
  apply (refine_vcg nfoldli_rule[where I = "\<lambda>it1 it2 l'. \<forall>u. if u\<in>set it2 then l' u = l u else l' u = gap_effect l k u"])
  apply (vc_solve simp: upt_eq_lel_conv)
  subgoal
    apply (frule gap_effect_invar[where k=k])
    unfolding l_invar_def using V_ss by force
  subgoal using N_not_Z cardV_le_N by auto
  subgoal unfolding l_invar_def by auto
  subgoal unfolding gap_effect_def by auto
  subgoal for v l' u
    apply (drule spec[where x=u])
    by (auto split: if_splits simp: gap_effect_def)
  subgoal by auto
  done

definition "gap2 C clc k \<equiv> do {
  nfoldli [0..<N] (\<lambda>_. True) (\<lambda>v clc. do {
    lv \<leftarrow> clc_get_rlx clc v;
    if (k < lv \<and> lv < C) then do {
      clc \<leftarrow> clc_set clc v (C+1);
      return clc
    } else return clc
  }) clc
}"

lemma gap2_refine[refine]:
  assumes [simplified,simp]: "(Ci,C)\<in>nat_rel" "(ki,k)\<in>nat_rel"
  assumes CLC: "(clc,l)\<in>clc_rel"
  shows "gap2 Ci clc ki \<le>\<Down>clc_rel (gap_aux C l k)"
  unfolding gap2_def gap_aux_def
  apply (refine_rcg CLC)
  apply refine_dref_type
  by auto

definition "gap_relabel_aux C f l u \<equiv> do {
  lu \<leftarrow> l_get l u;
  l \<leftarrow> relabel f l u;
  if gap_precond l lu then
    gap_aux C l lu
  else return l
}"

lemma gap_relabel_aux_refine:
  assumes [simp]: "C = card V" "l_invar l"
  shows "gap_relabel_aux C f l u \<le> gap_relabel f l u"
  unfolding gap_relabel_aux_def gap_relabel_def relabel_def
    gap_relabel_effect_def l_get_def
  apply (simp only: Let_def nres_monad_laws)
  apply refine_vcg
  by auto

definition "min_adj_label_clc am cf clc u \<equiv> case clc of (_,l) \<Rightarrow> min_adj_label am cf l u"

definition "clc_relabel2 am cf clc u \<equiv> do {
  assert (u\<in>V - {s,t});
  nl \<leftarrow> min_adj_label_clc am cf clc u;
  clc \<leftarrow> clc_set clc u (nl+1);
  return clc
}"

lemma clc_relabel2_refine[refine]:
  assumes XF: "((x,cf),f)\<in>xf_rel"
  assumes CLC: "(clc,l)\<in>clc_rel"
  assumes AM: "(am,adjacent_nodes)\<in>nat_rel\<rightarrow>\<langle>nat_rel\<rangle>list_set_rel"
  assumes [simplified,simp]: "(ui,u)\<in>Id"
  shows "clc_relabel2 am cf clc ui \<le> \<Down>clc_rel (relabel f l u)"
proof -
  have "clc_relabel2 am cf clc ui \<le>\<Down>clc_rel (relabel2 am cf l ui)"
    unfolding clc_relabel2_def relabel2_def
    apply (refine_rcg)
    apply (refine_dref_type)
    apply (vc_solve simp: CLC)
    subgoal
      using CLC
      unfolding clc_rel_def in_br_conv min_adj_label_clc_def
      by (auto split: prod.split)
    done
  also note relabel2_refine[OF XF AM, of l l ui u]
  finally show ?thesis by simp
qed

definition "gap_relabel2 C am cf clc u \<equiv> do {
  lu \<leftarrow> clc_get clc u;
  clc \<leftarrow> clc_relabel2 am cf clc u;
  has_gap \<leftarrow> clc_has_gap clc lu;
  if has_gap then gap2 C clc lu
  else
    RETURN clc
}"

lemma gap_relabel2_refine_aux:
  assumes XCF: "((x, cf), f) \<in> xf_rel"
  assumes CLC: "(clc,l)\<in>clc_rel"
  assumes AM: "(am,adjacent_nodes)\<in>nat_rel\<rightarrow>\<langle>nat_rel\<rangle>list_set_rel"
  assumes [simplified,simp]: "(Ci,C)\<in>Id" "(ui,u)\<in>Id"
  shows "gap_relabel2 Ci am cf clc ui \<le> \<Down>clc_rel (gap_relabel_aux C f l u)"
  unfolding gap_relabel2_def gap_relabel_aux_def
  apply (refine_vcg XCF AM CLC if_bind_cond_refine bind_refine')
  apply (vc_solve solve: refl )
  subgoal for _ lu
    using CLC
    unfolding clc_get_def l_get_def clc_rel_def in_br_conv clc_invar_def
    by (auto simp: refine_pw_simps split: prod.splits)
  done

lemma gap_relabel2_refine[refine]:
  assumes XCF: "((x, cf), f) \<in> xf_rel"
  assumes CLC: "(clc,l)\<in>clc_rel"
  assumes AM: "(am,adjacent_nodes)\<in>nat_rel\<rightarrow>\<langle>nat_rel\<rangle>list_set_rel"
  assumes [simplified,simp]: "(ui,u)\<in>Id"
  assumes CC: "C = card V"
  shows "gap_relabel2 C am cf clc ui \<le>\<Down>clc_rel (gap_relabel f l u)"
proof -
  from CLC have LINV: "l_invar l" unfolding clc_rel_def in_br_conv clc_invar_def by auto

  note gap_relabel2_refine_aux[OF XCF CLC AM IdI IdI]
  also note gap_relabel_aux_refine[OF CC LINV]
  finally show ?thesis by simp
qed

subsection \<open>Refinement to Efficient Data Structures\<close>

subsubsection \<open>Registration of Abstract Operations\<close>
text \<open>We register all abstract operations at once,
  auto-rewriting the capacity matrix type\<close>

context includes Network_Impl_Sepref_Register
begin
sepref_register x_get x_add

sepref_register l_init l_get l_get_rlx l_set

sepref_register clc_init clc_get clc_set clc_has_gap clc_get_rlx

sepref_register cnt_init cnt_get cnt_incr cnt_decr
sepref_register gap2 min_adj_label min_adj_label_clc

sepref_register push2 relabel2 clc_relabel2 gap_relabel2

sepref_register pp_init_xcf2

end \<comment> \<open>Anonymous Context\<close>

subsubsection \<open>Excess by Array\<close>
definition "x_assn \<equiv> is_nf N (0::capacity_impl)"

lemma x_init_hnr[sepref_fr_rules]:
  "(uncurry0 (Array.new N 0), uncurry0 x_init) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a x_assn"
  apply sepref_to_hoare unfolding x_assn_def x_init_def
  by (sep_auto heap: nf_init_rule)

lemma x_get_hnr[sepref_fr_rules]:
  "(uncurry Array.nth, uncurry (PR_CONST x_get))
  \<in> x_assn\<^sup>k *\<^sub>a node_assn\<^sup>k \<rightarrow>\<^sub>a cap_assn"
  apply sepref_to_hoare
  unfolding x_assn_def x_get_def by (sep_auto simp: refine_pw_simps)

definition (in -) "x_add_impl x u \<Delta> \<equiv> do {
  xu \<leftarrow> Array.nth x u;
  x \<leftarrow> Array.upd u (xu+\<Delta>) x;
  return x
}"
lemma x_add_hnr[sepref_fr_rules]:
  "(uncurry2 x_add_impl, uncurry2 (PR_CONST x_add))
  \<in> x_assn\<^sup>d *\<^sub>a node_assn\<^sup>k *\<^sub>a cap_assn\<^sup>k \<rightarrow>\<^sub>a x_assn"
  apply sepref_to_hoare
  unfolding x_assn_def x_add_impl_def x_add_def
  by (sep_auto simp: refine_pw_simps)

subsubsection \<open>Labeling by Array\<close>
definition "l_assn \<equiv> is_nf N (0::nat)"
definition (in -) "l_init_impl N s cardV \<equiv> do {
  l \<leftarrow> Array.new N (0::nat);
  l \<leftarrow> Array.upd s cardV l;
  return l
}"
lemma l_init_hnr[sepref_fr_rules]:
  "(l_init_impl N s, (PR_CONST l_init)) \<in> nat_assn\<^sup>k \<rightarrow>\<^sub>a l_assn"
  apply sepref_to_hoare
  unfolding l_assn_def l_init_def l_init_impl_def
  by (sep_auto heap: nf_init_rule)

lemma l_get_hnr[sepref_fr_rules]:
  "(uncurry Array.nth, uncurry (PR_CONST l_get))
  \<in> l_assn\<^sup>k *\<^sub>a node_assn\<^sup>k \<rightarrow>\<^sub>a nat_assn"
  apply sepref_to_hoare
  unfolding l_assn_def l_get_def by (sep_auto simp: refine_pw_simps)

lemma l_get_rlx_hnr[sepref_fr_rules]:
  "(uncurry Array.nth, uncurry (PR_CONST l_get_rlx))
  \<in> l_assn\<^sup>k *\<^sub>a node_assn\<^sup>k \<rightarrow>\<^sub>a nat_assn"
  apply sepref_to_hoare
  unfolding l_assn_def l_get_rlx_def by (sep_auto simp: refine_pw_simps)

lemma l_set_hnr[sepref_fr_rules]:
  "(uncurry2 (\<lambda>a i x. Array.upd i x a), uncurry2 (PR_CONST l_set))
  \<in> l_assn\<^sup>d *\<^sub>a node_assn\<^sup>k *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a l_assn"
  apply sepref_to_hoare
  unfolding l_assn_def l_set_def
  by (sep_auto simp: refine_pw_simps split: prod.split)

subsubsection \<open>Label Frequency by Array\<close>

definition "cnt_assn (f::node\<Rightarrow>nat) a
  \<equiv> \<exists>\<^sub>Al. a\<mapsto>\<^sub>al * \<up>(length l = 2*N \<and> (\<forall>i<2*N. l!i = f i) \<and> (\<forall>i\<ge>2*N. f i = 0))"

definition (in -) "cnt_init_impl N C \<equiv> do {
  a \<leftarrow> Array.new (2*N) (0::nat);
  a \<leftarrow> Array.upd 0 (C-1) a;
  a \<leftarrow> Array.upd C 1 a;
  return a
}"

definition (in -) "cnt_incr_impl a k \<equiv> do {
  freq \<leftarrow> Array.nth a k;
  a \<leftarrow> Array.upd k (freq+1) a;
  return a
}"

definition (in -) "cnt_decr_impl a k \<equiv> do {
  freq \<leftarrow> Array.nth a k;
  a \<leftarrow> Array.upd k (freq-1) a;
  return a
}"

lemma cnt_init_hnr[sepref_fr_rules]: "(cnt_init_impl N, PR_CONST cnt_init) \<in> nat_assn\<^sup>k \<rightarrow>\<^sub>a cnt_assn"
  apply sepref_to_hoare
  unfolding cnt_init_def cnt_init_impl_def cnt_assn_def
  by (sep_auto simp: refine_pw_simps)

lemma cnt_get_hnr[sepref_fr_rules]: "(uncurry Array.nth, uncurry (PR_CONST cnt_get)) \<in> cnt_assn\<^sup>k *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a nat_assn"
  apply sepref_to_hoare
  unfolding cnt_get_def cnt_assn_def
  by (sep_auto simp: refine_pw_simps)

lemma cnt_incr_hnr[sepref_fr_rules]: "(uncurry cnt_incr_impl, uncurry (PR_CONST cnt_incr)) \<in> cnt_assn\<^sup>d *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a cnt_assn"
  apply sepref_to_hoare
  unfolding cnt_incr_def cnt_incr_impl_def cnt_assn_def
  by (sep_auto simp: refine_pw_simps)

lemma cnt_decr_hnr[sepref_fr_rules]: "(uncurry cnt_decr_impl, uncurry (PR_CONST cnt_decr)) \<in> cnt_assn\<^sup>d *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a cnt_assn"
  apply sepref_to_hoare
  unfolding cnt_decr_def cnt_decr_impl_def cnt_assn_def
  by (sep_auto simp: refine_pw_simps)

subsubsection \<open>Combined Frequency Count and Labeling\<close>
definition "clc_assn \<equiv> cnt_assn \<times>\<^sub>a l_assn"

sepref_thm clc_init_impl is "PR_CONST clc_init" :: "nat_assn\<^sup>k \<rightarrow>\<^sub>a clc_assn"
  unfolding clc_init_def PR_CONST_def clc_assn_def
  by sepref
concrete_definition (in -) clc_init_impl
  uses Network_Impl.clc_init_impl.refine_raw
lemmas [sepref_fr_rules] = clc_init_impl.refine[OF Network_Impl_axioms]

sepref_thm clc_get_impl is "uncurry (PR_CONST clc_get)"
  :: "clc_assn\<^sup>k *\<^sub>a node_assn\<^sup>k \<rightarrow>\<^sub>a nat_assn"
  unfolding clc_get_def PR_CONST_def clc_assn_def
  by sepref
concrete_definition (in -) clc_get_impl
  uses Network_Impl.clc_get_impl.refine_raw is "(uncurry ?f,_)\<in>_"
lemmas [sepref_fr_rules] = clc_get_impl.refine[OF Network_Impl_axioms]

sepref_thm clc_get_rlx_impl is "uncurry (PR_CONST clc_get_rlx)"
  :: "clc_assn\<^sup>k *\<^sub>a node_assn\<^sup>k \<rightarrow>\<^sub>a nat_assn"
  unfolding clc_get_rlx_def PR_CONST_def clc_assn_def
  by sepref
concrete_definition (in -) clc_get_rlx_impl
  uses Network_Impl.clc_get_rlx_impl.refine_raw is "(uncurry ?f,_)\<in>_"
lemmas [sepref_fr_rules] = clc_get_rlx_impl.refine[OF Network_Impl_axioms]

sepref_thm clc_set_impl is "uncurry2 (PR_CONST clc_set)"
  :: "clc_assn\<^sup>d *\<^sub>a node_assn\<^sup>k *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a clc_assn"
  unfolding clc_set_def PR_CONST_def clc_assn_def
  by sepref
concrete_definition (in -) clc_set_impl
  uses Network_Impl.clc_set_impl.refine_raw is "(uncurry2 ?f,_)\<in>_"
lemmas [sepref_fr_rules] = clc_set_impl.refine[OF Network_Impl_axioms]

sepref_thm clc_has_gap_impl is "uncurry (PR_CONST clc_has_gap)"
  :: "clc_assn\<^sup>k *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn"
  unfolding clc_has_gap_def PR_CONST_def clc_assn_def
  by sepref
concrete_definition (in -) clc_has_gap_impl
  uses Network_Impl.clc_has_gap_impl.refine_raw is "(uncurry ?f,_)\<in>_"
lemmas [sepref_fr_rules] = clc_has_gap_impl.refine[OF Network_Impl_axioms]

subsubsection \<open>Push\<close>

sepref_thm push_impl is "uncurry2 (PR_CONST push2)"
  :: "x_assn\<^sup>d *\<^sub>a cf_assn\<^sup>d *\<^sub>a edge_assn\<^sup>k \<rightarrow>\<^sub>a (x_assn\<times>\<^sub>acf_assn)"
  unfolding push2_def PR_CONST_def
  by sepref
concrete_definition (in -) push_impl
  uses Network_Impl.push_impl.refine_raw is "(uncurry2 ?f,_)\<in>_"
lemmas [sepref_fr_rules] = push_impl.refine[OF Network_Impl_axioms]

subsubsection \<open>Relabel\<close>
sepref_thm min_adj_label_impl is "uncurry3 (PR_CONST min_adj_label)"
  :: "am_assn\<^sup>k *\<^sub>a cf_assn\<^sup>k *\<^sub>a l_assn\<^sup>k *\<^sub>a node_assn\<^sup>k \<rightarrow>\<^sub>a nat_assn"
  unfolding min_adj_label_def PR_CONST_def
  by sepref
concrete_definition (in -) min_adj_label_impl
  uses Network_Impl.min_adj_label_impl.refine_raw is "(uncurry3 ?f,_)\<in>_"
lemmas [sepref_fr_rules] = min_adj_label_impl.refine[OF Network_Impl_axioms]

sepref_thm relabel_impl is "uncurry3 (PR_CONST relabel2)"
  :: "am_assn\<^sup>k *\<^sub>a cf_assn\<^sup>k *\<^sub>a l_assn\<^sup>d *\<^sub>a node_assn\<^sup>k \<rightarrow>\<^sub>a l_assn"
  unfolding relabel2_def PR_CONST_def
  by sepref
concrete_definition (in -) relabel_impl
  uses Network_Impl.relabel_impl.refine_raw is "(uncurry3 ?f,_)\<in>_"
lemmas [sepref_fr_rules] = relabel_impl.refine[OF Network_Impl_axioms]

subsubsection \<open>Gap-Relabel\<close>

sepref_thm gap_impl is "uncurry2 (PR_CONST gap2)"
  :: "nat_assn\<^sup>k *\<^sub>a clc_assn\<^sup>d *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a clc_assn"
  unfolding gap2_def PR_CONST_def
  by sepref
concrete_definition (in -) gap_impl
  uses Network_Impl.gap_impl.refine_raw is "(uncurry2 ?f,_)\<in>_"
lemmas [sepref_fr_rules] = gap_impl.refine[OF Network_Impl_axioms]

sepref_thm min_adj_label_clc_impl is "uncurry3 (PR_CONST min_adj_label_clc)"
  :: "am_assn\<^sup>k *\<^sub>a cf_assn\<^sup>k *\<^sub>a clc_assn\<^sup>k *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a nat_assn"
  unfolding min_adj_label_clc_def PR_CONST_def clc_assn_def
  by sepref

concrete_definition (in -) min_adj_label_clc_impl
  uses Network_Impl.min_adj_label_clc_impl.refine_raw is "(uncurry3 ?f,_)\<in>_"
lemmas [sepref_fr_rules] = min_adj_label_clc_impl.refine[OF Network_Impl_axioms]

sepref_thm clc_relabel_impl is "uncurry3 (PR_CONST clc_relabel2)"
    :: "am_assn\<^sup>k *\<^sub>a cf_assn\<^sup>k *\<^sub>a clc_assn\<^sup>d *\<^sub>a node_assn\<^sup>k \<rightarrow>\<^sub>a clc_assn"
  unfolding clc_relabel2_def PR_CONST_def
  by sepref
concrete_definition (in -) clc_relabel_impl
  uses Network_Impl.clc_relabel_impl.refine_raw is "(uncurry3 ?f,_)\<in>_"
lemmas [sepref_fr_rules] = clc_relabel_impl.refine[OF Network_Impl_axioms]

sepref_thm gap_relabel_impl is "uncurry4 (PR_CONST gap_relabel2)"
    :: "nat_assn\<^sup>k *\<^sub>a am_assn\<^sup>k *\<^sub>a cf_assn\<^sup>k *\<^sub>a clc_assn\<^sup>d *\<^sub>a node_assn\<^sup>k
      \<rightarrow>\<^sub>a clc_assn"
  unfolding gap_relabel2_def PR_CONST_def
  by sepref
concrete_definition (in -) gap_relabel_impl
  uses Network_Impl.gap_relabel_impl.refine_raw is "(uncurry4 ?f,_)\<in>_"
lemmas [sepref_fr_rules] = gap_relabel_impl.refine[OF Network_Impl_axioms]

subsubsection \<open>Initialization\<close>
sepref_thm pp_init_xcf2_impl is "(PR_CONST pp_init_xcf2)"
    :: "am_assn\<^sup>k \<rightarrow>\<^sub>a x_assn \<times>\<^sub>a cf_assn"
  unfolding pp_init_xcf2_def PR_CONST_def
  by sepref
concrete_definition (in -) pp_init_xcf2_impl
  uses Network_Impl.pp_init_xcf2_impl.refine_raw is "(?f,_)\<in>_"
lemmas [sepref_fr_rules] = pp_init_xcf2_impl.refine[OF Network_Impl_axioms]

end \<comment> \<open>Network Implementation Locale\<close>

end


theory weird_nat_add3acc_assoc2
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S y2) z = add3acc Z y2 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

(*hipster add3acc *)

theorem x0 :
  "!! (x1 :: Nat) (x2 :: Nat) (x3 :: Nat) (x4 :: Nat) (x5 :: Nat) .
     (add3acc (add3acc x1 x2 x3) x4 x5) =
       (add3acc x1 (add3acc x2 x3 x4) x5)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory LtakeWhile_repeat
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer

codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

primcorec ltakeWhile :: "('a \<Rightarrow> bool) \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist"
where
  "lnull xs \<or> \<not> P (lhd xs) \<Longrightarrow> lnull (ltakeWhile P xs)"
| "lhd (ltakeWhile P xs) = lhd xs"
| "ltl (ltakeWhile P xs) = ltakeWhile P (ltl xs)"
datatype ('a, 'b) Pair2 = Pair2 'a 'b

primcorec literates :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a Llist"
where "literates f x = LCons x (literates f (f x))"

primcorec repeat :: "'a \<Rightarrow> 'a Llist"
  where "repeat x = LCons x (repeat x)"

datatype 'a Lst =
  Emp
  | Cons "'a" "'a Lst"

fun obsLList :: "int \<Rightarrow> 'a Llist \<Rightarrow> 'a Lst" where
"obsLList n s = (if (n \<le> 0) then Emp else Cons (lhd s) (obsLList (n - 1) (ltl s)))"

(* hipster_obs Llist Lst obsLList ltakeWhile repeat
Nothing non-trivial found *)
theorem ltakeWhile_repeat:
  "ltakeWhile P (repeat x) = (if P x then repeat x else LNil)"
  by hipster_coinduct_sledgehammer

end


(*
  File: Lists_Thms.thy
  Author: Bohua Zhan

  Setup for proof steps related to lists.
*)

section \<open>Setup for lists\<close>

theory Lists_Thms
  imports Set_Thms
begin

subsection \<open>Definition of lists\<close>

setup \<open>add_resolve_prfstep @{thm list.distinct(2)}\<close>
setup \<open>add_forward_prfstep (equiv_forward_th @{thm list.simps(1)})\<close>
setup \<open>fold add_rewrite_rule @{thms List.list.sel}\<close>
setup \<open>add_rewrite_rule @{thm list.collapse}\<close>
setup \<open>add_var_induct_rule @{thm list.induct}\<close>

subsection \<open>Length\<close>

setup \<open>add_rewrite_rule @{thm List.list.size(3)}\<close>
lemma length_one [rewrite]: "length [x] = 1" by simp
lemma length_Cons [rewrite]: "length (a # b) = length b + 1" by simp
lemma length_snoc [rewrite]: "length (xs @ [x]) = length xs + 1" by auto
lemma length_zero_is_nil [forward]: "length xs = 0 \<Longrightarrow> xs = []" by simp
lemma length_gt_zero [forward]: "length xs > 0 \<Longrightarrow> xs \<noteq> []" by simp

subsection \<open>Append\<close>

setup \<open>add_rewrite_rule @{thm List.length_append}\<close>
setup \<open>add_rewrite_rule_cond @{thm List.append.simps(2)} [with_cond "?xs \<noteq> []"]\<close>
setup \<open>add_rewrite_rule @{thm List.hd_append2}\<close>
lemma append_is_empty [forward]: "xs @ ys = [] \<Longrightarrow> xs = [] \<and> ys = []" by simp

lemma cons_to_append [rewrite_back]: "a # b = [a] @ b" by simp

ML_file \<open>list_ac.ML\<close>
ML_file \<open>list_ac_test.ML\<close>

subsection \<open>Showing two lists are equal\<close>

setup \<open>add_backward2_prfstep_cond @{thm nth_equalityI} [with_filt (order_filter "xs" "ys")]\<close>

subsection \<open>Set of elements of a list\<close>

setup \<open>add_rewrite_rule @{thm List.set_simps(1)}\<close>
lemma set_one [rewrite]: "set [u] = {u}" by simp
lemma set_two [rewrite]: "set [u, v] = {u, v}" by simp
lemma set_simps2: "set (x # xs) = {x} \<union> set xs" by simp
setup \<open>add_rewrite_rule_cond @{thm set_simps2} [with_cond "?xs \<noteq> []", with_cond "?xs \<noteq> [?y]"]\<close>
setup \<open>add_rewrite_rule @{thm List.set_append}\<close>
setup \<open>add_rewrite_rule @{thm List.set_rev}\<close>
setup \<open>add_resolve_prfstep @{thm List.finite_set}\<close>
setup \<open>add_backward_prfstep (equiv_forward_th @{thm in_set_conv_nth})\<close>

subsection \<open>hd\<close>

setup \<open>register_wellform_data ("hd xs", ["xs \<noteq> []"])\<close>
setup \<open>add_forward_prfstep_cond @{thm List.hd_in_set} [with_term "hd ?xs"]\<close>

subsection \<open>tl\<close>

setup \<open>add_rewrite_rule @{thm length_tl}\<close>
lemma nth_tl' [rewrite]: "i < length (tl xs) \<Longrightarrow> tl xs ! i = xs ! (i + 1)"
  by (simp add: nth_tl)
lemma set_tl_subset [forward_arg1]: "set (tl xs) \<subseteq> set xs"
  by (metis list.set_sel(2) subsetI tl_Nil)

subsection \<open>nth\<close>

setup \<open>register_wellform_data ("xs ! i", ["i < length xs"])\<close>
setup \<open>add_prfstep_check_req ("xs ! i", "i < length xs")\<close>
setup \<open>add_rewrite_rule_back @{thm hd_conv_nth}\<close>
setup \<open>add_rewrite_rule @{thm List.nth_Cons'}\<close>
setup \<open>add_rewrite_rule @{thm List.nth_append}\<close>
setup \<open>add_forward_prfstep_cond @{thm nth_mem} [with_term "?xs ! ?n"]\<close>

subsection \<open>sorted\<close>

lemma sorted_Nil [resolve]: "sorted []" by simp
lemma sorted_single [resolve]: "sorted [x]" by simp
setup \<open>add_backward_prfstep (equiv_backward_th @{thm sorted.simps(2)})\<close>

lemma sorted_ConsD1 [forward]: "sorted (x # xs) \<Longrightarrow> sorted xs"
  using sorted.simps(2) by blast
lemma sorted_ConsD2 [forward, backward2]: "sorted (x # xs) \<Longrightarrow> y \<in> set xs \<Longrightarrow> x \<le> y"
  using sorted.simps(2) by blast

lemma sorted_appendI [backward]:
  "sorted xs \<and> sorted ys \<and> (\<forall>x\<in>set xs. \<forall>y\<in>set ys. x \<le> y) \<Longrightarrow> sorted (xs @ ys)"
  by (simp add: sorted_append)

lemma sorted_appendE [forward]: "sorted (xs @ ys) \<Longrightarrow> sorted xs \<and> sorted ys"
  by (simp add: sorted_append)

lemma sorted_appendE2 [forward]:
  "sorted (xs @ ys) \<Longrightarrow> x \<in> set xs \<Longrightarrow> \<forall>y\<in>set ys. x \<le> y"
  using sorted_append by blast

lemma sorted_nth_mono' [backward]:
  "sorted xs \<Longrightarrow> j < length xs \<Longrightarrow> i \<le> j \<Longrightarrow> xs ! i \<le> xs ! j" using sorted_nth_mono by auto

lemma sorted_nth_mono_less [forward]:
  "sorted xs \<Longrightarrow> i < length xs \<Longrightarrow> xs ! i < xs ! j \<Longrightarrow> i < j" by (meson leD not_le_imp_less sorted_nth_mono)

subsection \<open>sort\<close>

setup \<open>add_forward_prfstep_cond @{thm sorted_sort} [with_term "sort ?xs"]\<close>
setup \<open>add_rewrite_rule @{thm length_sort}\<close>
setup \<open>add_rewrite_rule @{thm mset_sort}\<close>
setup \<open>add_rewrite_rule @{thm set_sort}\<close>
setup \<open>add_backward_prfstep @{thm properties_for_sort}\<close>
lemma sort_Nil [rewrite]: "sort [] = []" by auto
lemma sort_singleton [rewrite]: "sort [a] = [a]" by auto

subsection \<open>distinct\<close>

lemma distinct_Nil [resolve]: "distinct []" by simp
setup \<open>add_resolve_prfstep @{thm List.distinct_singleton}\<close>
setup \<open>add_rewrite_rule_cond @{thm distinct.simps(2)} [with_cond "?xs \<noteq> []"]\<close>
setup \<open>add_rewrite_rule @{thm distinct_append}\<close>
setup \<open>add_rewrite_rule @{thm distinct_rev}\<close>
setup \<open>add_rewrite_rule @{thm distinct_sort}\<close>
setup \<open>add_resolve_prfstep (equiv_backward_th @{thm distinct_conv_nth})\<close>

lemma distinct_nthE [forward]:
  "distinct xs \<Longrightarrow> i < length xs \<Longrightarrow> j < length xs \<Longrightarrow> xs ! i = xs ! j \<Longrightarrow> i = j"
  using nth_eq_iff_index_eq by blast

subsection \<open>map function\<close>

setup \<open>fold add_rewrite_rule @{thms List.list.map}\<close>
setup \<open>add_rewrite_rule @{thm List.length_map}\<close>
setup \<open>add_rewrite_rule @{thm List.nth_map}\<close>
setup \<open>add_rewrite_rule @{thm List.map_append}\<close>

subsection \<open>Replicate\<close>

setup \<open>add_rewrite_arg_rule @{thm length_replicate}\<close>
setup \<open>add_rewrite_rule @{thm List.nth_replicate}\<close>

subsection \<open>last\<close>

setup \<open>register_wellform_data ("last xs", ["xs \<noteq> []"])\<close>
lemma last_eval1 [rewrite]: "last [x] = x" by simp
lemma last_eval2 [rewrite]: "last [u, v] = v" by simp
setup \<open>add_rewrite_rule @{thm List.last_ConsR}\<close>
setup \<open>add_rewrite_rule @{thm List.last_appendR}\<close>
setup \<open>add_rewrite_rule @{thm List.last_snoc}\<close>
setup \<open>add_rewrite_rule_back @{thm last_conv_nth}\<close>
setup \<open>add_forward_prfstep_cond @{thm List.last_in_set} [with_term "last ?as"]\<close>

subsection \<open>butlast\<close>

setup \<open>add_rewrite_arg_rule @{thm List.length_butlast}\<close>
setup \<open>add_rewrite_rule @{thm List.nth_butlast}\<close>
setup \<open>add_rewrite_rule_back @{thm List.butlast_conv_take}\<close>
setup \<open>add_rewrite_rule @{thm List.butlast_snoc}\<close>
lemma butlast_eval1 [rewrite]: "butlast [x] = []" by simp
lemma butlast_eval2 [rewrite]: "butlast [x, y] = [x]" by simp
lemma butlast_cons [rewrite]: "as \<noteq> [] \<Longrightarrow> butlast (a # as) = a # butlast as" by simp
lemma butlast_append' [rewrite]: "bs \<noteq> [] \<Longrightarrow> butlast (as @ bs) = as @ butlast bs"
  by (simp add: butlast_append)

setup \<open>add_rewrite_rule @{thm List.append_butlast_last_id}\<close>
lemma set_butlast_is_subset: "set (butlast xs) \<subseteq> set xs" by (simp add: in_set_butlastD subsetI)
setup \<open>add_forward_arg1_prfstep @{thm set_butlast_is_subset}\<close>

subsection \<open>List update\<close>

setup \<open>register_wellform_data ("xs[i := x]", ["i < length xs"])\<close>
setup \<open>add_rewrite_arg_rule @{thm List.length_list_update}\<close>
setup \<open>add_rewrite_rule @{thm List.nth_list_update_eq}\<close>
setup \<open>add_rewrite_rule @{thm List.nth_list_update_neq}\<close>
setup \<open>add_rewrite_rule @{thm List.nth_list_update}\<close>

subsection \<open>take\<close>

setup \<open>register_wellform_data ("take n xs", ["n \<le> length xs"])\<close>
setup \<open>add_prfstep_check_req ("take n xs", "n \<le> length xs")\<close>

lemma length_take [rewrite_arg]: "n \<le> length xs \<Longrightarrow> length (take n xs) = n" by simp
lemma nth_take [rewrite]: "i < length (take n xs) \<Longrightarrow> take n xs ! i = xs ! i" by simp

setup \<open>add_rewrite_rule @{thm List.take_0}\<close>
setup \<open>add_rewrite_rule @{thm List.take_Suc_conv_app_nth}\<close>
lemma take_length [rewrite]: "take (length xs) xs = xs" by simp

setup \<open>add_forward_arg1_prfstep @{thm List.set_take_subset}\<close>

lemma take_Suc [rewrite]: "Suc n \<le> length xs \<Longrightarrow> take (Suc n) xs = take n xs @ [nth xs n]"
  using Suc_le_lessD take_Suc_conv_app_nth by blast

setup \<open>add_rewrite_rule @{thm List.take_update_cancel}\<close>
setup \<open>add_rewrite_rule @{thm List.append_take_drop_id}\<close>
setup \<open>add_rewrite_rule @{thm List.take_all}\<close>

subsection \<open>drop\<close>

setup \<open>add_rewrite_arg_rule @{thm List.length_drop}\<close>
lemma nth_drop [rewrite]:
  "i < length (drop n xs) \<Longrightarrow> drop n xs ! i = xs ! (n + i)" by simp

setup \<open>add_rewrite_rule @{thm List.drop_0}\<close>
setup \<open>add_rewrite_rule @{thm List.drop_all}\<close>
setup \<open>add_rewrite_rule_back @{thm List.take_drop}\<close>
setup \<open>add_rewrite_rule @{thm List.drop_drop}\<close>

subsection \<open>rev\<close>

setup \<open>add_rewrite_arg_rule @{thm List.length_rev}\<close>
setup \<open>fold add_rewrite_rule @{thms List.rev.simps}\<close>
setup \<open>add_rewrite_rule @{thm List.rev_append}\<close>
setup \<open>add_rewrite_rule @{thm List.rev_rev_ident}\<close>

subsection \<open>filter\<close>

setup \<open>fold add_rewrite_rule @{thms filter.simps}\<close>
setup \<open>add_rewrite_rule @{thm filter_append}\<close>
setup \<open>add_rewrite_rule_bidir @{thm rev_filter}\<close>

subsection \<open>concat\<close>

setup \<open>fold add_rewrite_rule @{thms concat.simps}\<close>

subsection \<open>mset\<close>

setup \<open>add_rewrite_rule @{thm mset.simps(1)}\<close>
lemma mset_simps_2 [rewrite]: "mset (a # x) = mset x + {#a#}" by simp
setup \<open>add_rewrite_rule @{thm mset_append}\<close>

setup \<open>add_rewrite_rule @{thm mset_eq_setD}\<close>
setup \<open>add_rewrite_rule_cond @{thm in_multiset_in_set} [with_term "set ?xs"]\<close>
setup \<open>add_rewrite_rule_back_cond @{thm in_multiset_in_set} [with_term "mset ?xs"]\<close>
setup \<open>add_backward_prfstep @{thm Multiset.nth_mem_mset}\<close>

lemma in_mset_conv_nth [resolve]: "x \<in># mset xs \<Longrightarrow> \<exists>i<length xs. x = xs ! i"
  by (metis in_multiset_in_set in_set_conv_nth)

lemma hd_in_mset: "xs \<noteq> [] \<Longrightarrow> hd xs \<in># mset xs" by simp
setup \<open>add_forward_prfstep_cond @{thm hd_in_mset} [with_term "hd ?xs", with_term "mset ?xs"]\<close>

lemma last_in_mset: "xs \<noteq> [] \<Longrightarrow> last xs \<in># mset xs" by simp
setup \<open>add_forward_prfstep_cond @{thm last_in_mset} [with_term "last ?xs", with_term "mset ?xs"]\<close>

subsection \<open>Relationship between mset and set of lists\<close>

lemma mset_butlast [rewrite]: "xs \<noteq> [] \<Longrightarrow> mset (butlast xs) = mset xs - {# last xs #}"
  by (metis add_diff_cancel_right' append_butlast_last_id mset.simps(1) mset.simps(2) union_code)

lemma insert_mset_to_set [rewrite]: "mset xs' = mset xs + {# x #} \<Longrightarrow> set xs' = set xs \<union> {x}"
  by (metis set_mset_mset set_mset_single set_mset_union)

lemma delete_mset_to_set [rewrite]:
  "distinct xs \<Longrightarrow> mset xs' = mset xs - {# x #} \<Longrightarrow> set xs' = set xs - {x}"
  by (metis mset_eq_setD mset_remove1 set_remove1_eq)

lemma update_mset_to_set [rewrite]:
  "distinct xs \<Longrightarrow> mset xs' = {# y #} + (mset xs - {# x #}) \<Longrightarrow> set xs' = (set xs - {x}) \<union> {y}"
  by (metis insert_mset_to_set mset_remove1 set_remove1_eq union_commute)

lemma mset_update' [rewrite]:
  "i < length ls \<Longrightarrow> mset (ls[i := v]) = {#v#} + (mset ls - {# ls ! i #})"
  using mset_update by fastforce

subsection \<open>swap\<close>

setup \<open>add_rewrite_rule @{thm mset_swap}\<close>
setup \<open>add_rewrite_rule @{thm set_swap}\<close>

subsection \<open>upto lists\<close>

lemma upt_zero_length [rewrite]: "length [0..<n] = n" by simp
lemma nth_upt_zero [rewrite]: "i < length [0..<n] \<Longrightarrow> [0..<n] ! i = i" by simp

subsection \<open>Lambda lists\<close>

definition list :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a list" where
  "list s n = map s [0 ..< n]"

lemma list_length [rewrite_arg]: "length (list s n) = n" by (simp add: list_def)
lemma list_nth [rewrite]: "i < length (list s n) \<Longrightarrow> (list s n) ! i = s i" by (simp add: list_def)

subsection \<open>Splitting of lists\<close>

setup \<open>add_resolve_prfstep @{thm split_list}\<close>
setup \<open>add_backward_prfstep @{thm not_distinct_decomp}\<close>

subsection \<open>Finiteness\<close>

setup \<open>add_resolve_prfstep @{thm finite_lists_length_le}\<close>

subsection \<open>Cardinality\<close>

setup \<open>add_rewrite_rule @{thm distinct_card}\<close>

end