section \<open>Transition Systems\<close>

theory "Transition_Systems-Transition_Systems"
imports
  "Transition_Systems-Simulation_Systems"
begin

locale transition_system =
  simulation_system \<open>transition\<close> \<open>transition\<close>
  for transition :: "'a \<Rightarrow> 'p relation" (\<open>'(\<rightarrow>\<lparr>_\<rparr>')\<close>)
begin

abbreviation transition_std :: "'p \<Rightarrow> 'a \<Rightarrow> 'p \<Rightarrow> bool" (\<open>(_ \<rightarrow>\<lparr>_\<rparr>/ _)\<close> [51, 0, 51] 50) where
  "p \<rightarrow>\<lparr>\<alpha>\<rparr> q \<equiv> (\<rightarrow>\<lparr>\<alpha>\<rparr>) p q"

subsection \<open>Simulations and Bisimulations\<close>

notation unilateral_progression (infix \<open>\<hookrightarrow>\<close> 50)

notation bilateral_progression (infix \<open>\<mapsto>\<close> 50)

notation simulation (\<open>sim\<close>)

notation bisimulation (\<open>bisim\<close>)

lemma equality_is_simulation:
  shows "sim (=)"
  by (simp add: eq_OO OO_eq)

lemma relation_composition_is_simulation:
  assumes "sim K" and "sim L"
  shows "sim (K OO L)"
proof -
  have "(K OO L)\<inverse>\<inverse> OO (\<rightarrow>\<lparr>\<alpha>\<rparr>) \<le> (\<rightarrow>\<lparr>\<alpha>\<rparr>) OO (K OO L)\<inverse>\<inverse>" for \<alpha>
  proof -
    have "(K OO L)\<inverse>\<inverse> OO (\<rightarrow>\<lparr>\<alpha>\<rparr>) = L\<inverse>\<inverse> OO K\<inverse>\<inverse> OO (\<rightarrow>\<lparr>\<alpha>\<rparr>)"
      by blast
    also from \<open>sim K\<close> have "\<dots> \<le> L\<inverse>\<inverse> OO (\<rightarrow>\<lparr>\<alpha>\<rparr>) OO K\<inverse>\<inverse>"
      by (simp add: relcompp_mono)
    also from \<open>sim L\<close> have "\<dots> \<le> (\<rightarrow>\<lparr>\<alpha>\<rparr>) OO L\<inverse>\<inverse> OO K\<inverse>\<inverse>"
      by fastforce
    also have "\<dots> = (\<rightarrow>\<lparr>\<alpha>\<rparr>) OO (K OO L)\<inverse>\<inverse>"
      by blast
    finally show ?thesis .
  qed
  then show ?thesis
    by simp
qed

lemma equality_is_bisimulation:
  shows "bisim (=)"
  using equality_is_simulation
  by simp

lemma relation_composition_is_bisimulation:
  assumes "bisim K" and "bisim L"
  shows "bisim (K OO L)"
  using relation_composition_is_simulation and assms
  by (simp only: simulation_def bisimulation_def bilateral_progression_def converse_relcompp)

subsection \<open>Bisimilarity\<close>

notation bisimilarity (infix \<open>\<sim>\<close> 50)

lemma bisimilarity_reflexivity_rule [iff]:
  shows "p \<sim> p"
  by (coinduction arbitrary: p) blast

lemma bisimilarity_reflexivity:
  shows "reflp (\<sim>)"
  using bisimilarity_reflexivity_rule ..

lemma bisimilarity_transitivity_rule [trans]:
  assumes "p \<sim> q" and "q \<sim> r"
  shows "p \<sim> r"
  using assms by (coinduction arbitrary: p q r) (auto; elim bisimilarity.cases, blast)

lemma bisimilarity_transitivity:
  shows "transp (\<sim>)"
  using bisimilarity_transitivity_rule ..

theorem bisimilarity_is_equivalence:
  shows "equivp (\<sim>)"
  using bisimilarity_reflexivity and bisimilarity_symmetry and bisimilarity_transitivity
  by (fact equivpI)

subsection \<open>Respectful Functions\<close>

notation shortcut_progression (infix \<open>\<leadsto>\<close> 50)

notation constant_bisimilarity (\<open>[\<sim>]\<close>)

lemma relation_composition_shortcut_progression:
  assumes "K\<^sub>1 \<leadsto> L\<^sub>1" and "K\<^sub>2 \<leadsto> L\<^sub>2"
  shows "K\<^sub>1 OO K\<^sub>2 \<leadsto> L\<^sub>1 OO L\<^sub>2"
  using assms by (simp, blast)

lemma chain_is_respectful [respectful]:
  assumes "respectful \<F>" and "respectful \<G>"
  shows "respectful (\<F> \<frown> \<G>)"
proof -
  have "(\<F> \<frown> \<G>) K \<leadsto> (\<F> \<frown> \<G>) L" if "K \<leadsto> L" for K and L
  proof -
    from \<open>respectful \<F>\<close> and \<open>respectful \<G>\<close> and \<open>K \<leadsto> L\<close> have "\<F> K \<leadsto> \<F> L" and "\<G> K \<leadsto> \<G> L"
      by simp_all
    then show ?thesis
      unfolding chain_def
      by (fact relation_composition_shortcut_progression)
  qed
  then show ?thesis
    by simp
qed

subsection \<open>``Up to'' Methods\<close>

notation simulation_up_to (\<open>sim\<^bsub>_\<^esub>\<close>)

notation bisimulation_up_to (\<open>bisim\<^bsub>_\<^esub>\<close>)

end

end


theory PaperTest
imports "../Nominal2"
begin

atom_decl name

datatype trm =
  Const "string"
| Var "name"
| App "trm" "trm"
| Lam "name" "trm"  ("Lam [_]. _" [100, 100] 100)

fun
  subst :: "trm \<Rightarrow> name \<Rightarrow> name \<Rightarrow> trm"  ("_[_::=_]" [100,100,100] 100)
where
  "(Var x)[y::=p] = (if x=y then (App (App (Const ''unpermute'') (Var p)) (Var x)) else (Var x))"
| "(App t\<^isub>1 t\<^isub>2)[y::=p] = App (t\<^isub>1[y::=p]) (t\<^isub>2[y::=p])"
| "(Lam [x].t)[y::=p] = (if x=y then (Lam [x].t) else Lam [x].(t[y::=p]))"
| "(Const n)[y::=p] = Const n"

datatype utrm =
  UConst "string"
| UnPermute "name" "name"
| UVar "name"
| UApp "utrm" "utrm"
| ULam "name" "utrm"  ("ULam [_]. _" [100, 100] 100)

fun
  usubst :: "utrm \<Rightarrow> name \<Rightarrow> name \<Rightarrow> utrm"  ("_[_:::=_]" [100,100,100] 100)
where
  "(UVar x)[y:::=p] = (if x=y then UnPermute p x else (UVar x))"
| "(UApp t\<^isub>1 t\<^isub>2)[y:::=p] = UApp (t\<^isub>1[y:::=p]) (t\<^isub>2[y:::=p])"
| "(ULam [x].t)[y:::=p] = (if x=y then (ULam [x].t) else ULam [x].(t[y:::=p]))"
| "(UConst n)[y:::=p] = UConst n"
| "(UnPermute x q)[y:::=p] = UnPermute x q"

function
  ss :: "trm \<Rightarrow> nat"
where
  "ss (Var x) = 1"
| "ss (Const s) = 1"
| "ss (Lam [x].t) = 1 + ss t"
| "ss (App (App (Const ''unpermute'') (Var p)) (Var x)) = 1"
| "\<not>(\<exists>p x. t1 = App (Const ''unpermute'') (Var p) \<and> t2 = (Var x)) \<Longrightarrow> ss (App t1 t2) = 1 + ss t1 + ss t2"
defer
apply(simp_all)
apply(auto)[1]
apply(case_tac x)
apply(simp_all)
apply(auto)
apply(blast)
done

termination
  apply(relation "measure (\<lambda>t. size t)")
  apply(simp_all)
  done

fun
  uss :: "utrm \<Rightarrow> nat"
where
  "uss (UVar x) = 1"
| "uss (UConst s) = 1"
| "uss (ULam [x].t) = 1 + uss t"
| "uss (UnPermute x y) = 1"
| "uss (UApp t1 t2) = 1 + uss t1 + uss t2"

lemma trm_uss:
  shows "uss (t[x:::=p]) = uss t"
apply(induct rule: uss.induct)
apply(simp_all)
done

inductive
  ufree :: "utrm \<Rightarrow> bool"
where
  "ufree (UVar x)"
| "s \<noteq> ''unpermute'' \<Longrightarrow> ufree (UConst s)"
| "ufree t \<Longrightarrow> ufree (ULam [x].t)"
| "ufree (UnPermute x y)"
| "\<lbrakk>ufree t1; ufree t2\<rbrakk> \<Longrightarrow> ufree (UApp t1 t2)"

fun
  trans :: "utrm \<Rightarrow> trm" ("\<parallel>_\<parallel>" [100] 100)
where
  "\<parallel>(UVar x)\<parallel> = Var x"
| "\<parallel>(UConst x)\<parallel> = Const x"
| "\<parallel>(UnPermute p x)\<parallel> = (App (App (Const ''unpermute'') (Var p)) (Var x))"
| "\<parallel>(ULam [x].t)\<parallel> = Lam [x].(\<parallel>t\<parallel>)"
| "\<parallel>(UApp t1 t2)\<parallel> = App (\<parallel>t1\<parallel>) (\<parallel>t2\<parallel>)"

function
  utrans :: "trm \<Rightarrow> utrm" ("\<lparr>_\<rparr>" [90] 100)
where
  "\<lparr>Var x\<rparr> = UVar x"
| "\<lparr>Const x\<rparr> = UConst x"
| "\<lparr>Lam [x].t\<rparr> = ULam [x].\<lparr>t\<rparr>"
| "\<lparr>App (App (Const ''unpermute'') (Var p)) (Var x)\<rparr> = UnPermute p x"
| "\<not>(\<exists>p x. t1 = App (Const ''unpermute'') (Var p) \<and> t2 = (Var x)) \<Longrightarrow> \<lparr>App t1 t2\<rparr> = UApp (\<lparr>t1\<rparr>) (\<lparr>t2\<rparr>)"
defer
apply(simp_all)
apply(auto)[1]
apply(case_tac x)
apply(simp_all)
apply(auto)
apply(blast)
done

