(* Title:   Decompose_Update.thy
   Author:  Akama Hitoshi
*)

section \<open>Decomposition of an Update\<close>

theory Decompose_Update
  imports Main HOL.Enum HOL.List
    "../Util/Enum_Nat" "../Util/Scan"
    "../Core/Update" "../Core/SST"
    "../Single_Use/Single_Use"
    "../Decomposition/Shuffle"
begin

text \<open>
  An Update can be divided into two objects:
 - Shuffle (M1): shuffle and concatenate variables.
 - Store   (M2): stores strings which'll be concatenated to variables:
\<close>

text \<open>
  An index of string in Store.
  Both 'y and 'k are required to be an enum class.
  - 'y is the type of variables, and should be enumerated.
  - 'k is the type-level natural number, the boundedness of an update.
\<close>
type_synonym ('y, 'k) index = "'y \<times> 'k option"

text \<open>
  Consider an update which has k occurrences of each variable,
  it also has k + 1 strings between variables.
  So the type "'k option" is used to specify (k+1) indexes of strings.
  - (y, None) means the first string of the assignment to y.
  - (y, Some k) means the following string of k-th occurrence of x.
  Note that the occurrence is counted along bottom-up direction from zero.
  Example:
    x -> (x, None) x (x, Some 2) x (x, Some 1)
    y -> (y, None) x (y, Some 0) y (y, Some 0)