termination
  apply(relation "measure (\<lambda>t. size t)")
  apply(simp_all)
  done

lemma elim1:
  "ufree t \<Longrightarrow> \<parallel>t\<parallel> \<noteq>(Const ''unpermute'')"
apply(erule ufree.induct)
apply(auto)
done

lemma elim2:
  "ufree t \<Longrightarrow> \<not>(\<exists>p. \<parallel>t\<parallel> = App (Const ''unpermute'') (Var p))"
apply(erule ufree.induct)
apply(auto dest: elim1)
done

lemma ss1:
  "ufree t \<Longrightarrow> uss t = ss (\<parallel>t\<parallel>)"
apply(erule ufree.induct)
apply(simp_all)
apply(subst ss.simps)
apply(auto)
apply(drule elim2)
apply(auto)
done

lemma trans1:
  shows "\<parallel>\<lparr>t\<rparr>\<parallel> = t"
apply(induct t)
apply(simp)
apply(simp)
prefer 2
apply(simp)
apply(case_tac "(\<exists>p x. t1 = App (Const ''unpermute'') (Var p) \<and> t2 = (Var x))")
apply(erule exE)+
apply(simp)
apply(simp)
done

lemma trans_subst:
  shows "\<lparr>t[x ::= p]\<rparr> = \<lparr>t\<rparr>[x :::= p]"
apply(induct rule: subst.induct)
apply(simp)
defer
apply(simp)
apply(simp)
apply(simp)
apply(case_tac "(t1 = App (Const ''unpermute'') (Var p) \<and> t2 = (Var x))")
apply(erule exE)+
apply(simp only:)
apply(subst utrans.simps)
apply(subst usubst.simps)
apply(case_tac "xa = x")
apply(subst (asm) subst.simps)
apply(simp only:)
apply(subst (asm) utrans.simps)
apply(simp only: usubst.simps)
apply(simp)
apply(auto)[1]
apply(case_tac "pa = x")
apply(simp)
prefer 2
apply(simp)
apply(simp)
done

lemma
  "ss (t[x ::= p]) = ss t"
apply(subst (2) trans1[symmetric])
apply(subst ss1[symmetric])

fun
  fr :: "trm \<Rightarrow> name set"
where
  "fr (Var x) = {x}"
| "fr (Const s) = {}"
| "fr (Lam [x].t) = fr t - {x}"
| "fr (App t1 t2) = fr t1 \<union> fr t2"

function
  sfr :: "trm \<Rightarrow> name set"
where
  "sfr (Var x) = {}"
| "sfr (Const s) = {}"
| "sfr (Lam [x].t) = sfr t - {x}"
| "sfr (App (App (Const ''unpermute'') (Var p)) (Var x)) = {p, x}"
| "\<not>(\<exists>p x. t1 = App (Const ''unpermute'') (Var p) \<and> t2 = (Var x)) \<Longrightarrow> sfr (App t1 t2) = sfr t1 \<union> sfr t2"
defer
apply(simp_all)
apply(auto)[1]
apply(case_tac x)
apply(simp_all)
apply(auto)
apply(blast)
done

termination
  apply(relation "measure (\<lambda>t. size t)")
  apply(simp_all)
  done

function
  ss :: "trm \<Rightarrow> nat"
where
  "ss (Var x) = 1"
| "ss (Const s) = 1"
| "ss (Lam [x].t) = 1 + ss t"
| "ss (App (App (Const ''unpermute'') (Var p)) (Var x)) = 1"
| "\<not>(\<exists>p x. t1 = App (Const ''unpermute'') (Var p) \<and> t2 = (Var x)) \<Longrightarrow> ss (App t1 t2) = 1 + ss t1 + ss t2"
defer
apply(simp_all)
apply(auto)[1]
apply(case_tac x)
apply(simp_all)
apply(auto)
apply(blast)
done

termination
  apply(relation "measure (\<lambda>t. size t)")
  apply(simp_all)
  done

inductive
  improper :: "trm \<Rightarrow> bool"
where
  "improper (App (App (Const ''unpermute'') (Var p)) (Var x))"
| "improper p x t \<Longrightarrow> improper p x (Lam [y].t)"
| "\<lbrakk>improper p x t1; improper p x t2\<rbrakk> \<Longrightarrow> improper p x (App t1 t2)"

lemma trm_ss:
  shows "\<not>improper p x t \<Longrightarrow> ss (t[x::= p]) = ss t"
apply(induct rule: ss.induct)
apply(simp)
apply(simp)
apply(simp)
apply(auto)[1]
apply(case_tac "improper p x t")
apply(drule improper.intros(2))
apply(blast)
apply(simp)
using improper.intros(1)
apply(blast)
apply(erule contrapos_pn)
thm contrapos_np
apply(simp)
apply(auto)[1]
apply(simp)
apply(erule disjE)
apply(erule conjE)+
apply(subst ss.simps)
apply(simp)
apply(rule disjI1)
apply(rule allI)
apply(rule notI)

apply(simp del: ss.simps)
apply(erule disjE)
apply(subst ss.simps)
apply(simp)
apply(simp only: subst.simps)
apply(subst ss.simps)
apply(simp del: ss.simps)
apply(rule conjI)
apply(rule impI)
apply(erule conjE)
apply(erule exE)+
apply(subst ss.simps)
apply(simp)
apply(auto)[1]
apply(simp add: if_splits)
apply()

function
  simp :: "name \<Rightarrow> trm \<Rightarrow> trm"
where
  "simp p (Const c) = (Const c)"
| "simp p (Var x) = App (App (Const ''permute'') (Var p)) (Var x)"
| "simp p (App t1 t2) = (if ((\<exists>x. t1 = App (Const ''unpermute'') (Var p) \<and> t2 = (Var x)))
                         then t2
                         else App (simp p t1) (simp p t2))"
| "simp p (Lam [x].t) = Lam [x]. (simp p (t[x ::= p]))"
apply(pat_completeness)
apply(simp_all)
apply(auto)
done

termination
apply(relation "measure (\<lambda>(_, t). size t)")
apply(simp_all)

end


(* Author: Alexander Bentkamp, Universität des Saarlandes
*)
section \<open>Polynomials representing the Deep Network Model\<close>

theory DL_Deep_Model_Poly
imports DL_Deep_Model Polynomials.More_MPoly_Type Jordan_Normal_Form.Determinant
begin

lemma polyfun_det:
assumes "\<And>x. (A x) \<in> carrier_mat n n"
assumes "\<And>x i j. i<n \<Longrightarrow> j<n \<Longrightarrow> polyfun N (\<lambda>x. (A x) $$ (i,j))"
shows "polyfun N (\<lambda>x. det (A x))"
proof -
  {
    fix p assume "p\<in> {p. p permutes {0..<n}}"
    then have "p permutes {0..<n}" by auto
    then have "\<And>x. x < n \<Longrightarrow> p x < n" using permutes_in_image by auto
    then have "polyfun N (\<lambda>x. \<Prod>i = 0..<n. A x $$ (i, p i))"
      using polyfun_Prod[of "{0..<n}" N "\<lambda>i x. A x $$ (i, p i)"] assms by simp
    then have "polyfun N (\<lambda>x. signof p * (\<Prod>i = 0..<n. A x $$ (i, p i)))" using polyfun_const polyfun_mult by blast
  }
  moreover have "finite {i. i permutes {0..<n}}" by (simp add: finite_permutations)
  ultimately show ?thesis  unfolding det_def'[OF assms(1)]
    using polyfun_Sum[OF \<open>finite {i. i permutes {0..<n}}\<close>, of N "\<lambda>p x. signof p * (\<Prod>i = 0..<n. A x $$ (i, p i))"]
    by blast
qed

lemma polyfun_extract_matrix:
assumes "i<m" "j<n"
shows "polyfun {..<a + (m * n + c)} (\<lambda>f. extract_matrix (\<lambda>i. f (i + a)) m n $$ (i,j))"
unfolding index_extract_matrix[OF assms] apply (rule polyfun_single) using two_digit_le[OF assms] by simp

lemma polyfun_mult_mat_vec:
assumes "\<And>x. v x \<in> carrier_vec n"
assumes "\<And>j. j<n \<Longrightarrow> polyfun N (\<lambda>x. v x $ j)"
assumes "\<And>x. A x \<in> carrier_mat m n"
assumes "\<And>i j. i<m \<Longrightarrow> j<n \<Longrightarrow> polyfun N (\<lambda>x. A x $$ (i,j))"
assumes "j < m"
shows "polyfun N (\<lambda>x. ((A x) *\<^sub>v (v x)) $ j)"
proof -
  have "\<And>x. j < dim_row (A x)" using \<open>j < m\<close> assms(3) carrier_matD(1) by force
  have "\<And>x. n = dim_vec (v x)" using assms(1) carrier_vecD by fastforce
  {
    fix i assume "i \<in> {0..<n}"
    then have "i < n" by auto
    {
      fix x
      have "i < dim_vec (v x)" using assms(1) carrier_vecD \<open>i<n\<close> by fastforce
      have "j < dim_row (A x)" using \<open>j < m\<close> assms(3) carrier_matD(1) by force
      have "dim_col (A x) = dim_vec (v x)" by (metis assms(1) assms(3) carrier_matD(2) carrier_vecD)
      then have "row (A x) j $ i = A x $$ (j,i)" "i<n" using \<open>j < dim_row (A x)\<close> \<open>i<n\<close> by (simp_all add: \<open>i < dim_vec (v x)\<close>)
    }
    then have "polyfun N (\<lambda>x. row (A x) j $ i * v x $ i)"
      using polyfun_mult assms(4)[OF \<open>j < m\<close>] assms(2) by fastforce
  }
  then show ?thesis unfolding index_mult_mat_vec[OF \<open>\<And>x. j < dim_row (A x)\<close>] scalar_prod_def
    using polyfun_Sum[of "{0..<n}" N "\<lambda>i x. row (A x) j $ i * v x $ i"] finite_atLeastLessThan[of 0 n] \<open>\<And>x. n = dim_vec (v x)\<close>
    by simp
qed

(* The variable a has been inserted here to make the induction work:*)
lemma polyfun_evaluate_net_plus_a:
assumes "map dim_vec inputs = input_sizes m"
assumes "valid_net m"
assumes "j < output_size m"
shows "polyfun {..<a + count_weights s m} (\<lambda>f. evaluate_net (insert_weights s m (\<lambda>i. f (i + a))) inputs $ j)"
using assms proof (induction m arbitrary:inputs j a)
  case (Input)
  then show ?case unfolding insert_weights.simps evaluate_net.simps using polyfun_const by metis