\<close>
type_synonym ('y, 'k, 'b) store = "('y, 'k) index \<Rightarrow> 'b list"

subsection \<open>Utility functions\<close>

fun orElse where
  "orElse None b = b" |
  "orElse (Some a) b = Some a"

lemma orElse_assoc: "orElse (orElse a b) c = orElse a (orElse b c)"
  by (cases a; cases b; cases c; simp)

lemma orElse_eq_Some:
  assumes "orElse x y = Some a"
  shows "x = Some a \<or> y = Some a"
  using assms by (cases x, simp_all)

lemma map_option_orElse:
  "map_option f (orElse a b) = orElse (map_option f a) (map_option f b)"
  by (cases a, simp_all)

lemma option_if_Some_None_eq_Some:
  assumes "(if cond then Some a else None) = Some b"
  shows "a = b"
using assms by (cases cond, simp_all)

lemma option_if_None_Some_eq_Some:
  assumes "(if cond then None else Some a) = Some b"
  shows "a = b"
using assms by (cases cond, simp_all)

lemma option_if_Some_None_eq_None:
  assumes "(if cond then Some a else None) = None"
  shows "\<not>cond"
using assms by (cases cond, simp_all)

lemma option_if_None_Some_eq_None:
  assumes "(if cond then None else Some a) = None"
  shows "cond"
using assms by (cases cond, simp_all)

fun orNil :: "'a list option \<Rightarrow> 'a list" where
  "orNil (Some xs) = xs" |
  "orNil None      = []"

fun seek :: "'y \<Rightarrow> 'y list \<Rightarrow> 'y list" where
  "seek y0 [] = []" |
  "seek y0 (y#ys) = (if y = y0 then ys else seek y0 ys)"

subsection \<open>Auxiliary functions\<close>

fun calc_index_rows :: "'y shuffle \<Rightarrow> 'y list \<Rightarrow> 'y \<Rightarrow> nat" where
  "calc_index_rows s [] x = 0" |
  "calc_index_rows s (y#ys) x = count_list (s y) x + calc_index_rows s ys x"

definition calc_index :: "'y shuffle \<Rightarrow> 'y list \<Rightarrow> 'y list \<Rightarrow> 'y \<Rightarrow> nat" where
  "calc_index s ys xs x = count_list xs x + calc_index_rows s ys x"

fun lookup_row :: "'y shuffle \<Rightarrow> 'y \<Rightarrow> nat \<Rightarrow> 'y list \<Rightarrow> ('y, 'b) scanned_tail \<Rightarrow> 'b list option" where
  "lookup_row s x0 k0 ys [] = None" |
  "lookup_row s x0 k0 ys ((x, as)#xas) =
    (if x = x0 \<and> calc_index s ys (keys_pair xas) x = k0 then Some as else lookup_row s x0 k0 ys xas)"

fun lookup_rec :: "('y, 'b) update \<Rightarrow> 'y \<Rightarrow> nat \<Rightarrow> 'y list \<Rightarrow> 'b list option" where
  "lookup_rec m x0 k0 [] = None" |
  "lookup_rec m x0 k0 (y#ys) = orElse (lookup_row (\<pi>\<^sub>1 m) x0 k0 ys (scan_pair (m y)))
                                       (lookup_rec m x0 k0 ys)"

fun lookup :: "('y, 'b) update \<Rightarrow> 'y \<Rightarrow> nat \<Rightarrow>'y list \<Rightarrow> 'b list" where
  "lookup m x0 k0 ys = orNil (lookup_rec m x0 k0 ys)"

fun give_index_row :: "'y shuffle \<Rightarrow> 'y list \<Rightarrow> 'y list \<Rightarrow> ('y + 'y \<times> nat option) list" where
  "give_index_row s ys Nil    = []" |
  "give_index_row s ys (x#xs) = Inl x # Inr (x, Some (calc_index s ys xs x)) # give_index_row s ys xs"

fun to_nat :: "'k::enum boundedness \<Rightarrow> 'y \<times> 'k option \<Rightarrow> 'y \<times> nat option" where
  "to_nat B (y, None)   = (y, None)" |
  "to_nat B (y, Some k) = (y, Some (enum_to_nat k))"

fun to_enum :: "'k::enum boundedness \<Rightarrow> 'y \<times> nat option \<Rightarrow> 'y \<times> 'k option" where
  "to_enum B (y, None) = (y, None)" |
  "to_enum B (y, Some n) = (y, Some (nat_to_enum n))"

abbreviation to_nat_list :: "'k::enum boundedness \<Rightarrow> 'y \<times> 'k option \<Rightarrow> ('y \<times> nat option) list" where
  "to_nat_list B yk \<equiv> [to_nat B yk]"

abbreviation to_enum_list :: "'k::enum boundedness \<Rightarrow> 'y \<times> nat option \<Rightarrow> ('y \<times> 'k option) list" where
  "to_enum_list B yk \<equiv> [to_enum B yk]"

lemma valuate_give_index_row_post_index_vars[iff]:
  "Inr (x0, k0') \<in> set (give_index_row s ys xs) \<longleftrightarrow>
   (x0, k0') \<in> set (valuate (give_index_row s ys xs))"
 by (induct xs, auto)

subsection \<open>Properties of Auxiliary functions\<close>

lemma keys_pair_scan_pair: "keys_pair (scan_pair u) = extract_variables u"
  by (induct u rule: xw_induct, simp_all)

lemma concat_value_scanned_scan: "concat_value_scanned (scan u) = valuate u"
  by (induct u rule: xw_induct, simp_all)

lemma resolve_shuffle_keys_pair_scan_pair:
  "\<pi>\<^sub>1 m x = keys_pair (scan_pair (m x))"
  unfolding resolve_shuffle_def
  by  (simp add: keys_pair_scan_pair)

lemma there_exists_corresponding_string:
  fixes m :: "('y, 'b) update"
  assumes "(x0, Some k0) \<in> set (valuate (give_index_row (\<pi>\<^sub>1 m) ys (\<pi>\<^sub>1 m y0)))"
  shows "\<exists>as. lookup_row (\<pi>\<^sub>1 m) x0 k0 ys (scan_pair (m y0)) = Some as"
using assms proof (simp add: resolve_shuffle_keys_pair_scan_pair)
  fix xas :: "('y \<times> 'b list) list"
  assume "(x0, Some k0) \<in> set (valuate (give_index_row (\<pi>\<^sub>1 m) ys (keys_pair xas)))"
  then show "\<exists>as. lookup_row (\<pi>\<^sub>1 m) x0 k0 ys xas = Some as"
  by (induct xas rule: pair_induct, auto simp add: resolve_shuffle_def)
qed

lemma there_doesnt_exist_corresponding_string_inner:
  assumes "(x0, Some k0) \<notin> set (valuate (give_index_row s ys (keys_pair xas)))"
  shows "lookup_row s x0 k0 ys xas = None"
  using assms unfolding resolve_shuffle_def
  by (induct xas rule: pair_induct, auto)

lemma there_doesnt_exist_corresponding_string:
  assumes "(x0, Some k0) \<notin> set (valuate (give_index_row (\<pi>\<^sub>1 m) ys (\<pi>\<^sub>1 m y0)))"
  shows "lookup_row (\<pi>\<^sub>1 m) x0 k0 ys (scan_pair (m y0)) = None"
  apply (rule there_doesnt_exist_corresponding_string_inner)
  using assms
  apply (simp add: keys_pair_scan_pair)
  apply (simp add: resolve_shuffle_def)
  done

lemma give_index_row_position_ge:
  assumes "(x0, Some k0) \<in> set (valuate (give_index_row s ys xs))"
  shows "k0 \<ge> calc_index_rows s ys x0"
using assms proof (induct xs)
  case Nil
  then show ?case by (simp)
next
  case (Cons x xs)
  then show ?case using Cons by (cases "x = x0", auto simp add: calc_index_def)
qed

lemma give_index_row_position_lt:
  assumes "(x0, Some k0) \<in> set (valuate (give_index_row s ys xs))"
  shows "k0 < calc_index s ys xs x0"
using assms proof (induct xs)
  case Nil
  then show ?case by (simp)
next
  case (Cons x xs)
  then show ?case using Cons by (cases "x = x0", auto simp add: calc_index_def)
qed

lemma lookup_row_position_lt_None:
  assumes "k0 < calc_index_rows s ys x0"
  shows "lookup_row s x0 k0 ys xas = None"
using assms proof (induct xas rule: pair_induct)
  case Nil
  then show ?case by simp
next
  case (PairCons x as xas)
  then show ?case proof (cases "x = x0")
    case True
    then show ?thesis using PairCons by (simp add: calc_index_def)
  next
    case False
    then show ?thesis using PairCons by simp
  qed
qed

lemma calc_index_rows_seek:
  assumes "y0 \<in> set ys"
  shows "calc_index s (seek y0 ys) (s y0) x0
       \<le> calc_index_rows s ys x0"
using assms proof (induct ys)
  case Nil
  then show ?case by simp
next
  case (Cons y ys)
  show ?case proof (cases "y = y0")
    case True
    then show ?thesis unfolding calc_index_def by simp
  next
    case False
    then have "y0 \<in> set ys" using Cons.prems by simp
    then show ?thesis using False Cons.hyps by simp
  qed
qed

lemma previous_row_does_not_have_same_variable:
  assumes "y0 \<in> set ys"
  assumes "(x0, Some k0) \<in> set (valuate (give_index_row (\<pi>\<^sub>1 m) (seek y0 ys) (\<pi>\<^sub>1 m y0)))"
  shows "lookup_row (\<pi>\<^sub>1 m) x0 k0 ys xs = None"
proof -
  let ?xs0 = "\<pi>\<^sub>1 m y0"
  have "k0 < calc_index (\<pi>\<^sub>1 m) (seek y0 ys) ?xs0 x0"
    using assms(2) by (rule give_index_row_position_lt)
  also have "... \<le> calc_index_rows (\<pi>\<^sub>1 m) ys x0"
    using assms(1) by (rule calc_index_rows_seek)
  finally have "k0 < calc_index_rows (\<pi>\<^sub>1 m) ys x0" .
  then show ?thesis
    by (rule lookup_row_position_lt_None)
qed

lemma post_index_vars_does_not_contain_None:
  "(x0, None) \<notin> set (valuate (give_index_row s ys xs))"
  by (induct xs, simp_all)

lemma inspect_only_this_row:
  assumes "y0 \<in> set ys"
  assumes "(x0, Some k0) \<in> set (valuate (give_index_row (\<pi>\<^sub>1 m) (seek y0 ys) (\<pi>\<^sub>1 m y0)))"
  shows "lookup_rec m x0 k0 ys
       = lookup_row (\<pi>\<^sub>1 m) x0 k0 (seek y0 ys) (scan_pair (m y0))"
  using assms proof (induct ys)
  case Nil
  then show ?case by simp
next
  case (Cons y ys)
  show ?case proof (cases "y = y0")
    case True
    then have "\<exists>as. lookup_row (\<pi>\<^sub>1 m) x0 k0 ys (scan_pair (m y0)) = Some as"
      using Cons by (simp add: there_exists_corresponding_string)
    then show ?thesis using True by auto
  next
    case False
    then have y0: "y0 \<in> set ys" using Cons(2) by simp
    moreover have in_row: "(x0, Some k0) \<in> set (valuate (give_index_row (\<pi>\<^sub>1 m) (seek y0 ys) (\<pi>\<^sub>1 m y0)))"
      using Cons(3) False by simp
    ultimately have *: "lookup_rec m x0 k0 ys = lookup_row (\<pi>\<^sub>1 m) x0 k0 (seek y0 ys) (scan_pair (m y0))"
      using Cons by simp
    have "lookup_row (\<pi>\<^sub>1 m) x0 k0 ys (scan_pair (m y)) = None"
      using y0 in_row by (rule previous_row_does_not_have_same_variable)
    then show ?thesis using * False by simp
  qed
qed

lemma lookup_rec_distinct:
  assumes "distinct ys"
  assumes "ys \<noteq> []"
  shows "\<exists>y0 \<in> set ys.
     lookup_rec m x0 k0 ys
   = lookup_row (\<pi>\<^sub>1 m) x0 k0 (seek y0 ys) (scan_pair (m y0))"
using assms proof (induct ys)
  case Nil
  then show ?case by simp
next
  case (Cons y ys)
  then show ?case proof (cases "ys = []")
    case True
    then show ?thesis by simp
  next
    case False
    then show ?thesis
    proof (cases "lookup_row (\<pi>\<^sub>1 m) x0 k0 ys (scan_pair (m y))")
      case None
      have "distinct ys" using Cons.prems by simp
      then obtain y0 where
        y0: "y0 \<in> set ys \<and> lookup_rec m x0 k0 ys
                         = lookup_row (\<pi>\<^sub>1 m) x0 k0 (seek y0 ys) (scan_pair (m y0))"
        using Cons False by blast
      then have y: "y \<noteq> y0" using Cons.prems by auto
      show ?thesis proof (rule bexI)
        show "lookup_rec m x0 k0 (y # ys)
            = lookup_row (\<pi>\<^sub>1 m) x0 k0 (seek y0 (y # ys)) (scan_pair (m y0))"
          by (simp add: None y y0)
      next
        show "y0 \<in> set (y # ys)" using y0 by simp
      qed
    next
      case (Some a)
      then show ?thesis by simp
    qed
  qed
qed

lemma all_var_index_less_than:
  fixes s :: "'y shuffle"
  assumes "y0 \<in> set ys"
  assumes "(x0, Some k0) \<in> set (valuate (give_index_row s (seek y0 ys) (s y0)))"
  shows "k0 < calc_index_rows s ys x0"
proof -
  have "k0 < calc_index s (seek y0 ys) (s y0) x0"
    using assms(2)
    by (rule give_index_row_position_lt)
  also have "... \<le> calc_index_rows s ys x0"
    using assms(1) by (rule calc_index_rows_seek)
  finally show ?thesis .
qed

subsection \<open>Resolve and Synthesize\<close>

fun resolve_store_nat :: "('y::enum, 'b) update \<Rightarrow> ('y, nat, 'b) store" ("\<pi>\<^sub>2'") where
  "\<pi>\<^sub>2' m (y, None) = fst (scan (m y))" |
  "\<pi>\<^sub>2' m (y, Some k) = lookup m y k (Enum.enum :: 'y list)"

definition resolve_store :: "'k::enum boundedness \<Rightarrow> ('y::enum, 'b) update \<Rightarrow> ('y, 'k::enum, 'b) store" ("\<pi>\<^sub>2") where
  "\<pi>\<^sub>2 B m = \<pi>\<^sub>2' m \<odot> to_nat_list B"

fun empty_store :: "('y::enum, 'k, 'b) store" where
  "empty_store (y, k) = []"

definition synthesize_shuffle_nat :: "'y::enum shuffle \<Rightarrow> 'y \<Rightarrow> ('y + 'y \<times> nat option) list" where
  "synthesize_shuffle_nat s y = Inr (y, None) # give_index_row s (seek y (Enum.enum :: 'y list)) (s y)"

fun synthesize_shuffle :: "'k::enum boundedness \<Rightarrow> 'y::enum shuffle \<Rightarrow> ('y, 'y \<times> 'k option) update" where
  "synthesize_shuffle B s = to_enum_list B \<star> synthesize_shuffle_nat s"

definition synthesize :: "'k::enum boundedness \<Rightarrow> 'y::enum shuffle \<times> ('y, 'k, 'b) store
                      \<Rightarrow> ('y, 'b) update" ("\<pi>\<inverse>") where
  "\<pi>\<inverse> B sa = (case sa of (s, a) \<Rightarrow> a \<star> synthesize_shuffle B s)"

lemma synthesize_simp: "\<pi>\<inverse> B (s, a) = a \<star> synthesize_shuffle B s"
  unfolding synthesize_def by simp

lemma index_cases [case_names VarNone VarSome]:
  assumes "\<And>y. yk = (y, None) \<Longrightarrow> P"
  assumes "\<And>y k. yk = (y, Some k) \<Longrightarrow> P"
  shows "P"
proof (cases yk)
  case (Pair y k)
  then show ?thesis using assms by (cases k, simp_all)
qed

lemma var_index_cases [case_names Var VarNil VarSome]:
  assumes Var:     "(\<And>y.   x = Inl y        \<Longrightarrow> P)"
  assumes VarNil:  "(\<And>y.   x = Inr (y, None) \<Longrightarrow> P)"
  assumes VarSome: "(\<And>y k. x = Inr (y, Some k)   \<Longrightarrow> P)"
  shows "P"
proof (cases x)
  case (Inl y)
  then show ?thesis using Var by simp
next
  case (Inr yk)
  then show ?thesis proof (cases yk)
    case (Pair y k)
    then show ?thesis proof (cases k)
      case None
      then show ?thesis using Inr Pair VarNil by simp
    next
      case (Some k)
      then show ?thesis using Inr Pair VarSome by simp
    qed
  qed
qed

subsection \<open>Properties of Resolve and Synthesize\<close>

lemma map_alpha_synthesize:
  "t \<star> \<pi>\<inverse> B (s, a) = \<pi>\<inverse> B (s, t \<odot> a)"
  by (simp add: synthesize_simp map_alpha_assoc del: synthesize_shuffle.simps)

lemma resolve_idU_idS: "\<pi>\<^sub>1 idU = idS"
  by (rule ext, simp add: idU_def idS_def resolve_shuffle_def)

lemma resolve_idU_empty:
  fixes B :: "'k::enum boundedness"
  shows "\<pi>\<^sub>2 B (idU :: ('y::enum, 'b) update) = empty_store"
proof -
  { fix yk
    have "\<pi>\<^sub>2 B (idU :: ('y::enum, 'b) update) yk = empty_store yk"
    proof (cases yk rule: index_cases)
      case (VarNone y)
      then show ?thesis by (simp add: resolve_store_def idU_def compS_apply)
    next
      case (VarSome y k)
      show ?thesis proof -
        { fix k' ys
          have "orNil (lookup_rec (idU :: ('y::enum, 'b) update) y k' ys) = []"
            by (induct ys, simp_all add: idU_def)
        }
        then show ?thesis by (simp add: resolve_store_def VarSome compS_apply)
      qed
    qed
  } note that = this
  show ?thesis by (rule ext, simp add: that)
qed

lemma resolve_shuffle_distrib: "\<pi>\<^sub>1 (\<phi> \<bullet> \<psi>) = \<pi>\<^sub>1 \<phi> \<odot> \<pi>\<^sub>1 \<psi>"
proof -
  have *: "\<And>u. extract_variables (hat_hom \<phi> u) = concat (map (\<pi>\<^sub>1 \<phi>) (extract_variables u))"
    by (induct_tac u rule: xa_induct, simp_all add: resolve_shuffle_def)
  show ?thesis by (rule ext, simp add: compU_apply resolve_shuffle_def * compS_apply)
qed

lemma resolve_shuffle_map_alpha: "\<pi>\<^sub>1 (t \<star> m) = \<pi>\<^sub>1 m"
proof -
  have *: "\<And>u. extract_variables (hat_alpha t u) = extract_variables u"
    by (induct_tac u rule: xa_induct, simp_all)
  show ?thesis by (rule ext, auto simp add: resolve_shuffle_def map_alpha_def *)
qed

theorem synthesize_inverse_shuffle: "\<pi>\<^sub>1 (\<pi>\<inverse> B (s, a)) = s"
proof -
  { fix xs ys
    have "extract_variables (give_index_row s ys xs) = xs"
      by (induct xs, simp_all)
  } note it = this
  show ?thesis
    by (rule ext, simp add: synthesize_simp resolve_shuffle_map_alpha,
                  simp add: resolve_shuffle_def synthesize_shuffle_nat_def it)
qed

lemma synthesize_idU: "\<pi>\<inverse> B (idS :: 'x shuffle, empty_store) = (idU :: ('x::enum, 'a) update)"
  by (rule ext, simp add: synthesize_def idU_def idS_def scan_def map_alpha_apply synthesize_shuffle_nat_def)

lemma compS_resolve_store_nat:
  fixes \<theta> :: "('y::enum, 'b) update"
  shows "s \<odot> \<pi>\<^sub>2' \<theta> = \<pi>\<^sub>2' (s \<star> \<theta>)"
proof
  fix yk
  show "(s \<odot> \<pi>\<^sub>2' \<theta>) yk = \<pi>\<^sub>2' (s \<star> \<theta>) yk"
  proof (cases yk rule: index_cases)
    case (VarNone y)
    then show ?thesis proof (simp add: compS_apply map_alpha_apply)
      fix u :: "('y + 'b) list"
      show "concat (map s (fst (scan u))) = fst (scan (hat_alpha s u))"
        by (induct u rule: xw_induct, simp_all)
    qed
  next
    case (VarSome y k)
    then show ?thesis proof (simp add: compS_apply resolve_store_def map_alpha_apply)
      fix ys k
      show "concat (map s (orNil (lookup_rec \<theta> y k ys)))
          = orNil (lookup_rec (s \<star> \<theta>) y k ys)" proof -
        have "concat (map s (orNil (lookup_rec \<theta> y k ys)))
            = orNil (map_option (concat o map s) (lookup_rec \<theta> y k ys))"
          by (cases "(lookup_rec \<theta> y k ys)", simp_all)
        also have "... = orNil (lookup_rec (s \<star> \<theta>) y k ys)"
        proof (rule arg_cong[where f="orNil"], induct ys)
          case Nil
          then show ?case by simp
        next
          case (Cons a ys)
          show ?case proof -
            { fix xas
              have "map_option (concat o map s) (lookup_row (\<pi>\<^sub>1 \<theta>) y k ys xas)
                  = lookup_row (\<pi>\<^sub>1 (s \<star> \<theta>)) y k ys (map_value_pair s xas)"
              proof (induct xas rule: pair_induct)
                case Nil
                then show ?case by simp
              next
                case (PairCons x as xas)
                then show ?case by (auto simp add: resolve_shuffle_map_alpha keys_pair_map_value_pair)
              qed
            } note map_option_lookup_rec = this
            { fix u :: "('y + 'b) list"
              have "map_value_pair s (scan_pair u) = scan_pair (hat_alpha s u)"
                by (induct u rule: xw_induct, simp_all)
            } note map_value_pair_scan_pair = this
            show ?thesis
              by (simp add: map_option_orElse map_option_lookup_rec Cons map_value_pair_scan_pair map_alpha_apply[symmetric] del: comp_apply)
          qed
        qed
        finally show ?thesis .
      qed
    qed
  qed
qed

lemma compS_resolve_store:
  fixes \<theta> :: "('y::enum, 'b) update"
  shows "s \<odot> \<pi>\<^sub>2 B \<theta> = \<pi>\<^sub>2 B (s \<star> \<theta>)"
  by (simp add: resolve_store_def map_alpha_apply compS_assoc[symmetric] compS_resolve_store_nat)

lemma resolve_store_preserve_prop_on_string:
  fixes m :: "('x::enum, 'b) update"
  assumes "\<forall>x. list_all P (valuate (m x))"
  shows "\<forall>x k. list_all P (\<pi>\<^sub>2 B m (x, k))"
proof (intro allI)
  fix x0 k0
  have *: "\<forall>x. list_all P (concat_value_scanned (scan (m x)))"
    using assms by (simp add: concat_value_scanned_scan)

  show "list_all P (\<pi>\<^sub>2 B m (x0, k0))" proof (cases k0)
    case None
    have "list_all P (concat_value_scanned (scan (m x0)))"
      using * by simp
    then show ?thesis proof (simp add: None resolve_store_def compS_apply)
      fix sc :: "('x, 'b) scanned"
      assume "list_all P (concat_value_scanned sc)"
      then show "list_all P (fst sc)"
       by (induct sc rule: scanned_rev_induct, simp_all)
    qed
  next
    case (Some k)
    then show ?thesis proof (simp add: resolve_store_def compS_apply)
      fix ys n
      show "list_all P (orNil (lookup_rec m x0 n ys))" proof (induct ys)
        case Nil
        then show ?case by simp
      next
        case (Cons y ys)
        then show ?case
        proof (cases "lookup_row (\<pi>\<^sub>1 m) x0 n ys (scan_pair (m y))")
          case None
          then show ?thesis using Cons by simp
        next
          case (Some as)
          have "list_all P (concat_value_pair (scan_pair (m y)))"
            using * unfolding concat_value_scanned_def by (simp add: snd_scan)
          then show ?thesis using Some proof (simp)
            fix xas :: "('x \<times> 'b list) list" and s
            assume "list_all P (concat_value_pair xas)"
            moreover assume "lookup_row s x0 n ys xas = Some as"
            ultimately show "list_all P as" proof (induct xas rule: pair_induct)
              case Nil
              then show ?case by simp
            next
              case (PairCons x bs xas)
              then show ?case proof (cases "x = x0 \<and> calc_index s ys (keys_pair xas) x = n")
                case True
                then show ?thesis using PairCons by (simp add: True)
              next
                case False
                then show ?thesis using PairCons by (simp add: False)
              qed
            qed
          qed
        qed
      qed
    qed
  qed
qed

lemma synthesize_preserve_prop_on_string:
  assumes "\<forall>x k. list_all P (a (x, k))"
  shows "\<forall>x. list_all P (valuate (\<pi>\<inverse> B (s, a) x))"
proof (auto simp add: synthesize_def map_alpha_apply valuate_hat_alpha synthesize_shuffle_nat_def simp del: to_enum.simps)
  fix x
  show "list_all P (a (to_enum B (x, None)))" using assms by simp
next
  fix x xs ys
  show "list_all P (concat (map (a \<circ> to_enum B) (valuate (give_index_row s ys xs))))"
    using assms by (induct xs, simp_all)
qed

lemma map_alpha_resolve_store:
  "t \<bullet> \<pi>\<^sub>2 B \<theta> = \<pi>\<^sub>2 B (update2hom t \<star> \<theta>)"
  by (simp add: update2hom_compS_compU[symmetric] compS_resolve_store)

subsection \<open>Proof of inverse of Resolve\<close>

fun index_less_than :: "nat \<Rightarrow> 'x \<times> nat option \<Rightarrow> bool" where
  "index_less_than K yk = (\<forall>x0 k0. yk = (x0, Some k0) \<longrightarrow> k0 < K)"

lemma calc_index_rows_eq_sum:
  assumes "distinct ys"
  shows "calc_index_rows s ys x = (\<Sum>y\<in>set ys. count_list (s y) x)"
  using assms by (induct ys, simp_all)

lemma bounded_shuffle_less_than:
  fixes s :: "'y::enum shuffle"
  assumes "bounded_shuffle K s"
  assumes "(x0, Some k0) \<in> set (valuate (give_index_row s (seek y0 (Enum.enum :: 'y list)) (s y0)))"
  shows "k0 < K"
proof -
  let ?enum = "Enum.enum :: 'y list"
  have "y0 \<in> set ?enum"
    by (simp add: enum_UNIV)
  then have "k0 < calc_index_rows s ?enum x0"
    using assms(2) by (rule all_var_index_less_than)
  also have "... = (\<Sum>y::'y\<in>UNIV. count_list (s y) x0)" proof -
    have "distinct ?enum" using enum_distinct by simp
    moreover have "set ?enum = UNIV" using enum_UNIV by simp
    ultimately show ?thesis by (simp add: calc_index_rows_eq_sum)
  qed
  also have "... \<le> K"
    using assms(1) unfolding bounded_shuffle_def by simp
  finally show ?thesis .
qed

lemma bounded_shuffle_index_less_than:
  fixes s :: "'y::enum shuffle"
  assumes "bounded_shuffle K s"
  shows "list_all (index_less_than K) (valuate (give_index_row s (seek y0 (Enum.enum :: 'y list)) (s y0)))"
using assms by (auto simp add: list_all_iff bounded_shuffle_less_than)

fun resolve_store_row where
  "resolve_store_row s ys as xas (x, None)   = as" |
  "resolve_store_row s ys as xas (x, Some k) = orNil (lookup_row s x k ys xas)"

lemma resolve_store_row_induct_lemma:
  assumes "yk \<in> set (valuate (give_index_row s ys (keys_pair xas)))"
  shows "resolve_store_row s ys as ((x0, bs) # xas) yk
       = resolve_store_row s ys as xas yk"
proof (cases yk rule: index_cases)
  case (VarNone y)
  then show ?thesis by simp
next
  case (VarSome y k)
  then show ?thesis proof (cases "y = x0")
    case True
    then show ?thesis using assms by (simp add: VarSome dual_order.strict_implies_not_eq give_index_row_position_lt)
  next
    case False
    then show ?thesis by (simp add: VarSome)
  qed
qed

lemma hat_alpha_ext:
  assumes "\<forall>x \<in> set (valuate u). f x = g x"
  shows "hat_alpha f u = hat_alpha g u"
  using assms by (induct u rule: xa_induct, simp_all)

lemma resolve_inverse_nat:
  "\<pi>\<^sub>2' m \<star> synthesize_shuffle_nat (\<pi>\<^sub>1 m) = m"
proof -
  {
    fix x
    have "(\<pi>\<^sub>2' m \<star> synthesize_shuffle_nat (\<pi>\<^sub>1 m)) x
       = (resolve_store_row (\<pi>\<^sub>1 m) (seek x Enum.enum) (fst (scan (m x))) (snd (scan (m x)))
        \<star> synthesize_shuffle_nat (\<pi>\<^sub>1 m)) x"
    proof (simp add: map_alpha_apply synthesize_shuffle_nat_def snd_scan, rule hat_alpha_ext, rule ballI)
      fix xa
      assume *: "xa \<in> set (valuate (give_index_row (\<pi>\<^sub>1 m) (seek x Enum.enum) (\<pi>\<^sub>1 m x)))"
      show "\<pi>\<^sub>2' m xa
        = resolve_store_row (\<pi>\<^sub>1 m) (seek x enum_class.enum) (fst (scan (m x))) (scan_pair (m x)) xa"
      proof (cases xa rule: index_cases)
        case (VarNone y)
        then show ?thesis using * post_index_vars_does_not_contain_None by fast
      next
        case (VarSome y k)
        have x: "x \<in> set Enum.enum" by (simp add: enum_UNIV)
        then show ?thesis using inspect_only_this_row[OF x *[simplified VarSome]] by (simp add: VarSome)
      qed
    qed
    also have "... = flat (fst (scan (m x)), snd (scan (m x)))"
    proof (simp add: map_alpha_apply resolve_shuffle_def snd_scan synthesize_shuffle_nat_def keys_pair_scan_pair[symmetric])
      fix xas
      show "map Inr (fst (scan (m x))) @
            hat_alpha (resolve_store_row (\<pi>\<^sub>1 m) (seek x enum_class.enum) (fst (scan (m x))) xas)
                 (give_index_row (\<pi>\<^sub>1 m) (seek x enum_class.enum) (keys_pair xas))
        = flat (fst (scan (m x)), xas)"
      proof (simp add: flat_def, induct xas rule: pair_induct)
        case Nil
        then show ?case by simp
      next
        case (PairCons y as xas)
        then show ?case proof -
          have "hat_alpha (resolve_store_row (\<pi>\<^sub>1 m) (seek x enum_class.enum) (fst (scan (m x))) xas) (give_index_row (\<pi>\<^sub>1 m) (seek x enum_class.enum) (keys_pair xas))
           = hat_alpha (resolve_store_row (\<pi>\<^sub>1 m) (seek x enum_class.enum) (fst (scan (m x))) ((y, as) # xas)) (give_index_row (\<pi>\<^sub>1 m) (seek x enum_class.enum) (keys_pair xas))"
            by (rule hat_alpha_ext, simp add: resolve_store_row_induct_lemma)
          then show ?thesis using PairCons by simp
        qed
      qed
    qed
    also have "... = m x"
      by (simp add: scan_inverse)
    finally have "(\<pi>\<^sub>2' m \<star> synthesize_shuffle_nat (\<pi>\<^sub>1 m)) x = m x" .
  }
  then show ?thesis by (rule ext)
qed

lemma hat_alpha_remove_enum:
  fixes B :: "'k::enum boundedness"
  fixes m :: "('y::enum, 'b) update"
  assumes "boundedness B K"
  assumes "list_all (index_less_than K) (valuate u)"
  shows " hat_alpha (to_nat_list B \<odot> to_enum_list B) u = u"
using assms(2) proof (induct u rule: xa_induct)
  case Nil
  then show ?case by simp
next
  case (Var x xs)
  then show ?case by simp
next
  case (Alpha a xs)
  then show ?case
    apply (cases "a" rule: index_cases)
    apply (simp_all add: compS_apply del: index_less_than.simps)
    apply (drule conjunct1)
    using assms(1) unfolding boundedness_def
    apply (simp add: nat_enum_iso)
    done
qed

lemma synthesize_shuffle_nat_remove_enum:
  fixes B :: "'k::enum boundedness"
  fixes s :: "'y::enum shuffle"
  assumes "boundedness B K"
  assumes "bounded_shuffle K s"
  shows "to_nat_list B \<star> to_enum_list B \<star> synthesize_shuffle_nat s
       = synthesize_shuffle_nat s"
  apply (rule ext)
  apply (simp add: map_alpha_assoc del: to_enum.simps)
  apply (simp add: map_alpha_apply del: to_enum.simps)
  apply (rule hat_alpha_remove_enum[OF assms(1)])
  apply (simp add: synthesize_shuffle_nat_def)
  apply (rule bounded_shuffle_index_less_than)
  apply (rule assms(2))
  done

theorem resolve_inverse:
  fixes B :: "'k::enum boundedness"
  fixes m :: "('y::enum, 'b) update"
  assumes "boundedness B k"
  assumes "bounded k m"
  shows "\<pi>\<inverse> B (\<pi>\<^sub>1 m, \<pi>\<^sub>2 B m) = m"
proof (rule ext, simp add: resolve_store_def synthesize_def del: to_enum.simps)
  fix x
  have bs: "bounded_shuffle k (\<pi>\<^sub>1 m)"
    using assms(2) by (simp add: resolve_bounded)
  have "((\<pi>\<^sub>2' m \<odot> to_nat_list B) \<star> to_enum_list B \<star> synthesize_shuffle_nat (\<pi>\<^sub>1 m)) x
      = (\<pi>\<^sub>2' m \<star> to_nat_list B \<star> to_enum_list B \<star> synthesize_shuffle_nat (\<pi>\<^sub>1 m)) x"
    by (simp add: map_alpha_assoc compS_assoc)
  also have "... = m x"
    by (simp add: synthesize_shuffle_nat_remove_enum[OF assms(1) bs] resolve_inverse_nat del: to_enum.simps)
  finally show "((\<pi>\<^sub>2' m \<odot> to_nat_list B) \<star> to_enum_list B \<star> synthesize_shuffle_nat (\<pi>\<^sub>1 m)) x = m x" .
qed

subsection \<open>Lemmas for counting alphabet\<close>

subsection \<open>Example\<close>

fun poyo :: "(bool, char) update" where
  "poyo False = [Inr (CHR ''A''), Inl True, Inr (CHR ''B''), Inl False, Inr (CHR ''C'')]" |
  "poyo True  = [Inr (CHR ''D''), Inl False, Inr (CHR ''E''), Inl True,  Inr (CHR ''F'')]"

definition testB :: "bool boundedness" where
  "testB = Boundedness"

lemmas resolve_store_poyo_expand =
  resolve_store_def resolve_shuffle_def compS_apply
  scan_def scan_pair_def
  enum_to_nat_def calc_index_def
  enum_bool_def

lemma "\<pi>\<^sub>2 testB poyo (False, None) = ''A''"
  by (simp add: resolve_store_poyo_expand)

lemma "\<pi>\<^sub>2 testB poyo (False, Some False) = ''E''"
  by (simp add: resolve_store_poyo_expand)

lemma "\<pi>\<^sub>2 testB poyo (False, Some True) = ''C''"
  by (simp add: resolve_store_poyo_expand)

lemma "\<pi>\<^sub>2 testB poyo (True, None) = ''D''"
  by (simp add: resolve_store_poyo_expand)

lemma "\<pi>\<^sub>2 testB poyo (True, Some False) = ''F''"
  by (simp add: resolve_store_poyo_expand)

lemma "\<pi>\<^sub>2 testB poyo (True, Some True) = ''B''"
  by (simp add: resolve_store_poyo_expand)

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Early_Cong
  imports Weak_Early_Bisim Weak_Early_Step_Sim Strong_Early_Bisim
begin

definition weakCongruence :: "pi \<Rightarrow> pi \<Rightarrow> bool" (infixr "\<simeq>" 65)
where "P \<simeq> Q \<equiv> P \<leadsto>\<guillemotleft>weakBisim\<guillemotright> Q \<and> Q \<leadsto>\<guillemotleft>weakBisim\<guillemotright> P"

lemma weakCongISym[consumes 1, case_names cSym cSim]:
  fixes P :: pi
  and   Q :: pi

  assumes "Prop P Q"
  and     "\<And>R S. Prop R S \<Longrightarrow> Prop S R"
  and     "\<And>R S. Prop R S \<Longrightarrow> (F R) \<leadsto>\<guillemotleft>weakBisim\<guillemotright> (F S)"

  shows "F P \<simeq> F Q"
using assms
by(auto simp add: weakCongruence_def)

lemma weakCongISym2[consumes 1, case_names cSim]:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq> Q"
  and     "\<And>R S. R \<simeq> S \<Longrightarrow> (F R) \<leadsto>\<guillemotleft>weakBisim\<guillemotright> (F S)"

  shows "F P \<simeq> F Q"
using assms
by(auto simp add: weakCongruence_def)

lemma weakCongEE:
  fixes P :: pi
  and   Q :: pi
  and   s :: "(name \<times> name) list"

  assumes "P \<simeq> Q"

  shows "P \<leadsto>\<guillemotleft>weakBisim\<guillemotright> Q"
  and   "Q \<leadsto>\<guillemotleft>weakBisim\<guillemotright> P"
using assms
by(auto simp add: weakCongruence_def)

lemma weakCongI:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<leadsto>\<guillemotleft>weakBisim\<guillemotright> Q"
  and     "Q \<leadsto>\<guillemotleft>weakBisim\<guillemotright> P"

  shows "P \<simeq> Q"
using assms
by(auto simp add: weakCongruence_def)

lemma eqvtI[eqvt]:
  fixes P :: pi
  and   Q :: pi
  and   p :: "name prm"

  assumes "P \<simeq> Q"

  shows "(p \<bullet> P) \<simeq> (p \<bullet> Q)"
using assms
by(auto simp add: weakCongruence_def intro: eqvtI)

lemma strongBisimWeakCong:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<sim> Q"

  shows "P \<simeq> Q"
proof -
  have "\<And>P Q. P \<leadsto>[bisim] Q \<Longrightarrow> P \<leadsto>\<guillemotleft>weakBisim\<guillemotright> Q"
  proof -
    fix P Q
    assume "P \<leadsto>[bisim] Q"
    hence "P \<leadsto>\<guillemotleft>bisim\<guillemotright> Q" by(rule Weak_Early_Step_Sim.strongSimWeakSim)
    moreover have "bisim \<subseteq> weakBisim"
      by(auto intro: strongBisimWeakBisim)
    ultimately show "P \<leadsto>\<guillemotleft>weakBisim\<guillemotright> Q" by(rule Weak_Early_Step_Sim.monotonic)
  qed
  with assms show ?thesis
    by(blast intro: weakCongI dest: Strong_Early_Bisim.bisimE)
qed

lemma congruenceWeakBisim:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq> Q"

  shows "P \<approx> Q"
using assms
proof -
  let ?X = "{(P, Q) | P Q. P \<simeq> Q}"
  from assms have "(P, Q) \<in> ?X" by simp
  thus ?thesis
  proof(induct rule: weakBisimCoinduct)
    case(cSim P Q)
    {
      fix P Q
      assume "P \<simeq> Q"
      hence "P \<leadsto>\<guillemotleft>weakBisim\<guillemotright> Q" by(simp add: weakCongruence_def)
      hence "P \<leadsto>\<guillemotleft>(?X \<union> weakBisim)\<guillemotright> Q" by(rule_tac Weak_Early_Step_Sim.monotonic) auto
      hence "P \<leadsto><(?X \<union> weakBisim)> Q" by(rule weakSimWeakEqSim)
    }
    with \<open>(P, Q) \<in> ?X\<close> show ?case by auto
  next
    case(cSym P Q)
    thus ?case by(auto simp add: weakCongruence_def)
  qed
qed

lemma reflexive:
  fixes P :: pi

  shows "P \<simeq> P"
proof -
  from Weak_Early_Bisim.reflexive have "\<And>P. P \<leadsto>\<guillemotleft>weakBisim\<guillemotright> P"
    by(blast intro: Weak_Early_Step_Sim.reflexive)
  thus ?thesis
    by(force simp add: substClosed_def weakCongruence_def)
qed

lemma symetric:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<simeq> Q"

  shows "Q \<simeq> P"
using assms
by(force simp add: substClosed_def weakCongruence_def)

end


(*  Title:      HOL/MicroJava/BV/JVM.thy

    Author:     Gerwin Klein
    Copyright   2000 TUM

*)

section \<open>The JVM Type System as Semilattice\<close>

theory JVM_SemiType imports SemiType begin

type_synonym ty\<^sub>l = "ty err list"
type_synonym ty\<^sub>s = "ty list"
type_synonym ty\<^sub>i = "ty\<^sub>s \<times> ty\<^sub>l"
type_synonym ty\<^sub>i' = "ty\<^sub>i option"
type_synonym ty\<^sub>m = "ty\<^sub>i' list"
type_synonym ty\<^sub>P = "mname \<Rightarrow> cname \<Rightarrow> ty\<^sub>m"

definition stk_esl :: "'c prog \<Rightarrow> nat \<Rightarrow> ty\<^sub>s esl"
where
  "stk_esl P mxs \<equiv> upto_esl mxs (SemiType.esl P)"

definition loc_sl :: "'c prog \<Rightarrow> nat \<Rightarrow> ty\<^sub>l sl"
where
  "loc_sl P mxl \<equiv> Listn.sl mxl (Err.sl (SemiType.esl P))"

definition sl :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty\<^sub>i' err sl"
where
  "sl P mxs mxl \<equiv>
  Err.sl(Opt.esl(Product.esl (stk_esl P mxs) (Err.esl(loc_sl P mxl))))"

definition states :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty\<^sub>i' err set"
where "states P mxs mxl \<equiv> fst(sl P mxs mxl)"

definition le :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty\<^sub>i' err ord"
where
  "le P mxs mxl \<equiv> fst(snd(sl P mxs mxl))"

definition sup :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty\<^sub>i' err binop"
where
  "sup P mxs mxl \<equiv> snd(snd(sl P mxs mxl))"

definition sup_ty_opt :: "['c prog,ty err,ty err] \<Rightarrow> bool"
    ("_ \<turnstile> _ \<le>\<^sub>\<top> _" [71,71,71] 70)
where
  "sup_ty_opt P \<equiv> Err.le (subtype P)"

definition sup_state :: "['c prog,ty\<^sub>i,ty\<^sub>i] \<Rightarrow> bool"
    ("_ \<turnstile> _ \<le>\<^sub>i _" [71,71,71] 70)
where
  "sup_state P \<equiv> Product.le (Listn.le (subtype P)) (Listn.le (sup_ty_opt P))"

definition sup_state_opt :: "['c prog,ty\<^sub>i',ty\<^sub>i'] \<Rightarrow> bool"
    ("_ \<turnstile> _ \<le>'' _" [71,71,71] 70)
where
  "sup_state_opt P \<equiv> Opt.le (sup_state P)"

abbreviation
  sup_loc :: "['c prog,ty\<^sub>l,ty\<^sub>l] \<Rightarrow> bool"  ("_ \<turnstile> _ [\<le>\<^sub>\<top>] _"  [71,71,71] 70)
  where "P \<turnstile> LT [\<le>\<^sub>\<top>] LT' \<equiv> list_all2 (sup_ty_opt P) LT LT'"

notation (ASCII)
  sup_ty_opt  ("_ |- _ <=T _" [71,71,71] 70) and
  sup_state  ("_ |- _ <=i _"  [71,71,71] 70) and
  sup_state_opt  ("_ |- _ <=' _"  [71,71,71] 70) and
  sup_loc  ("_ |- _ [<=T] _"  [71,71,71] 70)

subsection "Unfolding"

lemma JVM_states_unfold:
  "states P mxs mxl \<equiv> err(opt((Union {list n (types P) |n. n <= mxs}) \<times>
                                 list mxl (err(types P))))"
(*<*)
  apply (unfold states_def sl_def Opt.esl_def Err.sl_def
         stk_esl_def loc_sl_def Product.esl_def
         Listn.sl_def upto_esl_def SemiType.esl_def Err.esl_def)
  apply simp
  done
(*>*)

lemma JVM_le_unfold:
 "le P m n \<equiv>
  Err.le(Opt.le(Product.le(Listn.le(subtype P))(Listn.le(Err.le(subtype P)))))"
(*<*)
  apply (unfold le_def sl_def Opt.esl_def Err.sl_def
         stk_esl_def loc_sl_def Product.esl_def
         Listn.sl_def upto_esl_def SemiType.esl_def Err.esl_def)
  apply simp
  done
(*>*)

lemma sl_def2:
  "JVM_SemiType.sl P mxs mxl \<equiv>
  (states P mxs mxl, JVM_SemiType.le P mxs mxl, JVM_SemiType.sup P mxs mxl)"
(*<*) by (unfold JVM_SemiType.sup_def states_def JVM_SemiType.le_def) simp (*>*)

lemma JVM_le_conv:
  "le P m n (OK t1) (OK t2) = P \<turnstile> t1 \<le>' t2"
(*<*) by (simp add: JVM_le_unfold Err.le_def lesub_def sup_state_opt_def
                sup_state_def sup_ty_opt_def) (*>*)

lemma JVM_le_Err_conv:
  "le P m n = Err.le (sup_state_opt P)"
(*<*) by (unfold sup_state_opt_def sup_state_def
             sup_ty_opt_def JVM_le_unfold) simp (*>*)

lemma err_le_unfold [iff]:
  "Err.le r (OK a) (OK b) = r a b"
(*<*) by (simp add: Err.le_def lesub_def) (*>*)

subsection \<open>Semilattice\<close>

lemma order_sup_state_opt [intro, simp]:
  "wf_prog wf_mb P \<Longrightarrow> order (sup_state_opt P)"
(*<*) by (unfold sup_state_opt_def sup_state_def sup_ty_opt_def) blast (*>*)

lemma semilat_JVM [intro?]:
  "wf_prog wf_mb P \<Longrightarrow> semilat (JVM_SemiType.sl P mxs mxl)"
(*<*)
  apply (unfold JVM_SemiType.sl_def stk_esl_def loc_sl_def)
  apply (blast intro: err_semilat_Product_esl err_semilat_upto_esl
                      Listn_sl err_semilat_JType_esl)
  done
(*>*)

lemma acc_JVM [intro]:
  "wf_prog wf_mb P \<Longrightarrow> acc (JVM_SemiType.le P mxs mxl)"
(*<*) by (unfold JVM_le_unfold) blast (*>*)

subsection \<open>Widening with \<open>\<top>\<close>\<close>

lemma subtype_refl[iff]: "subtype P t t" (*<*) by (simp add: fun_of_def) (*>*)

lemma sup_ty_opt_refl [iff]: "P \<turnstile> T \<le>\<^sub>\<top> T"
(*<*)
  apply (unfold sup_ty_opt_def)
  apply (fold lesub_def)
  apply (rule le_err_refl)
  apply (simp add: lesub_def)
  done
(*>*)

lemma Err_any_conv [iff]: "P \<turnstile> Err \<le>\<^sub>\<top> T = (T = Err)"
(*<*) by (unfold sup_ty_opt_def) (rule Err_le_conv [simplified lesub_def]) (*>*)

lemma any_Err [iff]: "P \<turnstile> T \<le>\<^sub>\<top> Err"
(*<*) by (unfold sup_ty_opt_def) (rule le_Err [simplified lesub_def]) (*>*)

lemma OK_OK_conv [iff]:
  "P \<turnstile> OK T \<le>\<^sub>\<top> OK T' = P \<turnstile> T \<le> T'"
(*<*) by (simp add: sup_ty_opt_def fun_of_def) (*>*)

lemma any_OK_conv [iff]:
  "P \<turnstile> X \<le>\<^sub>\<top> OK T' = (\<exists>T. X = OK T \<and> P \<turnstile> T \<le> T')"
(*<*)
  apply (unfold sup_ty_opt_def)
  apply (rule le_OK_conv [simplified lesub_def])
  done
(*>*)

lemma OK_any_conv:
 "P \<turnstile> OK T \<le>\<^sub>\<top> X = (X = Err \<or> (\<exists>T'. X = OK T' \<and> P \<turnstile> T \<le> T'))"
(*<*)
  apply (unfold sup_ty_opt_def)
  apply (rule OK_le_conv [simplified lesub_def])
  done
(*>*)

lemma sup_ty_opt_trans [intro?, trans]:
  "\<lbrakk>P \<turnstile> a \<le>\<^sub>\<top> b; P \<turnstile> b \<le>\<^sub>\<top> c\<rbrakk> \<Longrightarrow> P \<turnstile> a \<le>\<^sub>\<top> c"
(*<*) by (auto intro: widen_trans
           simp add: sup_ty_opt_def Err.le_def lesub_def fun_of_def
           split: err.splits) (*>*)

subsection "Stack and Registers"

lemma stk_convert:
  "P \<turnstile> ST [\<le>] ST' = Listn.le (subtype P) ST ST'"
(*<*) by (simp add: Listn.le_def lesub_def) (*>*)

lemma sup_loc_refl [iff]: "P \<turnstile> LT [\<le>\<^sub>\<top>] LT"
(*<*) by (rule list_all2_refl) simp (*>*)

lemmas sup_loc_Cons1 [iff] = list_all2_Cons1 [of "sup_ty_opt P"] for P

lemma sup_loc_def:
  "P \<turnstile> LT [\<le>\<^sub>\<top>] LT' \<equiv> Listn.le (sup_ty_opt P) LT LT'"
(*<*) by (simp add: Listn.le_def lesub_def) (*>*)

lemma sup_loc_widens_conv [iff]:
  "P \<turnstile> map OK Ts [\<le>\<^sub>\<top>] map OK Ts' = P \<turnstile> Ts [\<le>] Ts'"
(*<*)
  by (simp add: list_all2_map1 list_all2_map2)
(*>*)

lemma sup_loc_trans [intro?, trans]:
  "\<lbrakk>P \<turnstile> a [\<le>\<^sub>\<top>] b; P \<turnstile> b [\<le>\<^sub>\<top>] c\<rbrakk> \<Longrightarrow> P \<turnstile> a [\<le>\<^sub>\<top>] c"
(*<*) by (rule list_all2_trans, rule sup_ty_opt_trans) (*>*)

subsection "State Type"

lemma sup_state_conv [iff]:
  "P \<turnstile> (ST,LT) \<le>\<^sub>i (ST',LT') = (P \<turnstile> ST [\<le>] ST' \<and> P \<turnstile> LT [\<le>\<^sub>\<top>] LT')"
(*<*) by (auto simp add: sup_state_def stk_convert lesub_def Product.le_def sup_loc_def) (*>*)

lemma sup_state_conv2:
  "P \<turnstile> s1 \<le>\<^sub>i s2 = (P \<turnstile> fst s1 [\<le>] fst s2 \<and> P \<turnstile> snd s1 [\<le>\<^sub>\<top>] snd s2)"
(*<*) by (cases s1, cases s2) simp (*>*)

lemma sup_state_refl [iff]: "P \<turnstile> s \<le>\<^sub>i s"
(*<*) by (auto simp add: sup_state_conv2) (*>*)

lemma sup_state_trans [intro?, trans]:
  "\<lbrakk>P \<turnstile> a \<le>\<^sub>i b; P \<turnstile> b \<le>\<^sub>i c\<rbrakk> \<Longrightarrow> P \<turnstile> a \<le>\<^sub>i c"
(*<*) by (auto intro: sup_loc_trans widens_trans simp add: sup_state_conv2) (*>*)

lemma sup_state_opt_None_any [iff]:
  "P \<turnstile> None \<le>' s"
(*<*) by (simp add: sup_state_opt_def Opt.le_def) (*>*)

lemma sup_state_opt_any_None [iff]:
  "P \<turnstile> s \<le>' None = (s = None)"
(*<*) by (simp add: sup_state_opt_def Opt.le_def) (*>*)

lemma sup_state_opt_Some_Some [iff]:
  "P \<turnstile> Some a \<le>' Some b = P \<turnstile> a \<le>\<^sub>i b"
(*<*) by (simp add: sup_state_opt_def Opt.le_def lesub_def) (*>*)

lemma sup_state_opt_any_Some:
  "P \<turnstile> (Some s) \<le>' X = (\<exists>s'. X = Some s' \<and> P \<turnstile> s \<le>\<^sub>i s')"
(*<*) by (simp add: sup_state_opt_def Opt.le_def lesub_def) (*>*)

lemma sup_state_opt_refl [iff]: "P \<turnstile> s \<le>' s"
(*<*) by (simp add: sup_state_opt_def Opt.le_def lesub_def) (*>*)

lemma sup_state_opt_trans [intro?, trans]:
  "\<lbrakk>P \<turnstile> a \<le>' b; P \<turnstile> b \<le>' c\<rbrakk> \<Longrightarrow> P \<turnstile> a \<le>' c"
(*<*)
  apply (unfold sup_state_opt_def Opt.le_def lesub_def)
  apply (simp del: split_paired_All)
  apply (rule sup_state_trans, assumption+)
  done
(*>*)

end


section {* UTP variables *}

theory utp_var
  imports
  Deriv
  "~~/src/HOL/Library/Prefix_Order"
  "~~/src/HOL/Library/Char_ord"
  "~~/src/Tools/Adhoc_Overloading"
  "~~/src/HOL/Library/Monad_Syntax"
  "~~/src/HOL/Library/Countable"
  "~~/src/HOL/Eisbach/Eisbach"
  "../contrib/Complete_Lattice"
  "../contrib/Galois_Connection"
  "../optics/Lenses"
  "../utils/Profiling"
  "../utils/TotalRecall"
  "../utils/Pfun"
  "../utils/Ffun"
  "../utils/List_lexord_alt"
  "../utils/Monoid_extra"
  utp_parser_utils
begin

text {* We will overload the square order relation with refinement and also the lattice operators so
  we will turn off these notations. *}

purge_notation
  le (infixl "\<sqsubseteq>\<index>" 50) and
  asup ("\<Squnion>\<index>_" [90] 90) and
  ainf ("\<Sqinter>\<index>_" [90] 90) and
  join (infixl "\<squnion>\<index>" 65) and
  meet (infixl "\<sqinter>\<index>" 70)

text {* We hide HOL's built-in relation type since we will replace it with our own *}

hide_type rel
type_synonym 'a relation = "('a \<times> 'a) set"

declare fst_vwb_lens [simp]
declare snd_vwb_lens [simp]
(* declare lens_indep_left_comp [simp] *)
declare comp_vwb_lens [simp]
declare lens_indep_left_ext [simp]
declare lens_indep_right_ext [simp]

text {* This theory describes the foundational structure of UTP variables, upon which the rest
        of our model rests. We start by defining alphabets, which following~\cite{Feliachi2010,Feliachi2012}
        in this shallow model are simply represented as types, though by convention usually a record
        type where each field corresponds to a variable. *}

type_synonym '\<alpha> "alphabet"  = "'\<alpha>"

text {* UTP variables in this frame are simply modelled as lenses, where the view type
  @{typ "'a"} is the variable type, and the source type @{text "'\<alpha>"} is the state-space
  type. *}

type_synonym ('a, '\<alpha>) uvar = "('a, '\<alpha>) lens"

 text {* We also define some lifting functions for variables to create input and output variables.
        These simply lift the alphabet to a tuple type since relations will ultimately be defined
        to a tuple alphabet. *}

definition in_var :: "('a, '\<alpha>) uvar \<Rightarrow> ('a, '\<alpha> \<times> '\<beta>) uvar" where
[lens_defs]: "in_var x = x ;\<^sub>L fst\<^sub>L"

definition out_var :: "('a, '\<beta>) uvar \<Rightarrow> ('a, '\<alpha> \<times> '\<beta>) uvar" where
[lens_defs]: "out_var x = x ;\<^sub>L snd\<^sub>L"

definition pr_var :: "('a, '\<beta>) uvar \<Rightarrow> ('a, '\<beta>) uvar" where
[simp]: "pr_var x = x"

lemma in_var_semi_uvar [simp]:
  "mwb_lens x \<Longrightarrow> mwb_lens (in_var x)"
  by (simp add: comp_mwb_lens in_var_def)

lemma in_var_uvar [simp]:
  "vwb_lens x \<Longrightarrow> vwb_lens (in_var x)"
  by (simp add: in_var_def)

lemma out_var_semi_uvar [simp]:
  "mwb_lens x \<Longrightarrow> mwb_lens (out_var x)"
  by (simp add: comp_mwb_lens out_var_def)

lemma out_var_uvar [simp]:
  "vwb_lens x \<Longrightarrow> vwb_lens (out_var x)"
  by (simp add: out_var_def)

lemma out_in_indep [simp]:
  "out_var x \<bowtie> in_var y"
  by (simp add: lens_indep_def in_var_def out_var_def fst_lens_def snd_lens_def lens_comp_def)

lemma in_var_indep [simp]:
  "x \<bowtie> y \<Longrightarrow> in_var x \<bowtie> in_var y"
  by (simp add: in_var_def out_var_def)

lemma out_var_indep [simp]:
  "x \<bowtie> y \<Longrightarrow> out_var x \<bowtie> out_var y"
  by (simp add: out_var_def)

lemma prod_lens_indep_in_var [simp]:
  "a \<bowtie> x \<Longrightarrow> a \<times>\<^sub>L b \<bowtie> in_var x"
  by (metis in_var_def in_var_indep out_in_indep out_var_def plus_pres_lens_indep prod_as_plus)

lemma prod_lens_indep_out_var [simp]:
  "b \<bowtie> x \<Longrightarrow> a \<times>\<^sub>L b \<bowtie> out_var x"
  by (metis in_out_indep in_var_def out_var_def out_var_indep plus_pres_lens_indep prod_as_plus)

text {* We also define some lookup abstraction simplifications. *}

lemma var_lookup_in [simp]: "lens_get (in_var x) (A, A') = lens_get x A"
  by (simp add: in_var_def fst_lens_def lens_comp_def)

lemma var_lookup_out [simp]: "lens_get (out_var x) (A, A') = lens_get x A'"
  by (simp add: out_var_def snd_lens_def lens_comp_def)

lemma var_update_in [simp]: "lens_put (in_var x) (A, A') v = (lens_put x A v, A')"
  by (simp add: in_var_def fst_lens_def lens_comp_def)

lemma var_update_out [simp]: "lens_put (out_var x) (A, A') v = (A, lens_put x A' v)"
  by (simp add: out_var_def snd_lens_def lens_comp_def)

text {* Variables can also be used to effectively define sets of variables. Here we define the
        the universal alphabet ($\Sigma$) to be a variable with identity for both the lookup
        and update functions. Effectively this is just a function directly on the alphabet type. *}

abbreviation (input) univ_alpha :: "('\<alpha>, '\<alpha>) uvar" ("\<Sigma>") where
"univ_alpha \<equiv> 1\<^sub>L"

(*
  Nonterminals:
    svid: is an identifier soely used for variables
    svar: is a potentially decorated variable (but does not need to be?!)
    salpha: is to construct alphabets (variable sets). This can only be done
    through lense composition due to typing restrictions.
*)

nonterminal svid and svar and salpha

syntax
  "_salphaid"    :: "id \<Rightarrow> salpha" ("_" [998] 998)
  "_salphavar"   :: "svar \<Rightarrow> salpha" ("_" [998] 998)
  "_salphacomp"  :: "salpha \<Rightarrow> salpha \<Rightarrow> salpha" (infixr ";" 75)
  "_svid"        :: "id \<Rightarrow> svid" ("_" [999] 999)
  "_svid_alpha"  :: "svid" ("\<Sigma>")
  "_svid_empty"  :: "svid" ("\<emptyset>")
  "_svid_dot"    :: "svid \<Rightarrow> svid \<Rightarrow> svid" ("_:_" [999,998] 999)
  "_spvar"       :: "svid \<Rightarrow> svar" ("&_" [998] 998)
  "_sinvar"      :: "svid \<Rightarrow> svar" ("$_" [998] 998)
  "_soutvar"     :: "svid \<Rightarrow> svar" ("$_\<acute>" [998] 998)

(*
  The functions below turn a representation of a variable (type 'v) including
  its name and type. And 'e is typically some lense type. So the functions
  below bridge between then model/encoding of the variable and its interpretation
  as a lense in order to integrate it into the general lense-based framework.
  Overriding the below is all we need to make use of any kind of variables in
  terms of interfacing it with the system.
*)

consts
  svar :: "'v \<Rightarrow> 'e"
  ivar :: "'v \<Rightarrow> 'e"
  ovar :: "'v \<Rightarrow> 'e"

adhoc_overloading
  svar pr_var and ivar in_var and ovar out_var

translations
  "_salphaid x" => "x"
  "_salphacomp x y" => "x +\<^sub>L y"
  "_salphavar x" => "x"
  "_svid_alpha" == "\<Sigma>"
  "_svid_empty" == "0\<^sub>L"
  "_svid_dot x y" => "y ;\<^sub>L x"
  "_svid x" => "x"
  "_sinvar (_svid_dot x y)" <= "CONST ivar (CONST lens_comp y x)"
  "_soutvar (_svid_dot x y)" <= "CONST ovar (CONST lens_comp y x)"
  "_spvar x" == "CONST svar x"
  "_sinvar x" == "CONST ivar x"
  "_soutvar x" == "CONST ovar x"

text {* Syntactic function to construct a uvar type given a return type *}

syntax
  "_uvar_ty"      :: "type \<Rightarrow> type \<Rightarrow> type"

parse_translation {*
let
  fun uvar_ty_tr [ty] = Syntax.const @{type_syntax uvar} $ ty $ Syntax.const @{type_syntax dummy}
    | uvar_ty_tr ts = raise TERM ("uvar_ty_tr", ts);
in [(@{syntax_const "_uvar_ty"}, K uvar_ty_tr)] end
*}
end


header {* Stutter Invariance of next-free LTL Formula *}
theory LTL_Stutter
imports LTL "../Stuttering_Equivalence/PLTL"
begin
  text {* This theory builds on the AFP-entry by Stephan Merz *}

  text {* Get rid of overlapping notation *}
  no_notation PLTL.holds_of ("_ \<Turnstile> _" [70,70] 40)

  hide_const (open) PLTL.false PLTL.atom PLTL.implies PLTL.next PLTL.until
  hide_const (open) PLTL.not PLTL.true PLTL.or PLTL.and
  hide_const (open) PLTL.eventually PLTL.always

  no_notation Samplers.suffix ("_[_ ..]" [80, 15] 80)
  hide_const (open) Samplers.suffix
  hide_fact (open) Samplers.suffix_def

  lemma PLTL_suffix_cnv[simp]: "Samplers.suffix = (\<lambda>w i. suffix i w)"
    apply (intro ext)
    unfolding Samplers.suffix_def Words.suffix_def ..

  hide_const (open) PLTL.next_free

  primrec ltl_next_free :: "'a ltl \<Rightarrow> bool" where
    "ltl_next_free LTLTrue \<longleftrightarrow> True"
  | "ltl_next_free LTLFalse \<longleftrightarrow> True"
  | "ltl_next_free (LTLProp _) \<longleftrightarrow> True"
  | "ltl_next_free (LTLNeg \<phi>) \<longleftrightarrow> ltl_next_free \<phi>"
  | "ltl_next_free (LTLAnd \<phi> \<psi>) \<longleftrightarrow> ltl_next_free \<phi> \<and> ltl_next_free \<psi>"
  | "ltl_next_free (LTLOr \<phi> \<psi>) \<longleftrightarrow> ltl_next_free \<phi> \<and> ltl_next_free \<psi>"
  | "ltl_next_free (LTLNext _) \<longleftrightarrow> False"
  | "ltl_next_free (LTLUntil \<phi> \<psi>) \<longleftrightarrow> ltl_next_free \<phi> \<and> ltl_next_free \<psi>"
  | "ltl_next_free (LTLRelease \<phi> \<psi>) \<longleftrightarrow> ltl_next_free \<phi> \<and> ltl_next_free \<psi>"

  text {* Conversion between the two LTL formalizations *}

  primrec cnv :: "'a LTL.ltl \<Rightarrow> 'a set PLTL.pltl" where
    "cnv LTLTrue = PLTL.true"
  | "cnv LTLFalse = PLTL.false"
  | "cnv (LTLProp a) = PLTL.atom (op \<in> a)"
  | "cnv (LTLNeg \<phi>) = PLTL.not (cnv \<phi>)"
  | "cnv (LTLAnd \<phi> \<psi>) = PLTL.and (cnv \<phi>) (cnv \<psi>)"
  | "cnv (LTLOr \<phi> \<psi>) = PLTL.or (cnv \<phi>) (cnv \<psi>)"
  | "cnv (LTLNext \<phi>) = PLTL.next (cnv \<phi>)"
  | "cnv (LTLUntil \<phi> \<psi>) = PLTL.until (cnv \<phi>) (cnv \<psi>)"
  | "cnv (LTLRelease \<phi> \<psi>)
    = PLTL.not (PLTL.until (PLTL.not (cnv \<phi>)) (PLTL.not (cnv \<psi>)))"

  lemma PLTL_holds_of_cnv[simp]: "PLTL.holds_of r (cnv \<phi>) \<longleftrightarrow> ltl_semantics r \<phi>"
    by (induction \<phi> arbitrary: r) simp_all

  lemma PLTL_next_free_cnv[simp]: "PLTL.next_free (cnv \<phi>) \<longleftrightarrow> ltl_next_free \<phi>"
    by (induction \<phi>) auto

  theorem next_free_stutter_invariant:
    assumes next_free: "ltl_next_free \<phi>"
    assumes eq: "r \<approx> r'"
    shows "r \<Turnstile> \<phi> \<longleftrightarrow> r' \<Turnstile> \<phi>"
    -- {* A next free formula cannot distinguish between
      stutter-equivalent runs. *}
  proof -
    {
      fix r r'
      assume eq: "r \<approx> r'" and holds: "r \<Turnstile> \<phi>"
      hence "holds_of r (cnv \<phi>)" by simp

      from next_free_stutter_invariant[of "cnv \<phi>"] next_free
      have "PLTL.stutter_invariant (cnv \<phi>)" by simp
      from stutter_invariantD[OF this eq] holds have "r' \<Turnstile> \<phi>" by simp
    } note aux=this

    from aux[of r r'] aux[of r' r] eq stutter_equiv_sym[OF eq] show ?thesis
      by blast
  qed

end


subsection \<open>IMO 2006 SL - A3\<close>

theory IMO_2006_SL_A3
  imports Complex_Main

begin

theorem IMO_2006_SL_A3:
  fixes c :: "nat \<Rightarrow> nat"
   and  S :: "(nat \<times> nat) set"
  assumes "c 0 = 1" "c 1 = 0" "\<forall> n \<ge> 0. c (n + 2) = c (n + 1) + c n" and
    "\<forall> (x, y) \<in> S. \<exists> J :: nat set. (\<forall> j \<in> J. j > 0) \<and>
    x = (\<Sum>j\<in>J. c j) \<and> y = (\<Sum>j\<in>J. c (j-1))"
  shows "\<exists> \<alpha> \<beta> m M :: real. (x,y) \<in> S \<longleftrightarrow> (m < \<alpha> * x + \<beta> * y \<and> \<alpha> * x + \<beta> * y  < M)"
  sorry

end


theory prop_19
imports Main
        "../../TestTheories/Listi"
        "../../TestTheories/Naturals"
        "$HIPSTER_HOME/IsaHipster"

begin

theorem notEmptyDrop: "leq (S n) (len ts) \<Longrightarrow> (drop n ts) \<noteq> Nil"
by (hipster_induct_schemes leq.simps len.simps)

end


(*  Title:      HOL/MicroJava/BV/LBVSpec.thy
    Author:     Gerwin Klein
    Copyright   1999 Technische Universitaet Muenchen
*)

header {* \isaheader{The Lightweight Bytecode Verifier} *}

theory LBVSpec
imports SemilatAlg Opt
begin

type_synonym
  's certificate = "'s list"

primrec merge :: "'s certificate \<Rightarrow> 's binop \<Rightarrow> 's ord \<Rightarrow> 's \<Rightarrow> nat \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's \<Rightarrow> 's"
where
  "merge cert f r T pc []     x = x"
| "merge cert f r T pc (s#ss) x = merge cert f r T pc ss (let (pc',s') = s in
                                  if pc'=pc+1 then s' \<squnion>\<^sub>f x
                                  else if s' \<sqsubseteq>\<^sub>r cert!pc' then x
                                  else T)"

definition wtl_inst :: "'s certificate \<Rightarrow> 's binop \<Rightarrow> 's ord \<Rightarrow> 's \<Rightarrow>
              's step_type \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> 's"
where
  "wtl_inst cert f r T step pc s = merge cert f r T pc (step pc s) (cert!(pc+1))"

definition wtl_cert :: "'s certificate \<Rightarrow> 's binop \<Rightarrow> 's ord \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow>
              's step_type \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> 's"
where
  "wtl_cert cert f r T B step pc s =
  (if cert!pc = B then
    wtl_inst cert f r T step pc s
  else
    if s \<sqsubseteq>\<^sub>r cert!pc then wtl_inst cert f r T step pc (cert!pc) else T)"

primrec wtl_inst_list :: "'a list \<Rightarrow> 's certificate \<Rightarrow> 's binop \<Rightarrow> 's ord \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow>
                    's step_type \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> 's"
where
  "wtl_inst_list []     cert f r T B step pc s = s"
| "wtl_inst_list (i#is) cert f r T B step pc s =
    (let s' = wtl_cert cert f r T B step pc s in
      if s' = T \<or> s = T then T else wtl_inst_list is cert f r T B step (pc+1) s')"

definition cert_ok :: "'s certificate \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow> 's set \<Rightarrow> bool"
where
  "cert_ok cert n T B A \<longleftrightarrow> (\<forall>i < n. cert!i \<in> A \<and> cert!i \<noteq> T) \<and> (cert!n = B)"

definition bottom :: "'a ord \<Rightarrow> 'a \<Rightarrow> bool"
where
  "bottom r B \<longleftrightarrow> (\<forall>x. B \<sqsubseteq>\<^sub>r x)"

locale lbv = Semilat +
  fixes T :: "'a" ("\<top>")
  fixes B :: "'a" ("\<bottom>")
  fixes step :: "'a step_type"
  assumes top: "top r \<top>"
  assumes T_A: "\<top> \<in> A"
  assumes bot: "bottom r \<bottom>"
  assumes B_A: "\<bottom> \<in> A"

  fixes merge :: "'a certificate \<Rightarrow> nat \<Rightarrow> (nat \<times> 'a) list \<Rightarrow> 'a \<Rightarrow> 'a"
  defines mrg_def: "merge cert \<equiv> LBVSpec.merge cert f r \<top>"

  fixes wti :: "'a certificate \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
  defines wti_def: "wti cert \<equiv> wtl_inst cert f r \<top> step"

  fixes wtc :: "'a certificate \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
  defines wtc_def: "wtc cert \<equiv> wtl_cert cert f r \<top> \<bottom> step"

  fixes wtl :: "'b list \<Rightarrow> 'a certificate \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
  defines wtl_def: "wtl ins cert \<equiv> wtl_inst_list ins cert f r \<top> \<bottom> step"

lemma (in lbv) wti:
  "wti c pc s = merge c pc (step pc s) (c!(pc+1))"
  (*<*) by (simp add: wti_def mrg_def wtl_inst_def) (*>*)

lemma (in lbv) wtc:
  "wtc c pc s = (if c!pc = \<bottom> then wti c pc s else if s \<sqsubseteq>\<^sub>r c!pc then wti c pc (c!pc) else \<top>)"
  (*<*) by (unfold wtc_def wti_def wtl_cert_def) rule (*>*)

lemma cert_okD1 [intro?]:
  "cert_ok c n T B A \<Longrightarrow> pc < n \<Longrightarrow> c!pc \<in> A"
  (*<*) by (unfold cert_ok_def) fast (*>*)

lemma cert_okD2 [intro?]:
  "cert_ok c n T B A \<Longrightarrow> c!n = B"
  (*<*) by (simp add: cert_ok_def) (*>*)

lemma cert_okD3 [intro?]:
  "cert_ok c n T B A \<Longrightarrow> B \<in> A \<Longrightarrow> pc < n \<Longrightarrow> c!Suc pc \<in> A"
  (*<*) by (drule Suc_leI) (auto simp add: le_eq_less_or_eq dest: cert_okD1 cert_okD2) (*>*)

declare Let_def [simp]

section "more semilattice lemmas"

lemma (in lbv) sup_top [simp, elim]:
  assumes x: "x \<in> A"
  shows "x \<squnion>\<^sub>f \<top> = \<top>"
(*<*)
proof -
  from top have "x \<squnion>\<^sub>f \<top> \<sqsubseteq>\<^sub>r \<top>" ..
  moreover from x T_A have "\<top> \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f \<top>" ..
  ultimately show ?thesis ..
qed
(*>*)

lemma (in lbv) plusplussup_top [simp, elim]:
  "set xs \<subseteq> A \<Longrightarrow> xs \<Squnion>\<^bsub>f\<^esub> \<top> = \<top>"
  by (induct xs) auto

lemma (in Semilat) pp_ub1':
  assumes S: "snd`set S \<subseteq> A"
  assumes y: "y \<in> A" and ab: "(a, b) \<in> set S"
  shows "b \<sqsubseteq>\<^sub>r map snd [(p', t') \<leftarrow> S . p' = a] \<Squnion>\<^bsub>f\<^esub> y"
(*<*)
proof -
  from S have "\<forall>(x,y) \<in> set S. y \<in> A" by auto
  with Semilat_axioms show ?thesis using y ab by (rule ub1')
qed
(*>*)

lemma (in lbv) bottom_le [simp, intro!]: "\<bottom> \<sqsubseteq>\<^sub>r x"
  by (insert bot) (simp add: bottom_def)

lemma (in lbv) le_bottom [simp]: "x \<sqsubseteq>\<^sub>r \<bottom> = (x = \<bottom>)"
  by (blast intro: antisym_r)

section "merge"

lemma (in lbv) merge_Nil [simp]:
  "merge c pc [] x = x" by (simp add: mrg_def)

lemma (in lbv) merge_Cons [simp]:
  "merge c pc (l#ls) x = merge c pc ls (if fst l=pc+1 then snd l +_f x
                                        else if snd l \<sqsubseteq>\<^sub>r c!fst l then x
                                        else \<top>)"
  by (simp add: mrg_def split_beta)

lemma (in lbv) merge_Err [simp]:
  "snd`set ss \<subseteq> A \<Longrightarrow> merge c pc ss \<top> = \<top>"
  by (induct ss) auto

lemma (in lbv) merge_not_top:
  "\<And>x. snd`set ss \<subseteq> A \<Longrightarrow> merge c pc ss x \<noteq> \<top> \<Longrightarrow>
  \<forall>(pc',s') \<in> set ss. (pc' \<noteq> pc+1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc')"
  (is "\<And>x. ?set ss \<Longrightarrow> ?merge ss x \<Longrightarrow> ?P ss")
(*<*)
proof (induct ss)
  show "?P []" by simp
next
  fix x ls l
  assume "?set (l#ls)" then obtain set: "snd`set ls \<subseteq> A" by simp
  assume merge: "?merge (l#ls) x"
  moreover
  obtain pc' s' where [simp]: "l = (pc',s')" by (cases l)
  ultimately
  obtain x' where merge': "?merge ls x'" by simp
  assume "\<And>x. ?set ls \<Longrightarrow> ?merge ls x \<Longrightarrow> ?P ls" hence "?P ls" using set merge' .
  moreover
  from merge set
  have "pc' \<noteq> pc+1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc'" by (simp split: split_if_asm)
  ultimately show "?P (l#ls)" by simp
qed
(*>*)

lemma (in lbv) merge_def:
  shows
  "\<And>x. x \<in> A \<Longrightarrow> snd`set ss \<subseteq> A \<Longrightarrow>
  merge c pc ss x =
  (if \<forall>(pc',s') \<in> set ss. pc'\<noteq>pc+1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc' then
    map snd [(p',t') \<leftarrow> ss. p'=pc+1] \<Squnion>\<^bsub>f\<^esub> x
  else \<top>)"
  (is "\<And>x. _ \<Longrightarrow> _ \<Longrightarrow> ?merge ss x = ?if ss x" is "\<And>x. _ \<Longrightarrow> _ \<Longrightarrow> ?P ss x")
(*<*)
proof (induct ss)
  fix x show "?P [] x" by simp
next
  fix x assume x: "x \<in> A"
  fix l::"nat \<times> 'a" and ls
  assume "snd`set (l#ls) \<subseteq> A"
  then obtain l: "snd l \<in> A" and ls: "snd`set ls \<subseteq> A" by auto
  assume "\<And>x. x \<in> A \<Longrightarrow> snd`set ls \<subseteq> A \<Longrightarrow> ?P ls x"
  hence IH: "\<And>x. x \<in> A \<Longrightarrow> ?P ls x" using ls by iprover
  obtain pc' s' where [simp]: "l = (pc',s')" by (cases l)
  hence "?merge (l#ls) x = ?merge ls
    (if pc'=pc+1 then s' \<squnion>\<^sub>f x else if s' \<sqsubseteq>\<^sub>r c!pc' then x else \<top>)"
    (is "?merge (l#ls) x = ?merge ls ?if'")
    by simp
  also have "\<dots> = ?if ls ?if'"
  proof -
    from l have "s' \<in> A" by simp
    with x have "s' \<squnion>\<^sub>f x \<in> A" by simp
    with x T_A have "?if' \<in> A" by auto
    hence "?P ls ?if'" by (rule IH) thus ?thesis by simp
  qed
  also have "\<dots> = ?if (l#ls) x"
    proof (cases "\<forall>(pc', s')\<in>set (l#ls). pc'\<noteq>pc+1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc'")
      case True
      hence "\<forall>(pc', s')\<in>set ls. pc'\<noteq>pc+1 \<longrightarrow> s' \<sqsubseteq>\<^sub>r c!pc'" by auto
      moreover
      from True have
        "map snd [(p',t') \<leftarrow> ls . p'=pc+1] \<Squnion>\<^bsub>f\<^esub> ?if' =
        (map snd [(p',t') \<leftarrow> l#ls . p'=pc+1] \<Squnion>\<^bsub>f\<^esub> x)"
        by simp
      ultimately
      show ?thesis using True by simp
    next
      case False
      moreover
      from ls have "set (map snd [(p', t') \<leftarrow> ls . p' = Suc pc]) \<subseteq> A" by auto
      ultimately show ?thesis by auto
    qed
  finally show "?P (l#ls) x" .
qed
(*>*)

lemma (in lbv) merge_not_top_s:
  assumes x:  "x \<in> A" and ss: "snd`set ss \<subseteq> A"
  assumes m:  "merge c pc ss x \<noteq> \<top>"
  shows "merge c pc ss x = (map snd [(p',t') \<leftarrow> ss. p'=pc+1] \<Squnion>\<^bsub>f\<^esub> x)"
(*<*)
proof -
  from ss m have "\<forall>(pc',s') \<in> set ss. (pc' \<noteq> pc+1 \<longrightarrow> s' <=_r c!pc')"
    by (rule merge_not_top)
  with x ss m show ?thesis by - (drule merge_def, auto split: split_if_asm)
qed
(*>*)

section "wtl-inst-list"

lemmas [iff] = not_Err_eq

lemma (in lbv) wtl_Nil [simp]: "wtl [] c pc s = s"
  by (simp add: wtl_def)

lemma (in lbv) wtl_Cons [simp]:
  "wtl (i#is) c pc s =
  (let s' = wtc c pc s in if s' = \<top> \<or> s = \<top> then \<top> else wtl is c (pc+1) s')"
  by (simp add: wtl_def wtc_def)

lemma (in lbv) wtl_Cons_not_top:
  "wtl (i#is) c pc s \<noteq> \<top> =
  (wtc c pc s \<noteq> \<top> \<and> s \<noteq> T \<and> wtl is c (pc+1) (wtc c pc s) \<noteq> \<top>)"
  by (auto simp del: split_paired_Ex)

lemma (in lbv) wtl_top [simp]:  "wtl ls c pc \<top> = \<top>"
  by (cases ls) auto

lemma (in lbv) wtl_not_top:
  "wtl ls c pc s \<noteq> \<top> \<Longrightarrow> s \<noteq> \<top>"
  by (cases "s=\<top>") auto

lemma (in lbv) wtl_append [simp]:
  "\<And>pc s. wtl (a@b) c pc s = wtl b c (pc+length a) (wtl a c pc s)"
  by (induct a) auto

lemma (in lbv) wtl_take:
  "wtl is c pc s \<noteq> \<top> \<Longrightarrow> wtl (take pc' is) c pc s \<noteq> \<top>"
  (is "?wtl is \<noteq> _ \<Longrightarrow> _")
(*<*)
proof -
  assume "?wtl is \<noteq> \<top>"
  hence "?wtl (take pc' is @ drop pc' is) \<noteq> \<top>" by simp
  thus ?thesis by (auto dest!: wtl_not_top simp del: append_take_drop_id)
qed
(*>*)

lemma take_Suc:
  "\<forall>n. n < length l \<longrightarrow> take (Suc n) l = (take n l)@[l!n]" (is "?P l")
(*<*)
proof (induct l)
  show "?P []" by simp
next
  fix x xs assume IH: "?P xs"
  show "?P (x#xs)"
  proof (intro strip)
    fix n assume "n < length (x#xs)"
    with IH show "take (Suc n) (x # xs) = take n (x # xs) @ [(x # xs) ! n]"
      by (cases n, auto)
  qed
qed
(*>*)

lemma (in lbv) wtl_Suc:
  assumes suc: "pc+1 < length is"
  assumes wtl: "wtl (take pc is) c 0 s \<noteq> \<top>"
  shows "wtl (take (pc+1) is) c 0 s = wtc c pc (wtl (take pc is) c 0 s)"
(*<*)
proof -
  from suc have "take (pc+1) is=(take pc is)@[is!pc]" by (simp add: take_Suc)
  with suc wtl show ?thesis by (simp add: min_def)
qed
(*>*)

lemma (in lbv) wtl_all:
  assumes all: "wtl is c 0 s \<noteq> \<top>" (is "?wtl is \<noteq> _")
  assumes pc:  "pc < length is"
  shows  "wtc c pc (wtl (take pc is) c 0 s) \<noteq> \<top>"
(*<*)
proof -
  from pc have "0 < length (drop pc is)" by simp
  then  obtain i r where Cons: "drop pc is = i#r"
    by (auto simp add: neq_Nil_conv simp del: length_drop drop_eq_Nil)
  hence "i#r = drop pc is" ..
  with all have take: "?wtl (take pc is@i#r) \<noteq> \<top>" by simp
  from pc have "is!pc = drop pc is ! 0" by simp
  with Cons have "is!pc = i" by simp
  with take pc show ?thesis by (auto simp add: min_def split: split_if_asm)
qed
(*>*)

section "preserves-type"

lemma (in lbv) merge_pres:
  assumes s0: "snd`set ss \<subseteq> A" and x: "x \<in> A"
  shows "merge c pc ss x \<in> A"
(*<*)
proof -
  from s0 have "set (map snd [(p', t') \<leftarrow> ss . p'=pc+1]) \<subseteq> A" by auto
  with x semilat Semilat_axioms  have "(map snd [(p', t') \<leftarrow> ss . p'=pc+1] \<Squnion>\<^bsub>f\<^esub> x) \<in> A"
    by (auto intro!: plusplus_closed)
  with s0 x show ?thesis by (simp add: merge_def T_A)
qed
(*>*)

lemma pres_typeD2:
  "pres_type step n A \<Longrightarrow> s \<in> A \<Longrightarrow> p < n \<Longrightarrow> snd`set (step p s) \<subseteq> A"
  by auto (drule pres_typeD)

lemma (in lbv) wti_pres [intro?]:
  assumes pres: "pres_type step n A"
  assumes cert: "c!(pc+1) \<in> A"
  assumes s_pc: "s \<in> A" "pc < n"
  shows "wti c pc s \<in> A"
(*<*)
proof -
  from pres s_pc have "snd`set (step pc s) \<subseteq> A" by (rule pres_typeD2)
  with cert show ?thesis by (simp add: wti merge_pres)
qed
(*>*)

lemma (in lbv) wtc_pres:
  assumes "pres_type step n A"
  assumes "c!pc \<in> A" and "c!(pc+1) \<in> A"
  assumes "s \<in> A" and "pc < n"
  shows "wtc c pc s \<in> A"
(*<*)
proof -
  have "wti c pc s \<in> A" using assms(1,3-5) ..
  moreover have "wti c pc (c!pc) \<in> A" using assms(1,3,2,5) ..
  ultimately show ?thesis using T_A by (simp add: wtc)
qed
(*>*)

lemma (in lbv) wtl_pres:
  assumes pres: "pres_type step (length is) A"
  assumes cert: "cert_ok c (length is) \<top> \<bottom> A"
  assumes s:    "s \<in> A"
  assumes all:  "wtl is c 0 s \<noteq> \<top>"
  shows "pc < length is \<Longrightarrow> wtl (take pc is) c 0 s \<in> A"
  (is "?len pc \<Longrightarrow> ?wtl pc \<in> A")
(*<*)
proof (induct pc)
  from s show "?wtl 0 \<in> A" by simp
next
  fix n assume Suc_n: "Suc n < length is"
  hence n1: "n+1 < length is" by simp
  then obtain n: "n < length is" by simp
  assume "n < length is \<Longrightarrow> ?wtl n \<in> A"
  hence "?wtl n \<in> A" using n .
  from pres _ _ this n
  have "wtc c n (?wtl n) \<in> A"
  proof (rule wtc_pres)
    from cert n show "c!n \<in> A" by (rule cert_okD1)
    from cert n1 show "c!(n+1) \<in> A" by (rule cert_okD1)
  qed
  also
  from all n have "?wtl n \<noteq> \<top>" by - (rule wtl_take)
  with n1 have "wtc c n (?wtl n) = ?wtl (n+1)" by (rule wtl_Suc [symmetric])
  finally  show "?wtl (Suc n) \<in> A" by simp
qed
(*>*)

end


theory Check
  imports Submission
begin

lemma bound_decr: "while_free c \<Longrightarrow> (c, s) \<rightarrow> (c', s') \<Longrightarrow> bound c' < bound c"
  by (rule Submission.bound_decr)

end


theory Myhill_Nerode
  imports Tree_Automata Ground_Ctxt
begin

subsection \<open>Myhill Nerode characterization for regular tree languages\<close>

lemma ground_ctxt_apply_pres_der:
  assumes "ta_der \<A> (term_of_gterm s) = ta_der \<A> (term_of_gterm t)"
  shows "ta_der \<A> (term_of_gterm C\<langle>s\<rangle>\<^sub>G) = ta_der \<A> (term_of_gterm C\<langle>t\<rangle>\<^sub>G)" using assms
  by (induct C) (auto, (metis append_Cons_nth_not_middle nth_append_length)+)

locale myhill_nerode =
  fixes \<F> \<L> assumes term_subset: "\<L> \<subseteq> \<T>\<^sub>G \<F>"
begin

definition myhill ("_ \<equiv>\<^sub>\<L> _") where
  "myhill s t \<equiv> s \<in> \<T>\<^sub>G \<F> \<and> t \<in> \<T>\<^sub>G \<F> \<and> (\<forall> C. C\<langle>s\<rangle>\<^sub>G \<in> \<L> \<and> C\<langle>t\<rangle>\<^sub>G \<in> \<L> \<or> C\<langle>s\<rangle>\<^sub>G \<notin> \<L> \<and> C\<langle>t\<rangle>\<^sub>G \<notin> \<L>)"

lemma myhill_sound: "s \<equiv>\<^sub>\<L> t \<Longrightarrow> s \<in> \<T>\<^sub>G \<F>"  "s \<equiv>\<^sub>\<L> t \<Longrightarrow> t \<in> \<T>\<^sub>G \<F>"
  unfolding myhill_def by auto

lemma myhill_refl [simp]: "s \<in> \<T>\<^sub>G \<F> \<Longrightarrow> s \<equiv>\<^sub>\<L> s"
  unfolding myhill_def by auto

lemma myhill_symmetric: "s \<equiv>\<^sub>\<L> t \<Longrightarrow> t \<equiv>\<^sub>\<L> s"
  unfolding myhill_def by auto

lemma myhill_trans [trans]:
  "s \<equiv>\<^sub>\<L> t \<Longrightarrow> t \<equiv>\<^sub>\<L> u \<Longrightarrow> s \<equiv>\<^sub>\<L> u"
  unfolding myhill_def by auto

abbreviation myhill_r ("MN\<^sub>\<L>") where
  "myhill_r \<equiv> {(s, t) | s t. s \<equiv>\<^sub>\<L> t}"

lemma myhill_equiv:
  "equiv (\<T>\<^sub>G \<F>) MN\<^sub>\<L>"
  apply (intro equivI) apply (auto simp: myhill_sound myhill_symmetric sym_def trans_def refl_on_def)
  using myhill_trans by blast

lemma rtl_der_image_on_myhill_inj:
  assumes "gta_lang Q\<^sub>f \<A> = \<L>"
  shows "inj_on (\<lambda> X. gta_der \<A> ` X) (\<T>\<^sub>G \<F> // MN\<^sub>\<L>)" (is "inj_on ?D ?R")
proof -
  {fix S T assume eq_rel: "S \<in> ?R" "T \<in> ?R" "?D S = ?D T"
    have "\<And> s t. s \<in> S \<Longrightarrow> t \<in> T \<Longrightarrow> s \<equiv>\<^sub>\<L> t"
    proof -
      fix s t assume mem: "s \<in> S" "t \<in> T"
      then obtain t' where res: "t' \<in> T" "gta_der \<A> s = gta_der \<A> t'" using eq_rel(3)
        by (metis image_iff)
      from res(1) mem have "s \<in> \<T>\<^sub>G \<F>" "t \<in> \<T>\<^sub>G \<F>" "t' \<in> \<T>\<^sub>G \<F>" using eq_rel(1, 2)
        using in_quotient_imp_subset myhill_equiv by blast+
      then have "s \<equiv>\<^sub>\<L> t'" using assms res ground_ctxt_apply_pres_der[of \<A> s]
        by (auto simp: myhill_def gta_der_def simp flip: ctxt_of_gctxt_apply
         elim!: gta_langE intro: gta_langI)
      moreover have "t' \<equiv>\<^sub>\<L> t" using quotient_eq_iff[OF myhill_equiv eq_rel(2) eq_rel(2) res(1) mem(2)]
        by simp
      ultimately show "s \<equiv>\<^sub>\<L> t" using myhill_trans by blast
    qed
    then have "\<And> s t. s \<in> S \<Longrightarrow> t \<in> T \<Longrightarrow> (s, t) \<in> MN\<^sub>\<L>" by blast
    then have "S = T" using quotient_eq_iff[OF myhill_equiv eq_rel(1, 2)]
      using eq_rel(3) by fastforce}
  then show inj: "inj_on ?D ?R" by (meson inj_onI)
qed

lemma rtl_implies_finite_indexed_myhill_relation:
  assumes "gta_lang Q\<^sub>f \<A> = \<L>"
  shows "finite (\<T>\<^sub>G \<F> // MN\<^sub>\<L>)" (is "finite ?R")
proof -
  let ?D = "\<lambda> X. gta_der \<A> ` X"
  have image: "?D ` ?R \<subseteq> Pow (fset (fPow (\<Q> \<A>)))" unfolding gta_der_def
    by (meson PowI fPowI ground_ta_der_states ground_term_of_gterm image_subsetI notin_fset)
  then have "finite (Pow (fset (fPow (\<Q> \<A>))))" by simp
  then have "finite (?D ` ?R)" using finite_subset[OF image] by fastforce
  then show ?thesis using finite_image_iff[OF rtl_der_image_on_myhill_inj[OF assms]]
    by blast
qed

end

end


(*<*)
theory LoweOntologicalArgument_2
imports QML
begin

nitpick_params[box=false, user_axioms=true, show_all, expect=genuine, format = 3,  atoms e = a b c d]
sledgehammer_params[verbose=true]

consts isActualized::"e\<Rightarrow>wo" (infix "actualizedAt" 70)

abbreviation forallAct::"(e\<Rightarrow>wo)\<Rightarrow>wo" ("\<^bold>\<forall>\<^sup>A")
  where "\<^bold>\<forall>\<^sup>A\<Phi> \<equiv> \<lambda>w.\<forall>x. (x actualizedAt w)\<longrightarrow>(\<Phi> x w)"
abbreviation existsAct::"(e\<Rightarrow>wo)\<Rightarrow>wo" ("\<^bold>\<exists>\<^sup>A")
  where "\<^bold>\<exists>\<^sup>A\<Phi> \<equiv> \<lambda>w.\<exists>x. (x actualizedAt w) \<and> (\<Phi> x w)"
abbreviation mforallActB::"(e\<Rightarrow>wo)\<Rightarrow>wo" (binder"\<^bold>\<forall>\<^sup>A"[8]9)
  where "\<^bold>\<forall>\<^sup>Ax. (\<phi> x) \<equiv> \<^bold>\<forall>\<^sup>A\<phi>"
abbreviation mexistsActB::"(e\<Rightarrow>wo)\<Rightarrow>wo" (binder"\<^bold>\<exists>\<^sup>A"[8]9)
  where "\<^bold>\<exists>\<^sup>Ax. (\<phi> x) \<equiv> \<^bold>\<exists>\<^sup>A\<phi>"

definition Existence::"e\<Rightarrow>wo" ("E!") where "E! x  \<equiv> \<^bold>\<exists>\<^sup>Ay. y\<^bold>\<approx>x"
definition Necessary::"e\<Rightarrow>wo" where "Necessary x \<equiv>  \<^bold>\<box>E! x"
definition Contingent::"e\<Rightarrow>wo" where "Contingent x \<equiv>  \<^bold>\<diamond>E! x \<^bold>\<and> \<^bold>\<not>(Necessary x)"

consts Concrete::"e\<Rightarrow>wo"
abbreviation Abstract::"e\<Rightarrow>wo" where "Abstract x \<equiv>  \<^bold>\<not>(Concrete x)"

abbreviation Godlike::"e\<Rightarrow>wo"  where "Godlike x \<equiv> Necessary x \<^bold>\<and> Concrete x"

consts dependence::"e\<Rightarrow>e\<Rightarrow>wo" (infix "dependsOn" 100)
definition Dependent::"e\<Rightarrow>wo" where "Dependent x \<equiv> \<^bold>\<exists>\<^sup>Ay. x dependsOn y"
abbreviation Independent::"e\<Rightarrow>wo" where "Independent x  \<equiv> \<^bold>\<not>(Dependent x)"

consts explanation::"e\<Rightarrow>e\<Rightarrow>wo" (infix "explains" 100)
definition Explained::"e\<Rightarrow>wo" where "Explained x \<equiv> \<^bold>\<exists>\<^sup>Ay. y explains x"

axiomatization where
  P2: "\<lfloor>\<^bold>\<exists>\<^sup>Ax. Necessary x \<^bold>\<and> Abstract x\<rfloor>" and
  P3: "\<lfloor>\<^bold>\<forall>\<^sup>Ax. Abstract x \<^bold>\<rightarrow> Dependent x\<rfloor>" and
  P4: "\<lfloor>\<^bold>\<forall>\<^sup>Ax. Dependent x \<^bold>\<rightarrow> (\<^bold>\<exists>\<^sup>Ay. Independent y \<^bold>\<and> x dependsOn y)\<rfloor>" and
  P5: "\<lfloor>\<^bold>\<not>(\<^bold>\<exists>\<^sup>Ax. \<^bold>\<exists>\<^sup>Ay. Contingent y \<^bold>\<and> Necessary x \<^bold>\<and> y explains x)\<rfloor>" and
  P6: "\<lfloor>\<^bold>\<forall>x. Dependent x \<^bold>\<rightarrow> Explained x\<rfloor>" and
  P7: "\<lfloor>\<^bold>\<forall>x. Dependent x \<^bold>\<rightarrow> \<^bold>\<not>(x explains x)\<rfloor>" and
  P8:  "\<lfloor>\<^bold>\<forall>x y. y explains x \<^bold>\<rightarrow> x dependsOn y\<rfloor>"

theorem C1:  "\<lfloor>\<^bold>\<forall>\<^sup>Ax. Abstract x \<^bold>\<rightarrow> (\<^bold>\<exists>y. Concrete y \<^bold>\<and> x dependsOn y)\<rfloor>"  using P3 P4 by blast
theorem C5: "\<lfloor>\<^bold>\<exists>\<^sup>Ax. Concrete x\<rfloor>" using P2 P3 P4 by blast
theorem C7: "\<lfloor>\<^bold>\<forall>\<^sup>Ax. (Necessary x \<^bold>\<and> Abstract x) \<^bold>\<rightarrow> Explained x\<rfloor>"  using P3 P6 by blast
theorem C10:  "\<lfloor>\<^bold>\<exists>\<^sup>Ax. Godlike x\<rfloor>" nitpick[user_axioms]  oops
(*>*)

subsection \<open>Validating the Argument I\<close>
text\<open>\noindent{By examining the countermodel found by Nitpick for C10 we can see that some necessary beings that
are abstract in the actual world may indeed be concrete in other accessible worlds. Lowe had previously
presented numbers as an example of such necessary abstract beings. It can be argued that numbers, while
existing necessarily, can never be concrete in any possible world, so we add the restriction
of abstractness being an essential property, i.e. a locally rigid predicate.
}\<close>
axiomatization where
  abstractness_essential: "\<lfloor>\<^bold>\<forall>x. Abstract x \<^bold>\<rightarrow> \<^bold>\<box>Abstract x\<rfloor>"

theorem C10:  "\<lfloor>\<^bold>\<exists>\<^sup>Ax. Godlike x\<rfloor>"
  nitpick[user_axioms] oops \<comment> \<open>Countermodel found\<close>

text\<open>\noindent{As Nitpick shows us, the former restriction is not enough to prove C10.
We try postulating further restrictions on the accessibility relation \emph{R} which, taken together,
would amount to it being an equivalence relation. Following the \emph{Sahlqvist correspondence}, this
would make for a modal logic \emph{S5}, and our abstractness property would consequently
become a (globally) rigid predicate.}\<close>

axiomatization where
 T_axiom: "reflexive R" and \<comment> \<open>@{text "\<box>\<phi> \<rightarrow> \<phi>"}\<close>
 B_axiom: "symmetric R" and \<comment> \<open>@{text "\<phi> \<rightarrow>  \<box>\<diamond>\<phi>"}\<close>
 IV_axiom: "transitive R"   \<comment> \<open>@{text "\<box>\<phi> \<rightarrow> \<box>\<box>\<phi>"}\<close>

theorem C10:  "\<lfloor>\<^bold>\<exists>\<^sup>Ax. Godlike x\<rfloor>"
  nitpick[user_axioms] oops \<comment> \<open>Countermodel found\<close>

text\<open>\noindent{By examining the new countermodel found by Nitpick we notice that at some worlds there are
non-existent concrete beings. We want to disallow this possibility, so we make concreteness
an existence-entailing property.}\<close>

axiomatization where concrete_exist: "\<lfloor>\<^bold>\<forall>x. Concrete x \<^bold>\<rightarrow> E! x\<rfloor>"

text\<open>\noindent{We carry out the usual `sanity checks' to make sure the argument has not become trivialized.\footnote{
These checks are being carried out after postulating axioms for every iteration,
so we won't mention them anymore.}}\<close>
lemma True
  nitpick[satisfy, user_axioms] oops \<comment> \<open>Model found: axioms are consistent\<close>
lemma "\<lfloor>\<^bold>\<forall>x. E! x\<rfloor>"
  nitpick[user_axioms] oops \<comment> \<open>Countermodel found: necessitism is not valid\<close>
lemma "\<lfloor>\<phi> \<^bold>\<rightarrow> \<^bold>\<box>\<phi>\<rfloor>"
  nitpick[user_axioms] oops \<comment> \<open>Countermodel found: modal collapse is not valid\<close>

text\<open>\noindent{Since this time Nitpick was not able to find a countermodel for C10, we have enough confidence in
the validity of the formula to ask Sledgehammer to search for a proof.}\<close>
theorem C10:  "\<lfloor>\<^bold>\<exists>\<^sup>Ax. Godlike x\<rfloor>" using Existence_def Necessary_def
    abstractness_essential concrete_exist P2 C1 B_axiom by meson

text\<open>\noindent{Sledgehammer is able to find a proof relying on all premises
but the two modal axioms \emph{T} and \emph{IV}. By the end of this iteration we see
that Lowe's modal ontological argument depends for its validity on three non-stated (i.e. implicit) premises:
the essentiality of abstractness, the existence-entailing nature of concreteness and the modal
axiom \emph{B} (\<open>\<phi> \<rightarrow>  \<box>\<diamond>\<phi>\<close>). Moreover, we have also shed some light on the meaning of the concepts
of abstractness and concreteness.}\<close>

(*<*)
end
(*>*)