next
  case (Conv x m)
  then obtain x1 x2 where "x=(x1,x2)" by fastforce
  show ?case unfolding \<open>x=(x1,x2)\<close> insert_weights.simps evaluate_net.simps drop_map unfolding list_of_vec_index
  proof (rule polyfun_mult_mat_vec)
    {
      fix f
      have 1:"valid_net' (insert_weights s m (\<lambda>i. f (i + x1 * x2)))"
        using \<open>valid_net (Conv x m)\<close> valid_net.simps by (metis
        convnet.distinct(1) convnet.distinct(5) convnet.inject(2) remove_insert_weights)
      have 2:"map dim_vec inputs = input_sizes (insert_weights s m (\<lambda>i. f (i + x1 * x2)))"
        using input_sizes_remove_weights remove_insert_weights
        by (simp add: Conv.prems(1))
      have "dim_vec (evaluate_net (insert_weights s m (\<lambda>i. f (i + x1 * x2))) inputs) = output_size m"
       using output_size_correct[OF 1 2] using remove_insert_weights by auto
      then show "evaluate_net (insert_weights s m (\<lambda>i. f (i + x1 * x2))) inputs \<in> carrier_vec (output_size m)"
        using carrier_vec_def by (metis (full_types) mem_Collect_eq)
    }

    have "map dim_vec inputs = input_sizes m" by (simp add: Conv.prems(1))
    have "valid_net m" using Conv.prems(2) valid_net.cases by fastforce
    show "\<And>j. j < output_size m \<Longrightarrow>  polyfun {..<a + count_weights s (Conv (x1, x2) m)}
          (\<lambda>f. evaluate_net (insert_weights s m (\<lambda>i. f (i + x1 * x2 + a))) inputs $ j)"
      unfolding vec_of_list_index count_weights.simps
      using Conv(1)[OF \<open>map dim_vec inputs = input_sizes m\<close> \<open>valid_net m\<close>, of _ "x1 * x2 + a"]
      unfolding semigroup_add_class.add.assoc ab_semigroup_add_class.add.commute[of "x1 * x2" a]
      by blast

    have "output_size m = x2" using Conv.prems(2) \<open>x = (x1, x2)\<close> valid_net.cases by fastforce
    show "\<And>f. extract_matrix (\<lambda>i. f (i + a)) x1 x2 \<in> carrier_mat x1 (output_size m)" unfolding \<open>output_size m = x2\<close> using dim_extract_matrix
      using carrier_matI by (metis (no_types, lifting))

    show "\<And>i j. i < x1 \<Longrightarrow> j < output_size m \<Longrightarrow> polyfun {..<a + count_weights s (Conv (x1, x2) m)} (\<lambda>f. extract_matrix (\<lambda>i. f (i + a)) x1 x2 $$ (i, j))"
      unfolding \<open>output_size m = x2\<close> count_weights.simps using polyfun_extract_matrix[of _ x1 _ x2 a "count_weights s m"] by blast

    show "j < x1" using Conv.prems(3) \<open>x = (x1, x2)\<close> by auto
  qed
next
  case (Pool m1 m2 inputs j a)
  have A2:"\<And>f. map dim_vec (take (length (input_sizes (insert_weights s m1 (\<lambda>i. f (i + a))))) inputs) = input_sizes m1"
    by (metis Pool.prems(1)  append_eq_conv_conj input_sizes.simps(3) input_sizes_remove_weights remove_insert_weights take_map)
  have B2:"\<And>f. map dim_vec (drop (length (input_sizes (insert_weights s m1 (\<lambda>i. f (i + a))))) inputs) = input_sizes m2"
    using Pool.prems(1) append_eq_conv_conj input_sizes.simps(3) input_sizes_remove_weights remove_insert_weights by (metis drop_map)
  have A3:"valid_net m1" and B3:"valid_net m2" using \<open>valid_net (Pool m1 m2)\<close> valid_net.simps by blast+
  have "output_size (Pool m1 m2) = output_size m2" unfolding output_size.simps
    using \<open>valid_net (Pool m1 m2)\<close> "valid_net.cases" by fastforce
  then have A4:"j < output_size m1" and B4:"j < output_size m2" using \<open>j < output_size (Pool m1 m2)\<close> by simp_all

  let ?net1 = "\<lambda>f. evaluate_net (insert_weights s m1 (\<lambda>i. f (i + a)))
    (take (length (input_sizes (insert_weights s m1 (\<lambda>i. f (i + a))))) inputs)"
  let ?net2 = "\<lambda>f. evaluate_net (insert_weights s m2 (if s then \<lambda>i. f (i + a) else (\<lambda>i. f (i + count_weights s m1 + a))))
    (drop (length (input_sizes (insert_weights s m1 (\<lambda>i. f (i + a))))) inputs)"
  have length1: "\<And>f. output_size m1 = dim_vec (?net1 f)"
    by (metis A2 A3 input_sizes_remove_weights output_size_correct remove_insert_weights)
  then have jlength1:"\<And>f. j < dim_vec (?net1 f)" using A4 by metis
  have length2: "\<And>f. output_size m2 = dim_vec (?net2 f)"
    by (metis B2 B3 input_sizes_remove_weights output_size_correct remove_insert_weights)
  then have jlength2:"\<And>f. j < dim_vec (?net2 f)" using B4 by metis
  have cong1:"\<And>xf. (\<lambda>f. evaluate_net (insert_weights s m1 (\<lambda>i. f (i + a)))
        (take (length (input_sizes (insert_weights s m1 (\<lambda>i. xf (i + a))))) inputs) $ j)
         = (\<lambda>f. ?net1 f $ j)"
    using input_sizes_remove_weights remove_insert_weights by auto
  have cong2:"\<And>xf. (\<lambda>f. evaluate_net (insert_weights s m2 (\<lambda>i. f (i + (a + (if s then 0 else count_weights s m1)))))
        (drop (length (input_sizes (insert_weights s m1 (\<lambda>i. xf (i + a))))) inputs) $ j)
         = (\<lambda>f. ?net2 f $ j)"
    unfolding semigroup_add_class.add.assoc[symmetric] ab_semigroup_add_class.add.commute[of a "if s then 0 else count_weights s m1"]
    using input_sizes_remove_weights remove_insert_weights by auto

  show ?case unfolding insert_weights.simps evaluate_net.simps  count_weights.simps
    unfolding  index_component_mult[OF jlength1 jlength2]
    apply (rule polyfun_mult)
     using Pool.IH(1)[OF A2 A3 A4, of a, unfolded cong1]
     apply (simp add:polyfun_subset[of "{..<a + count_weights s m1}" "{..<a + (if s then max (count_weights s m1) (count_weights s m2) else count_weights s m1 + count_weights s m2)}"])
    using Pool.IH(2)[OF B2 B3 B4, of "a + (if s then 0 else count_weights s m1)", unfolded cong2 semigroup_add_class.add.assoc[of a]]
    by (simp add:polyfun_subset[of "{..<a + ((if s then 0 else count_weights s m1) + count_weights s m2)}" "{..<a + (if s then max (count_weights s m1) (count_weights s m2) else count_weights s m1 + count_weights s m2)}"])
qed

lemma polyfun_evaluate_net:
assumes "map dim_vec inputs = input_sizes m"
assumes "valid_net m"
assumes "j < output_size m"
shows "polyfun {..<count_weights s m} (\<lambda>f. evaluate_net (insert_weights s m f) inputs $ j)"
using polyfun_evaluate_net_plus_a[where a=0, OF assms] by simp

lemma polyfun_tensors_from_net:
assumes "valid_net m"
assumes "is \<lhd> input_sizes m"
assumes "j < output_size m"
shows "polyfun {..<count_weights s m} (\<lambda>f. Tensor.lookup (tensors_from_net (insert_weights s m f) $ j) is)"
proof -
  have 1:"\<And>f. valid_net' (insert_weights s m f)" by (simp add: assms(1) remove_insert_weights)
  have input_sizes:"\<And>f. input_sizes (insert_weights s m f) = input_sizes m"
    unfolding input_sizes_remove_weights by (simp add: remove_insert_weights)
  have 2:"\<And>f. is \<lhd> input_sizes (insert_weights s m f)"
    unfolding input_sizes using assms(2) by blast
  have 3:"\<And>f. j < output_size' (insert_weights s m f)"
    by (simp add: assms(3) remove_insert_weights)
  have "\<And>f1 f2. base_input (insert_weights s m f1) is = base_input (insert_weights s m f2) is"
    unfolding base_input_def by (simp add: input_sizes)
  then have "\<And>xf. (\<lambda>f. evaluate_net (insert_weights s m f) (base_input (insert_weights s m xf) is) $ j)
    = (\<lambda>f. evaluate_net (insert_weights s m f) (base_input (insert_weights s m f) is) $ j)"
    by metis
  then show ?thesis unfolding lookup_tensors_from_net[OF 1 2 3]
    using polyfun_evaluate_net[OF base_input_length[OF 2, unfolded input_sizes, symmetric] assms(1) assms(3), of s]
    by simp
qed

lemma polyfun_matricize:
assumes "\<And>x. dims (T x) = ds"
assumes "\<And>is. is \<lhd> ds \<Longrightarrow> polyfun N (\<lambda>x. Tensor.lookup (T x) is)"
assumes "\<And>x. dim_row (matricize I (T x)) = nr"
assumes "\<And>x. dim_col (matricize I (T x)) = nc"
assumes "i < nr"
assumes "j < nc"
shows "polyfun N (\<lambda>x. matricize I (T x) $$ (i,j))"
proof -
  let ?weave = "\<lambda> x. (weave I
    (digit_encode (nths ds I ) i)
    (digit_encode (nths ds (-I )) j))"
  have 1:"\<And>x. matricize I (T x) $$ (i,j) = Tensor.lookup (T x) (?weave x)" unfolding matricize_def
    by (metis (no_types, lifting) assms(1) assms(3) assms(4) assms(5) assms(6) case_prod_conv
    dim_col_mat(1) dim_row_mat(1) index_mat(1) matricize_def)
  have "\<And>x. ?weave x \<lhd> ds"
    using valid_index_weave(1) assms(2) digit_encode_valid_index dim_row_mat(1) matricize_def
    using assms digit_encode_valid_index matricize_def by (metis dim_col_mat(1))
  then have "polyfun N (\<lambda>x. Tensor.lookup (T x) (?weave x))" using assms(2) by simp
  then show ?thesis unfolding 1 using assms(1) by blast
qed

lemma "(\<not> (a::nat) < b) = (a \<ge> b)"
by (metis not_le)

lemma polyfun_submatrix:
assumes "\<And>x. (A x) \<in> carrier_mat m n"
assumes "\<And>x i j. i<m \<Longrightarrow> j<n \<Longrightarrow> polyfun N (\<lambda>x. (A x) $$ (i,j))"
assumes "i < card {i. i < m \<and> i \<in> I}"
assumes "j < card {j. j < n \<and> j \<in> J}"
assumes "infinite I" "infinite J"
shows "polyfun N (\<lambda>x. (submatrix (A x) I J) $$ (i,j))"
proof -
  have 1:"\<And>x. (submatrix (A x) I J) $$ (i,j) = (A x) $$ (pick I i, pick J j)"
    using submatrix_index by (metis (no_types, lifting) Collect_cong assms(1) assms(3) assms(4) carrier_matD(1) carrier_matD(2))
  have "pick I i < m"  "pick J j < n" using card_le_pick_inf[OF \<open>infinite I\<close>] card_le_pick_inf[OF \<open>infinite J\<close>]
    \<open>i < card {i. i < m \<and> i \<in> I}\<close>[unfolded set_le_in] \<open>j < card {j. j < n \<and> j \<in> J}\<close>[unfolded set_le_in] not_less by metis+
  then show ?thesis unfolding 1 by (simp add: assms(2))
qed

context deep_model_correct_params_y
begin

definition witness_submatrix where
"witness_submatrix f = submatrix (A' f) rows_with_1 rows_with_1"

lemma polyfun_tensor_deep_model:
assumes "is \<lhd> input_sizes (deep_model_l rs)"
shows "polyfun {..<weight_space_dim}
  (\<lambda>f. Tensor.lookup (tensors_from_net (insert_weights shared_weights (deep_model_l rs) f) $ y) is)"
proof -
  have 1:"\<And>f. remove_weights (insert_weights shared_weights (deep_model_l rs) f) = deep_model_l rs"
    using remove_insert_weights by metis
  then have "y < output_size ( deep_model_l rs)" using valid_deep_model y_valid length_output_deep_model by force
  have 0:"{..<weight_space_dim} = set [0..<weight_space_dim]" by auto
  then show ?thesis unfolding weight_space_dim_def using polyfun_tensors_from_net assms(1) valid_deep_model
    \<open>y < output_size ( deep_model_l rs )\<close> by metis
qed

lemma input_sizes_deep_model: "input_sizes (deep_model_l rs) = replicate (2 * N_half) (last rs)"
  unfolding N_half_def using input_sizes_deep_model deep
  by (metis (no_types, lifting) Nitpick.size_list_simp(2) One_nat_def Suc_1 Suc_le_lessD diff_Suc_Suc length_tl less_imp_le_nat list.size(3) not_less_eq numeral_3_eq_3 power_eq_if)

lemma polyfun_matrix_deep_model:
assumes "i<(last rs) ^ N_half"
assumes "j<(last rs) ^ N_half"
shows "polyfun {..<weight_space_dim} (\<lambda>f. A' f $$ (i,j))"
proof -
  have 0:"y < output_size ( deep_model_l rs )" using valid_deep_model y_valid length_output_deep_model by force
  have 1:"\<And>f. remove_weights (insert_weights shared_weights (deep_model_l rs) f) = deep_model_l rs"
    using remove_insert_weights by metis
  have 2:"(\<And>f is. is \<lhd> replicate (2 * N_half) (last rs) \<Longrightarrow>
         polyfun {..<weight_space_dim} (\<lambda>x. Tensor.lookup (A x) is))"
    unfolding A_def using polyfun_tensor_deep_model[unfolded input_sizes_deep_model] 0 by blast
  show ?thesis
    unfolding A'_def A_def apply (rule polyfun_matricize)
    using dims_tensor_deep_model[OF 1] 2[unfolded A_def]
    using dims_A'_pow[unfolded A'_def A_def] \<open>i<(last rs) ^ N_half\<close> \<open>j<(last rs) ^ N_half\<close>
    by auto
qed

lemma polyfun_submatrix_deep_model:
assumes "i < r ^ N_half"
assumes "j < r ^ N_half"
shows "polyfun {..<weight_space_dim} (\<lambda>f. witness_submatrix f $$ (i,j))"
unfolding witness_submatrix_def
proof (rule polyfun_submatrix)
  have 1:"\<And>f. remove_weights (insert_weights shared_weights (deep_model_l rs) f) = deep_model_l rs"
    using remove_insert_weights by metis
  show "\<And>f. A' f \<in> carrier_mat ((last rs) ^ N_half) ((last rs) ^ N_half)"
    using "1" dims_A'_pow using weight_space_dim_def by auto
  show "\<And>f i j. i < last rs ^ N_half \<Longrightarrow> j < last rs ^ N_half \<Longrightarrow>
        polyfun {..<weight_space_dim} (\<lambda>f. A' f $$ (i, j))"
    using polyfun_matrix_deep_model weight_space_dim_def by force
  show "i < card {i. i < last rs ^ N_half \<and> i \<in> rows_with_1}"
    using assms(1) card_rows_with_1 dims_Aw'_pow set_le_in by metis
  show "j < card {i. i < last rs ^ N_half \<and> i \<in> rows_with_1}"
    using assms(2) card_rows_with_1 dims_Aw'_pow set_le_in by metis
  show "infinite rows_with_1" "infinite rows_with_1" by (simp_all add: infinite_rows_with_1)
qed

lemma polyfun_det_deep_model:
shows "polyfun {..<weight_space_dim} (\<lambda>f. det (witness_submatrix f))"
proof (rule polyfun_det)
  fix f
  have "remove_weights (insert_weights shared_weights (deep_model_l rs) f) = deep_model_l rs"
    using remove_insert_weights by metis

  show "witness_submatrix f \<in> carrier_mat (r ^ N_half) (r ^ N_half)"
    unfolding witness_submatrix_def apply (rule carrier_matI) unfolding dim_submatrix[unfolded set_le_in]
    unfolding dims_A'_pow[unfolded weight_space_dim_def] using card_rows_with_1 dims_Aw'_pow by simp_all
  show "\<And>i j. i < r ^ N_half \<Longrightarrow> j < r ^ N_half \<Longrightarrow> polyfun {..<weight_space_dim} (\<lambda>f. witness_submatrix f $$ (i, j))"
    using polyfun_submatrix_deep_model by blast
qed

end

end


(*  Title:       Proving the Correctness of Disk Paxos

    Author:      Mauro J. Jaskelioff, Stephan Merz, 2005
    Maintainer:  Mauro J. Jaskelioff <mauro at fceia.unr.edu.ar>
*)

header "Proof of Disk Paxos' Invariant"

theory DiskPaxos_Inv1 imports DiskPaxos_Model begin

subsection {* Invariant 1 *}

text{* This is just a type Invariant. *}

definition Inv1 :: "state \<Rightarrow> bool"
where
  "Inv1 s = (\<forall>p.
     inpt s p \<in> Inputs
   \<and> phase s p \<le> 3
   \<and> finite (allRdBlks s p))"

definition HInv1 :: "state \<Rightarrow> bool"
where
  "HInv1 s =
     (Inv1 s
    \<and> allInput s \<subseteq> Inputs)"

declare HInv1_def [simp]

text {*
  We added the assertion that the set $allRdBlks p$ is finite
  for every process $p$; one may therefore choose a block with a
  maximum ballot number in action $EndPhase1$.
*}

text {*
  With the following the lemma, it will be enough to prove
  Inv1 s' for every action, without taking the history variables in account.
*}

lemma HNextPart_Inv1: "\<lbrakk> HInv1 s; HNextPart s s'; Inv1 s' \<rbrakk> \<Longrightarrow> HInv1 s'"
  by(auto simp add: HNextPart_def Inv1_def)

theorem HInit_HInv1: "HInit s \<longrightarrow> HInv1 s"
  by(auto simp add: HInit_def Inv1_def Init_def allRdBlks_def)

lemma allRdBlks_finite:
  assumes inv: "HInv1 s"
  and     asm: "\<forall>p. allRdBlks s' p \<subseteq> insert bk (allRdBlks s p)"
  shows   "\<forall>p. finite (allRdBlks s' p)"
proof
  fix pp
  from inv
  have "\<forall>p. finite (allRdBlks s p)"
    by(simp add: Inv1_def)
  hence "finite (allRdBlks s pp)"
    by blast
  with asm
  show "finite (allRdBlks s' pp)"
    by (auto intro: finite_subset)
qed

theorem HPhase1or2ReadThen_HInv1:
  assumes inv1: "HInv1 s"
  and act: "HPhase1or2ReadThen s s' p d q"
  shows "HInv1 s'"
proof -
  -- {* we focus on the last conjunct of Inv1 *}
  from act
  have "\<forall>p. allRdBlks s' p \<subseteq> allRdBlks s p \<union> {\<lparr>block = disk s d q, proc = q\<rparr>}"
    by(auto simp add: Phase1or2ReadThen_def allRdBlks_def
               split: split_if_asm)
  with inv1
  have "\<forall>p. finite (allRdBlks s' p)"
    by(blast dest: allRdBlks_finite)
  -- {*  the others conjuncts are trivial *}
  with inv1 act
  show ?thesis
    by(auto simp add: Inv1_def Phase1or2ReadThen_def HNextPart_def)
qed

theorem HEndPhase1_HInv1:
  assumes inv1: "HInv1 s"
  and act: "HEndPhase1 s s' p"
  shows "HInv1 s'"
proof -
     from inv1 act
     have "Inv1 s'"
       by(auto simp add:  Inv1_def EndPhase1_def InitializePhase_def allRdBlks_def)
     with inv1 act
     show ?thesis
       by(auto simp del: HInv1_def dest: HNextPart_Inv1)
qed

theorem HStartBallot_HInv1:
  assumes inv1: "HInv1 s"
  and act: "HStartBallot s s' p"
  shows "HInv1 s'"
 proof -
     from inv1 act
     have "Inv1 s'"
       by(auto simp add: Inv1_def StartBallot_def InitializePhase_def allRdBlks_def)
     with inv1 act
     show ?thesis
       by(auto simp del: HInv1_def elim: HNextPart_Inv1)
qed

theorem HPhase1or2Write_HInv1:
  assumes inv1: "HInv1 s"
  and act: "HPhase1or2Write s s' p d"
  shows "HInv1 s'"
proof -
 from inv1 act
 have "Inv1 s'"
   by(auto simp add: Inv1_def Phase1or2Write_def allRdBlks_def)
 with inv1 act
 show ?thesis
   by(auto simp del: HInv1_def elim: HNextPart_Inv1)
qed

theorem HPhase1or2ReadElse_HInv1:
  assumes act: "HPhase1or2ReadElse s s' p d q"
  and inv1: "HInv1 s"
  shows "HInv1 s'"
  using HStartBallot_HInv1[OF inv1] act
  by(auto simp add: Phase1or2ReadElse_def)

theorem HEndPhase2_HInv1:
  assumes inv1: "HInv1 s"
  and  act: "HEndPhase2 s s' p"
  shows "HInv1 s'"
proof -
  from inv1 act
  have "Inv1 s'"
    by(auto simp add: Inv1_def EndPhase2_def InitializePhase_def allRdBlks_def)
  with inv1 act
  show ?thesis
    by(auto simp del: HInv1_def elim: HNextPart_Inv1)
qed

theorem HFail_HInv1:
  assumes inv1: "HInv1 s"
  and     act: "HFail s s' p"
  shows "HInv1 s'"
proof -
  from inv1 act
  have "Inv1 s'"
    by(auto simp add: Inv1_def Fail_def InitializePhase_def allRdBlks_def)
  with inv1 act show ?thesis
  by(auto simp del: HInv1_def elim: HNextPart_Inv1)
qed

theorem HPhase0Read_HInv1:
  assumes inv1: "HInv1 s"
  and     act: "HPhase0Read s s' p d"
  shows "HInv1 s'"
proof -
 -- {* we focus on the last conjunct of Inv1 *}
  from act
  have "\<forall>pp. allRdBlks s' pp \<subseteq> allRdBlks s pp \<union> {\<lparr>block = disk s d p, proc = p\<rparr>}"
    by(auto simp add: Phase0Read_def allRdBlks_def
               split: split_if_asm)
  with inv1
  have "\<forall>p. finite (allRdBlks s' p)"
      by(blast dest: allRdBlks_finite)
  -- {*  the others conjuncts are trivial *}
  with inv1 act
  have "Inv1 s'"
    by(auto simp add: Inv1_def Phase0Read_def)
  with inv1 act
  show ?thesis
  by(auto simp del: HInv1_def elim: HNextPart_Inv1)
qed

theorem HEndPhase0_HInv1:
  assumes inv1: "HInv1 s"
  and act: "HEndPhase0 s s' p"
  shows "HInv1 s'"
proof -
  from inv1 act
  have "Inv1 s'"
    by(auto simp add: Inv1_def EndPhase0_def allRdBlks_def InitializePhase_def)
  with inv1 act
  show ?thesis
    by(auto simp del: HInv1_def elim: HNextPart_Inv1)
qed

declare HInv1_def [simp del]

text {* $HInv1$ is an invariant of $HNext$ *}

lemma I2a:
  assumes nxt: "HNext s s'"
  and inv: "HInv1 s"
  shows "HInv1 s'"
  using assms
  by(auto
    simp add: HNext_def Next_def,
    auto intro: HStartBallot_HInv1,
    auto intro: HPhase0Read_HInv1,
    auto intro: HPhase1or2Write_HInv1,
    auto simp add: Phase1or2Read_def
         intro: HPhase1or2ReadThen_HInv1
                HPhase1or2ReadElse_HInv1,
    auto simp add: EndPhase1or2_def
         intro: HEndPhase1_HInv1
                HEndPhase2_HInv1,
    auto intro: HFail_HInv1,
    auto intro: HEndPhase0_HInv1)

end


theory sort_ISortPermutes
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun insert2 :: "int => int list => int list" where
"insert2 x (Nil2) = Cons2 x (Nil2)"
| "insert2 x (Cons2 z xs) =
     (if x <= z then Cons2 x (Cons2 z xs) else Cons2 z (insert2 x xs))"

fun isort :: "int list => int list" where
"isort (Nil2) = Nil2"
| "isort (Cons2 y xs) = insert2 y (isort xs)"

fun count :: "int => int list => Nat" where
"count x (Nil2) = Z"
| "count x (Cons2 z xs) =
     (if x = z then S (count x xs) else count x xs)"

(*hipster insert2 isort count *)

theorem x0 :
  "!! (x :: int) (y :: int list) . (count x (isort y)) = (count x y)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(*  Title:       Countable Ordinals

    Author:      Brian Huffman, 2005
    Maintainer:  Brian Huffman <brianh at cse.ogi.edu>
*)

section \<open>Recursive Definitions\<close>

theory OrdinalRec
imports OrdinalCont
begin

definition
  oPrec :: "ordinal \<Rightarrow> ordinal" where
  "oPrec x = (THE p. x = oSuc p)"

lemma oPrec_oSuc [simp]: "oPrec (oSuc x) = x"
  by (simp add: oPrec_def)

lemma oPrec_less: "\<exists>p. x = oSuc p \<Longrightarrow> oPrec x < x"
  by clarsimp

definition
  ordinal_rec0 ::
    "['a, ordinal \<Rightarrow> 'a \<Rightarrow> 'a, (nat \<Rightarrow> 'a) \<Rightarrow> 'a, ordinal] \<Rightarrow> 'a" where
  "ordinal_rec0 z s l \<equiv> wfrec {(x,y). x < y} (\<lambda>F x.
    if x = 0 then z else
    if (\<exists>p. x = oSuc p) then s (oPrec x) (F (oPrec x)) else
    (THE y. \<forall>f. (\<forall>n. f n < oLimit f) \<and> oLimit f = x
            \<longrightarrow> l (\<lambda>n. F (f n)) = y))"

lemma ordinal_rec0_0 [simp]: "ordinal_rec0 z s l 0 = z"
  by (simp add: cut_apply def_wfrec[OF ordinal_rec0_def wf])

lemma ordinal_rec0_oSuc: "ordinal_rec0 z s l (oSuc x) = s x (ordinal_rec0 z s l x)"
  by (simp add: cut_apply def_wfrec[OF ordinal_rec0_def wf])

lemma limit_ordinal_not_0: "limit_ordinal x \<Longrightarrow> x \<noteq> 0" and limit_ordinal_not_oSuc: "limit_ordinal x \<Longrightarrow> x \<noteq> oSuc p"
  by auto

lemma ordinal_rec0_limit_ordinal:
"limit_ordinal x \<Longrightarrow> ordinal_rec0 z s l x =
 (THE y. \<forall>f. (\<forall>n. f n < oLimit f) \<and> oLimit f = x \<longrightarrow>
   l (\<lambda>n. ordinal_rec0 z s l (f n)) = y)"
 apply (rule trans[OF def_wfrec[OF ordinal_rec0_def wf]])
 apply (simp add: limit_ordinal_not_oSuc limit_ordinal_not_0)
 apply (rule_tac f=The in arg_cong, rule ext)
 apply (rule_tac f=All in arg_cong, rule ext)
 apply safe
  apply (simp add: cut_apply)
 apply (simp add: cut_apply)
done

subsection \<open>Partial orders\<close>

locale porder =
  fixes le  :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "<<" 55)
assumes po_refl:    "\<And>x. x << x"
    and po_trans:   "\<And>x y z. \<lbrakk>x << y; y << z\<rbrakk> \<Longrightarrow> x << z"
    and po_antisym: "\<And>x y. \<lbrakk>x << y; y << x\<rbrakk> \<Longrightarrow> x = y"

lemma porder_order: "porder ((\<le>) :: 'a::order \<Rightarrow> 'a \<Rightarrow> bool)"
  using porder_def by fastforce

lemma (in porder) flip: "porder (\<lambda>x y. y << x)"
  by (metis (no_types, lifting) po_antisym po_refl po_trans porder_def)

locale omega_complete = porder +
  fixes lub :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a"
  assumes is_ub_lub: "\<And>f n. f n << lub f"
  assumes is_lub_lub: "\<And>f x. \<forall>n. f n << x \<Longrightarrow> lub f << x"

lemma (in omega_complete) lub_cong_lemma:
"\<lbrakk>\<forall>n. f n < oLimit f; \<forall>m. g m < oLimit g; oLimit f \<le> oLimit g;
 \<forall>y<oLimit g. \<forall>x\<le>y. F x << F y\<rbrakk>
 \<Longrightarrow> lub (\<lambda>n. F (f n)) << lub (\<lambda>n. F (g n))"
 apply (rule is_lub_lub[rule_format])
  by (metis dual_order.trans is_ub_lub leD linorder_le_cases oLimit_leI po_trans)

lemma (in omega_complete) lub_cong:
"\<lbrakk>\<forall>n. f n < oLimit f; \<forall>m. g m < oLimit g; oLimit f = oLimit g;
 \<forall>y<oLimit g. \<forall>x\<le>y. F x << F y\<rbrakk>
 \<Longrightarrow> lub (\<lambda>n. F (f n)) = lub (\<lambda>n. F (g n))"
  by (simp add: lub_cong_lemma po_antisym)

lemma (in omega_complete) ordinal_rec0_mono:
  assumes s: "\<forall>p x. x << s p x" and "x \<le> y"
  shows "ordinal_rec0 z s lub x << ordinal_rec0 z s lub y"
proof -
  have "\<forall>y\<le>w. \<forall>x\<le>y. ordinal_rec0 z s lub x << ordinal_rec0 z s lub y" for w
  proof (induction w rule: oLimit_induct)
    case zero
    then show ?case
      by (simp add: po_refl)
  next
    case (suc x)
    then show ?case
      by (metis le_oSucE oSuc_le_oSuc ordinal_rec0_oSuc po_refl po_trans s)
  next
    case (lim f)
    then have "\<forall>g. (\<forall>n. g n < oLimit g) \<and> oLimit g = oLimit f \<longrightarrow>
             lub (\<lambda>n. ordinal_rec0 z s lub (g n)) =
             lub (\<lambda>n. ordinal_rec0 z s lub (f n))"
      by (metis linorder_not_le lub_cong oLimit_leI order_le_less strict_mono_less_oLimit)
    with lim have "ordinal_rec0 z s lub (oLimit f) =
                     lub (\<lambda>n. ordinal_rec0 z s lub (f n))"
      apply (simp add: ordinal_rec0_limit_ordinal strict_mono_limit_ordinal)
      by (smt (verit, del_insts) the_equality strict_mono_less_oLimit)
    then show ?case
      by (smt (verit, ccfv_SIG) is_ub_lub le_oLimitE lim.IH order_le_less po_refl po_trans)
  qed
  with assms show ?thesis
    by blast
qed

lemma (in omega_complete) ordinal_rec0_oLimit:
  assumes s: "\<forall>p x. x << s p x"
  shows "ordinal_rec0 z s lub (oLimit f) =
         lub (\<lambda>n. ordinal_rec0 z s lub (f n))"
proof (cases "\<forall>n. f n < oLimit f")
  case True
  then show ?thesis
    apply (simp add: ordinal_rec0_limit_ordinal limit_ordinal_oLimitI)
    apply (rule the_equality)
     apply (metis lub_cong omega_complete.ordinal_rec0_mono omega_complete_axioms s)
    by simp
next
  case False
  then show ?thesis
    apply (simp add: linorder_not_less, clarify)
    by (smt (verit, best) is_lub_lub is_ub_lub le_oLimit ordinal_rec0_mono po_antisym s)
qed

subsection \<open>Recursive definitions for @{typ "ordinal => ordinal"}\<close>

definition
  ordinal_rec ::
    "[ordinal, ordinal \<Rightarrow> ordinal \<Rightarrow> ordinal, ordinal] \<Rightarrow> ordinal" where
  "ordinal_rec z s = ordinal_rec0 z s oLimit"

lemma omega_complete_oLimit: "omega_complete (\<le>) oLimit"
  by (simp add: oLimit_leI omega_complete_axioms_def omega_complete_def porder_order)

lemma ordinal_rec_0 [simp]: "ordinal_rec z s 0 = z"
  by (simp add: ordinal_rec_def)

lemma ordinal_rec_oSuc [simp]:
  "ordinal_rec z s (oSuc x) = s x (ordinal_rec z s x)"
  by (unfold ordinal_rec_def, rule ordinal_rec0_oSuc)

lemma ordinal_rec_oLimit:
  assumes s: "\<forall>p x. x \<le> s p x"
  shows "ordinal_rec z s (oLimit f) = oLimit (\<lambda>n. ordinal_rec z s (f n))"
  by (metis omega_complete.ordinal_rec0_oLimit omega_complete_oLimit ordinal_rec_def s)

lemma continuous_ordinal_rec:
  assumes s: "\<forall>p x. x \<le> s p x"
  shows "continuous (ordinal_rec z s)"
  by (simp add: continuous.intro ordinal_rec_oLimit s)

lemma mono_ordinal_rec:
  assumes s: "\<forall>p x. x \<le> s p x"
  shows "mono (ordinal_rec z s)"
  by (simp add: continuous.mono continuous_ordinal_rec s)

lemma normal_ordinal_rec:
  assumes s: "\<forall>p x. x < s p x"
  shows "normal (ordinal_rec z s)"
  by (simp add: assms continuous.cont continuous_ordinal_rec less_imp_le normalI)

end


theory GDPR_E imports Ebackup       (*GDPR CTD Example. C. Benzmüller & X. Parent, 2019*)
begin
(*Unimportant.*) sledgehammer_params [max_facts=20,timeout=20]
(*Unimportant.*) nitpick_params [user_axioms,expect=genuine,show_all,dont_box]

datatype data = d1 | d2   (*We introduce concrete data objects d1 and d2.*)
datatype indiv = Mary | Peter (*We introduce individuals Mary and Peter.*)
consts process_lawfully::"data\<Rightarrow>\<sigma>" erase::"data\<Rightarrow>\<sigma>" is_protected_by_GDPR::"data\<Rightarrow>\<sigma>"
             belongs_to::"data\<Rightarrow>indiv\<Rightarrow>\<sigma>" is_european::"indiv=>\<sigma> " kill::"indiv\<Rightarrow>\<sigma>"

axiomatization where
(*Data belonging to Europeans is protected by the GDPR.*)
 A0: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>d. (is_european x \<^bold>\<and> belongs_to d x) \<^bold>\<rightarrow> is_protected_by_GDPR d\<rfloor>" and
(*Data d1 is belonging to the European Peter.*)
 F1: "\<lfloor>belongs_to d1 Peter \<^bold>\<and> is_european Peter\<rfloor>" and

(*It is an obligation to process data lawfully.*)
 A1: "\<lfloor>\<^bold>\<forall>d. \<circle><process_lawfully d | is_protected_by_GDPR d>\<rfloor>"  and
(*If data was not processed lawfully, then it is an obligation to erase the data.*)
 A2: "\<lfloor>\<^bold>\<forall>d. \<circle><erase d | is_protected_by_GDPR d  \<^bold>\<and> \<^bold>\<not>process_lawfully d>\<rfloor>" and
(*Implicit: It is an obligation to keep the data if it was processed lawfully.*)
 A3: "\<lfloor>\<^bold>\<forall>d. \<circle><\<^bold>\<not>erase d | is_protected_by_GDPR d \<^bold>\<and> process_lawfully d>\<rfloor>" and
(*Given a situation where data is processed unlawfully.*)
 Situation: "\<lfloor>\<^bold>\<not>process_lawfully d1\<rfloor>\<^sub>l"

(***Some Experiments***)
 lemma True nitpick [satisfy] oops (*Consistency-check: Nitpick finds a model.*)
 lemma False sledgehammer oops (*Inconsistency-check: Can Falsum be derived? No.*)
 lemma "\<lfloor>\<^bold>\<circle><kill Mary>\<rfloor>\<^sub>l" nitpick oops (*Should Mary be killed? —
                                                                   Answer is no. Countermodel by Nitpick.*)
end


(* The definitions for a challenge suggested by Adam Chlipala *)

theory Compile
imports "../Nominal"
begin

atom_decl name

nominal_datatype data =
    DNat
  | DProd "data" "data"
  | DSum "data" "data"

nominal_datatype ty =
    Data "data"
  | Arrow "ty" "ty" ("_\<rightarrow>_" [100,100] 100)

nominal_datatype trm =
  Var "name"
  | Lam "\<guillemotleft>name\<guillemotright>trm" ("Lam [_]._" [100,100] 100)
  | App "trm" "trm"
  | Const "nat"
  | Pr "trm" "trm"
  | Fst "trm"
  | Snd "trm"
  | InL "trm"
  | InR "trm"
  | Case "trm" "\<guillemotleft>name\<guillemotright>trm" "\<guillemotleft>name\<guillemotright>trm"
          ("Case _ of inl _ \<rightarrow> _ | inr _ \<rightarrow> _" [100,100,100,100,100] 100)

nominal_datatype dataI = OneI | NatI

nominal_datatype tyI =
    DataI "dataI"
  | ArrowI "tyI" "tyI" ("_\<rightarrow>_" [100,100] 100)

nominal_datatype trmI =
    IVar "name"
  | ILam "\<guillemotleft>name\<guillemotright>trmI" ("ILam [_]._" [100,100] 100)
  | IApp "trmI" "trmI"
  | IUnit
  | INat "nat"
  | ISucc "trmI"
  | IAss "trmI" "trmI" ("_\<mapsto>_" [100,100] 100)
  | IRef "trmI"
  | ISeq "trmI" "trmI" ("_;;_" [100,100] 100)
  | Iif "trmI" "trmI" "trmI"

text {* valid contexts *}

inductive
  valid :: "(name\<times>'a::pt_name) list \<Rightarrow> bool"
where
  v1[intro]: "valid []"
| v2[intro]: "\<lbrakk>valid \<Gamma>;a\<sharp>\<Gamma>\<rbrakk>\<Longrightarrow> valid ((a,\<sigma>)#\<Gamma>)" (* maybe dom of \<Gamma> *)

text {* typing judgements for trms *}

inductive
  typing :: "(name\<times>ty) list\<Rightarrow>trm\<Rightarrow>ty\<Rightarrow>bool" (" _ \<turnstile> _ : _ " [80,80,80] 80)
where
  t0[intro]: "\<lbrakk>valid \<Gamma>; (x,\<tau>)\<in>set \<Gamma>\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> Var x : \<tau>"
| t1[intro]: "\<lbrakk>\<Gamma> \<turnstile> e1 : \<tau>1\<rightarrow>\<tau>2; \<Gamma> \<turnstile> e2 : \<tau>1\<rbrakk>\<Longrightarrow> \<Gamma> \<turnstile> App e1 e2 : \<tau>2"
| t2[intro]: "\<lbrakk>x\<sharp>\<Gamma>;((x,\<tau>1)#\<Gamma>) \<turnstile> t : \<tau>2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [x].t : \<tau>1\<rightarrow>\<tau>2"
| t3[intro]: "valid \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> Const n : Data(DNat)"
| t4[intro]: "\<lbrakk>\<Gamma> \<turnstile> e1 : Data(\<sigma>1); \<Gamma> \<turnstile> e2 : Data(\<sigma>2)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Pr e1 e2 : Data (DProd \<sigma>1 \<sigma>2)"
| t5[intro]: "\<lbrakk>\<Gamma> \<turnstile> e : Data(DProd \<sigma>1 \<sigma>2)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Fst e : Data(\<sigma>1)"
| t6[intro]: "\<lbrakk>\<Gamma> \<turnstile> e : Data(DProd \<sigma>1 \<sigma>2)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Snd e : Data(\<sigma>2)"
| t7[intro]: "\<lbrakk>\<Gamma> \<turnstile> e : Data(\<sigma>1)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> InL e : Data(DSum \<sigma>1 \<sigma>2)"
| t8[intro]: "\<lbrakk>\<Gamma> \<turnstile> e : Data(\<sigma>2)\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> InR e : Data(DSum \<sigma>1 \<sigma>2)"
| t9[intro]: "\<lbrakk>x1\<sharp>\<Gamma>; x2\<sharp>\<Gamma>; \<Gamma> \<turnstile> e: Data(DSum \<sigma>1 \<sigma>2);
             ((x1,Data(\<sigma>1))#\<Gamma>) \<turnstile> e1 : \<tau>; ((x2,Data(\<sigma>2))#\<Gamma>) \<turnstile> e2 : \<tau>\<rbrakk>
             \<Longrightarrow> \<Gamma> \<turnstile> (Case e of inl x1 \<rightarrow> e1 | inr x2 \<rightarrow> e2) : \<tau>"

text {* typing judgements for Itrms *}

inductive
  Ityping :: "(name\<times>tyI) list\<Rightarrow>trmI\<Rightarrow>tyI\<Rightarrow>bool" (" _ I\<turnstile> _ : _ " [80,80,80] 80)
where
  t0[intro]: "\<lbrakk>valid \<Gamma>; (x,\<tau>)\<in>set \<Gamma>\<rbrakk>\<Longrightarrow> \<Gamma> I\<turnstile> IVar x : \<tau>"
| t1[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e1 : \<tau>1\<rightarrow>\<tau>2; \<Gamma> I\<turnstile> e2 : \<tau>1\<rbrakk>\<Longrightarrow> \<Gamma> I\<turnstile> IApp e1 e2 : \<tau>2"
| t2[intro]: "\<lbrakk>x\<sharp>\<Gamma>;((x,\<tau>1)#\<Gamma>) I\<turnstile> t : \<tau>2\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> ILam [x].t : \<tau>1\<rightarrow>\<tau>2"
| t3[intro]: "valid \<Gamma> \<Longrightarrow> \<Gamma> I\<turnstile> IUnit : DataI(OneI)"
| t4[intro]: "valid \<Gamma> \<Longrightarrow> \<Gamma> I\<turnstile> INat(n) : DataI(NatI)"
| t5[intro]: "\<Gamma> I\<turnstile> e : DataI(NatI) \<Longrightarrow> \<Gamma> I\<turnstile> ISucc(e) : DataI(NatI)"
| t6[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e : DataI(NatI)\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> IRef e : DataI (NatI)"
| t7[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e1 : DataI(NatI); \<Gamma> I\<turnstile> e2 : DataI(NatI)\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> e1\<mapsto>e2 : DataI(OneI)"
| t8[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e1 : DataI(NatI); \<Gamma> I\<turnstile> e2 : \<tau>\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> e1;;e2 : \<tau>"
| t9[intro]: "\<lbrakk>\<Gamma> I\<turnstile> e: DataI(NatI); \<Gamma> I\<turnstile> e1 : \<tau>; \<Gamma> I\<turnstile> e2 : \<tau>\<rbrakk> \<Longrightarrow> \<Gamma> I\<turnstile> Iif e e1 e2 : \<tau>"

text {* capture-avoiding substitution *}

class subst =
  fixes subst :: "'a \<Rightarrow> name \<Rightarrow> 'a \<Rightarrow> 'a"  ("_[_::=_]" [100,100,100] 100)

instantiation trm :: subst
begin

nominal_primrec subst_trm
where
  "(Var x)[y::=t'] = (if x=y then t' else (Var x))"
| "(App t1 t2)[y::=t'] = App (t1[y::=t']) (t2[y::=t'])"
| "\<lbrakk>x\<sharp>y; x\<sharp>t'\<rbrakk> \<Longrightarrow> (Lam [x].t)[y::=t'] = Lam [x].(t[y::=t'])"
| "(Const n)[y::=t'] = Const n"
| "(Pr e1 e2)[y::=t'] = Pr (e1[y::=t']) (e2[y::=t'])"
| "(Fst e)[y::=t'] = Fst (e[y::=t'])"
| "(Snd e)[y::=t'] = Snd (e[y::=t'])"
| "(InL e)[y::=t'] = InL (e[y::=t'])"
| "(InR e)[y::=t'] = InR (e[y::=t'])"
| "\<lbrakk>z\<noteq>x; x\<sharp>y; x\<sharp>e; x\<sharp>e2; z\<sharp>y; z\<sharp>e; z\<sharp>e1; x\<sharp>t'; z\<sharp>t'\<rbrakk> \<Longrightarrow>
     (Case e of inl x \<rightarrow> e1 | inr z \<rightarrow> e2)[y::=t'] =
       (Case (e[y::=t']) of inl x \<rightarrow> (e1[y::=t']) | inr z \<rightarrow> (e2[y::=t']))"
  apply(finite_guess)+
  apply(rule TrueI)+
  apply(simp add: abs_fresh)+
  apply(fresh_guess)+
  done

instance ..

end

instantiation trmI :: subst
begin

nominal_primrec subst_trmI
where
  "(IVar x)[y::=t'] = (if x=y then t' else (IVar x))"
| "(IApp t1 t2)[y::=t'] = IApp (t1[y::=t']) (t2[y::=t'])"
| "\<lbrakk>x\<sharp>y; x\<sharp>t'\<rbrakk> \<Longrightarrow> (ILam [x].t)[y::=t'] = ILam [x].(t[y::=t'])"
| "(INat n)[y::=t'] = INat n"
| "(IUnit)[y::=t'] = IUnit"
| "(ISucc e)[y::=t'] = ISucc (e[y::=t'])"
| "(IAss e1 e2)[y::=t'] = IAss (e1[y::=t']) (e2[y::=t'])"
| "(IRef e)[y::=t'] = IRef (e[y::=t'])"
| "(ISeq e1 e2)[y::=t'] = ISeq (e1[y::=t']) (e2[y::=t'])"
| "(Iif e e1 e2)[y::=t'] = Iif (e[y::=t']) (e1[y::=t']) (e2[y::=t'])"
  apply(finite_guess)+
  apply(rule TrueI)+
  apply(simp add: abs_fresh)+
  apply(fresh_guess)+
  done

instance ..

end

lemma Isubst_eqvt[eqvt]:
  fixes pi::"name prm"
  and   t1::"trmI"
  and   t2::"trmI"
  and   x::"name"
  shows "pi\<bullet>(t1[x::=t2]) = ((pi\<bullet>t1)[(pi\<bullet>x)::=(pi\<bullet>t2)])"
  apply (nominal_induct t1 avoiding: x t2 rule: trmI.strong_induct)
  apply (simp_all add: subst_trmI.simps eqvts fresh_bij)
  done

lemma Isubst_supp:
  fixes t1::"trmI"
  and   t2::"trmI"
  and   x::"name"
  shows "((supp (t1[x::=t2]))::name set) \<subseteq> (supp t2)\<union>((supp t1)-{x})"
  apply (nominal_induct t1 avoiding: x t2 rule: trmI.strong_induct)
  apply (auto simp add: subst_trmI.simps trmI.supp supp_atm abs_supp supp_nat)
  apply blast+
  done

lemma Isubst_fresh:
  fixes x::"name"
  and   y::"name"
  and   t1::"trmI"
  and   t2::"trmI"
  assumes a: "x\<sharp>[y].t1" "x\<sharp>t2"
  shows "x\<sharp>(t1[y::=t2])"
using a
apply(auto simp add: fresh_def Isubst_supp)
apply(drule rev_subsetD)
apply(rule Isubst_supp)
apply(simp add: abs_supp)
done

text {* big-step evaluation for trms *}

inductive
  big :: "trm\<Rightarrow>trm\<Rightarrow>bool" ("_ \<Down> _" [80,80] 80)
where
  b0[intro]: "Lam [x].e \<Down> Lam [x].e"
| b1[intro]: "\<lbrakk>e1\<Down>Lam [x].e; e2\<Down>e2'; e[x::=e2']\<Down>e'\<rbrakk> \<Longrightarrow> App e1 e2 \<Down> e'"
| b2[intro]: "Const n \<Down> Const n"
| b3[intro]: "\<lbrakk>e1\<Down>e1'; e2\<Down>e2'\<rbrakk> \<Longrightarrow> Pr e1 e2 \<Down> Pr e1' e2'"
| b4[intro]: "e\<Down>Pr e1 e2 \<Longrightarrow> Fst e\<Down>e1"
| b5[intro]: "e\<Down>Pr e1 e2 \<Longrightarrow> Snd e\<Down>e2"
| b6[intro]: "e\<Down>e' \<Longrightarrow> InL e \<Down> InL e'"
| b7[intro]: "e\<Down>e' \<Longrightarrow> InR e \<Down> InR e'"
| b8[intro]: "\<lbrakk>e\<Down>InL e'; e1[x::=e']\<Down>e''\<rbrakk> \<Longrightarrow> Case e of inl x1 \<rightarrow> e1 | inr x2 \<rightarrow> e2 \<Down> e''"
| b9[intro]: "\<lbrakk>e\<Down>InR e'; e2[x::=e']\<Down>e''\<rbrakk> \<Longrightarrow> Case e of inl x1 \<rightarrow> e1 | inr x2 \<rightarrow> e2 \<Down> e''"

inductive
  Ibig :: "((nat\<Rightarrow>nat)\<times>trmI)\<Rightarrow>((nat\<Rightarrow>nat)\<times>trmI)\<Rightarrow>bool" ("_ I\<Down> _" [80,80] 80)
where
  m0[intro]: "(m,ILam [x].e) I\<Down> (m,ILam [x].e)"
| m1[intro]: "\<lbrakk>(m,e1)I\<Down>(m',ILam [x].e); (m',e2)I\<Down>(m'',e3); (m'',e[x::=e3])I\<Down>(m''',e4)\<rbrakk>
            \<Longrightarrow> (m,IApp e1 e2) I\<Down> (m''',e4)"
| m2[intro]: "(m,IUnit) I\<Down> (m,IUnit)"
| m3[intro]: "(m,INat(n))I\<Down>(m,INat(n))"
| m4[intro]: "(m,e)I\<Down>(m',INat(n)) \<Longrightarrow> (m,ISucc(e))I\<Down>(m',INat(n+1))"
| m5[intro]: "(m,e)I\<Down>(m',INat(n)) \<Longrightarrow> (m,IRef(e))I\<Down>(m',INat(m' n))"
| m6[intro]: "\<lbrakk>(m,e1)I\<Down>(m',INat(n1)); (m',e2)I\<Down>(m'',INat(n2))\<rbrakk> \<Longrightarrow> (m,e1\<mapsto>e2)I\<Down>(m''(n1:=n2),IUnit)"
| m7[intro]: "\<lbrakk>(m,e1)I\<Down>(m',IUnit); (m',e2)I\<Down>(m'',e)\<rbrakk> \<Longrightarrow> (m,e1;;e2)I\<Down>(m'',e)"
| m8[intro]: "\<lbrakk>(m,e)I\<Down>(m',INat(n)); n\<noteq>0; (m',e1)I\<Down>(m'',e)\<rbrakk> \<Longrightarrow> (m,Iif e e1 e2)I\<Down>(m'',e)"
| m9[intro]: "\<lbrakk>(m,e)I\<Down>(m',INat(0)); (m',e2)I\<Down>(m'',e)\<rbrakk> \<Longrightarrow> (m,Iif e e1 e2)I\<Down>(m'',e)"

text {* Translation functions *}

nominal_primrec
  trans :: "trm \<Rightarrow> trmI"
where
  "trans (Var x) = (IVar x)"
| "trans (App e1 e2) = IApp (trans e1) (trans e2)"
| "trans (Lam [x].e) = ILam [x].(trans e)"
| "trans (Const n) = INat n"
| "trans (Pr e1 e2) =
       (let limit = IRef(INat 0) in
        let v1 = (trans e1) in
        let v2 = (trans e2) in
        (((ISucc limit)\<mapsto>v1);;(ISucc(ISucc limit)\<mapsto>v2));;(INat 0 \<mapsto> ISucc(ISucc(limit))))"
| "trans (Fst e) = IRef (ISucc (trans e))"
| "trans (Snd e) = IRef (ISucc (ISucc (trans e)))"
| "trans (InL e) =
        (let limit = IRef(INat 0) in
         let v = (trans e) in
         (((ISucc limit)\<mapsto>INat(0));;(ISucc(ISucc limit)\<mapsto>v));;(INat 0 \<mapsto> ISucc(ISucc(limit))))"
| "trans (InR e) =
        (let limit = IRef(INat 0) in
         let v = (trans e) in
         (((ISucc limit)\<mapsto>INat(1));;(ISucc(ISucc limit)\<mapsto>v));;(INat 0 \<mapsto> ISucc(ISucc(limit))))"
| "\<lbrakk>x2\<noteq>x1; x1\<sharp>e; x1\<sharp>e2; x2\<sharp>e; x2\<sharp>e1\<rbrakk> \<Longrightarrow>
   trans (Case e of inl x1 \<rightarrow> e1 | inr x2 \<rightarrow> e2) =
       (let v = (trans e) in
        let v1 = (trans e1) in
        let v2 = (trans e2) in
        Iif (IRef (ISucc v)) (v2[x2::=IRef (ISucc (ISucc v))]) (v1[x1::=IRef (ISucc (ISucc v))]))"
  apply(finite_guess add: Let_def)+
  apply(rule TrueI)+
  apply(simp add: abs_fresh Isubst_fresh)+
  apply(fresh_guess add: Let_def)+
  done

nominal_primrec
  trans_type :: "ty \<Rightarrow> tyI"
where
  "trans_type (Data \<sigma>) = DataI(NatI)"
| "trans_type (\<tau>1\<rightarrow>\<tau>2) = (trans_type \<tau>1)\<rightarrow>(trans_type \<tau>2)"
  by (rule TrueI)+

end


(*  Title:      Inductive definition of termination
    Author:      Tobias Nipkow, 2001/2006
    Maintainer:  Tobias Nipkow
*)
theory PTermi imports PLang begin

subsection{*Termination*}

inductive
  termi :: "com \<Rightarrow> state \<Rightarrow> bool" (infixl "\<down>" 50)
where
  Do[iff]: "f s \<noteq> {} \<Longrightarrow> Do f \<down> s"
| Semi[intro!]:   "\<lbrakk> c1 \<down> s0; \<And>s1. s0 -c1\<rightarrow> s1 \<Longrightarrow> c2 \<down> s1 \<rbrakk>
            \<Longrightarrow> (c1;c2) \<down> s0"

| IfTrue[intro,simp]: "\<lbrakk> b s; c1 \<down> s \<rbrakk> \<Longrightarrow> IF b THEN c1 ELSE c2 \<down> s"
| IfFalse[intro,simp]: "\<lbrakk> \<not>b s; c2 \<down> s \<rbrakk> \<Longrightarrow> IF b THEN c1 ELSE c2 \<down> s"

| WhileFalse: "\<not>b s \<Longrightarrow> WHILE b DO c \<down> s"

| WhileTrue:  "\<lbrakk> b s; c \<down> s; \<And>t. s -c\<rightarrow> t \<Longrightarrow> WHILE b DO c \<down> t \<rbrakk>
                \<Longrightarrow> WHILE b DO c \<down> s"
| "body \<down> s \<Longrightarrow> CALL \<down> s"

| Local: "c \<down> f s \<Longrightarrow> LOCAL f;c;g \<down> s"

lemma [iff]: "((c1;c2) \<down> s0) = (c1 \<down> s0 \<and> (\<forall>s1. s0 -c1\<rightarrow> s1 \<longrightarrow> c2 \<down> s1))"
apply(rule iffI)
 prefer 2
 apply(best intro:termi.intros)
apply(erule termi.cases)
apply blast+
done

lemma [iff]: "(IF b THEN c1 ELSE c2 \<down> s) =
              ((if b s then c1 else c2) \<down> s)"
apply simp
apply(rule conjI)
apply(rule impI)
apply(rule iffI)
prefer 2
apply(blast intro:termi.intros)
apply(erule termi.cases)
apply blast+
apply(rule impI)
apply(rule iffI)
prefer 2
apply(blast intro:termi.intros)
apply(erule termi.cases)
apply blast+
done

lemma [iff]: "(CALL \<down> s) = (body \<down> s)"
by(fast elim: termi.cases intro:termi.intros)

lemma [iff]: "(LOCAL f;c;g \<down> s) = (c \<down> f s)"
by(fast elim: termi.cases intro:termi.intros)

lemma termi_while_lemma[rule_format]:
 "w\<down>fk \<Longrightarrow>
 (\<forall>k b c. fk = f k \<and> w = WHILE b DO c \<and> (\<forall>i. f i -c\<rightarrow> f(Suc i))
          \<longrightarrow> (\<exists>i. \<not>b(f i)))"
apply(erule termi.induct)
apply simp_all
apply blast
apply blast
done

lemma termi_while:
 "\<lbrakk> (WHILE b DO c) \<down> f k;  \<forall>i. f i -c\<rightarrow> f(Suc i) \<rbrakk> \<Longrightarrow> \<exists>i. \<not>b(f i)"
by(blast intro:termi_while_lemma)

lemma wf_termi: "wf {(t,s). WHILE b DO c \<down> s \<and> b s \<and> s -c\<rightarrow> t}"
apply(subst wf_iff_no_infinite_down_chain)
apply(rule notI)
apply clarsimp
apply(insert termi_while)
apply blast
done

end


(*
   Title: The Calculus of Communicating Systems
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weak_Cong_Pres
  imports Weak_Cong Weak_Bisim_Pres Weak_Cong_Sim_Pres
begin

lemma actPres:
  fixes P :: ccs
  and   Q :: ccs
  and   \<alpha> :: act

  assumes "P \<cong> Q"

  shows "\<alpha>.(P) \<cong> \<alpha>.(Q)"
using assms
proof(induct rule: weakCongISym2)
  case(cSim P Q)
  from \<open>P \<cong> Q\<close> have "P \<approx> Q" by(rule weakCongruenceWeakBisimulation)
  thus ?case by(rule actPres)
qed

lemma sumPres:
  fixes P :: ccs
  and   Q :: ccs
  and   R :: ccs

  assumes "P \<cong> Q"

  shows "P \<oplus> R \<cong> Q \<oplus> R"
using assms
proof(induct rule: weakCongISym2)
  case(cSim P Q)
  from \<open>P \<cong> Q\<close> have "P \<leadsto><weakBisimulation> Q" by(rule weakCongruenceE)
  thus ?case using Weak_Bisim.reflexive
    by(rule_tac sumPres) auto
qed

lemma parPres:
  fixes P :: ccs
  and   Q :: ccs
  and   R :: ccs

  assumes "P \<cong> Q"

  shows "P \<parallel> R \<cong> Q \<parallel> R"
using assms
proof(induct rule: weakCongISym2)
  case(cSim P Q)
  from \<open>P \<cong> Q\<close> have "P \<leadsto><weakBisimulation> Q" by(rule weakCongruenceE)
  moreover from \<open>P \<cong> Q\<close> have "P \<approx> Q" by(rule weakCongruenceWeakBisimulation)
  ultimately show ?case using Weak_Bisim_Pres.parPres
    by(rule parPres)
qed

  assumes "P \<cong> Q"

  shows "\<lparr>\<nu>x\<rparr>P \<cong> \<lparr>\<nu>x\<rparr>Q"
using assms
proof(induct rule: weakCongISym2)
  case(cSim P Q)
  from \<open>P \<cong> Q\<close> have "P \<leadsto><weakBisimulation> Q" by(rule weakCongruenceE)
  thus ?case using Weak_Bisim_Pres.resPres
    by(rule resPres)
qed

lemma weakBisimBangRel: "bangRel weakBisimulation \<subseteq> weakBisimulation"
proof auto
  fix P Q
  assume "(P, Q) \<in> bangRel weakBisimulation"
  thus "P \<approx> Q"
  proof(induct rule: bangRel.induct)
    case(BRBang P Q)
    from \<open>P \<approx> Q\<close> show "!P \<approx> !Q" by(rule Weak_Bisim_Pres.bangPres)
  next
    case(BRPar R T P Q)
    from \<open>R \<approx> T\<close> have "R \<parallel> P \<approx> T \<parallel> P" by(rule Weak_Bisim_Pres.parPres)
    moreover from \<open>P \<approx> Q\<close> have "P \<parallel> T \<approx> Q \<parallel> T" by(rule Weak_Bisim_Pres.parPres)
    hence "T \<parallel> P \<approx> T \<parallel> Q" by(metis bisimWeakBisimulation Weak_Bisim.transitive parComm)
    ultimately show "R \<parallel> P \<approx> T \<parallel> Q" by(rule Weak_Bisim.transitive)
  qed
qed

  assumes "P \<cong> Q"

  shows "!P \<cong> !Q"
using assms
proof(induct rule: weakCongISym2)
  case(cSim P Q)
  let ?X = "{(P, Q) | P Q. P \<cong> Q}"
  from \<open>P \<cong> Q\<close> have "(P, Q) \<in> ?X" by auto
  moreover have "\<And>P Q. (P, Q) \<in> ?X \<Longrightarrow> P \<leadsto><weakBisimulation> Q" by(auto dest: weakCongruenceE)
  moreover have "?X \<subseteq> weakBisimulation" by(auto intro: weakCongruenceWeakBisimulation)
  ultimately have "!P \<leadsto><bangRel weakBisimulation> !Q" by(rule bangPres)
  thus ?case using weakBisimBangRel by(rule Weak_Cong_Sim.weakMonotonic)
qed

end