theory GraphExec
  imports Main tsp.Misc tsp.Berge tsp.CompleteGraph tsp.WeightedGraph
  "HOL-Data_Structures.Map_Specs" "HOL-Data_Structures.Set_Specs"
begin

(* OLD, NOT NEEDED; TODO: remove *)

definition "uedge \<equiv> \<lambda>(u,v). {u,v}"

locale irrefl_sym_digraph =
  fixes dE :: "('a \<times> 'a) set" \<comment> \<open>The graph is only represented by the set of directed edges.\<close>
  assumes finite_dE: "finite dE"
      and irrefl: "\<And>u. (u,u) \<notin> dE" \<comment> \<open>The set of edges is irreflexive.\<close>
      and sym: "\<And>u v. (u,v) \<in> dE \<Longrightarrow> (v,u) \<in> dE" \<comment> \<open>The set of edges is symmetric.\<close>
begin

definition "E \<equiv> uedge ` dE"

lemma finite_uedge_dE: "finite E"
  unfolding E_def by (simp add: finite_dE)

lemma edge_invar_uedge_E:
  assumes "e \<in> E"
  obtains u v where "e = {u,v}" "u \<noteq> v"
proof -
  obtain u v where "e = {u,v}" and "(u,v) \<in> dE"
    using assms unfolding E_def uedge_def by auto
  moreover hence "u \<noteq> v"
    using irrefl by auto
  ultimately show ?thesis
    using that by auto
qed

lemma graph_E: "graph_invar E"
  using finite_uedge_dE edge_invar_uedge_E by (intro graph_invarI2) force+

sublocale graph_abs E \<comment> \<open>A symmetric digraph is a undirected graph.\<close>
  using graph_E by unfold_locales

end

locale graph_adj_map =
  Map map_empty update map_delete lookup map_invar +
  Set set_empty insert set_delete isin set set_invar
  for map_empty :: "'map" and update :: "'v \<Rightarrow> 'vset \<Rightarrow> 'map \<Rightarrow> 'map" and map_delete lookup map_invar and
    set_empty :: "'vset" and insert :: "'v \<Rightarrow> 'vset \<Rightarrow> 'vset" and set_delete isin set set_invar +
  fixes G :: "'map" and \<N>\<^sub>G
  defines "\<N>\<^sub>G v \<equiv> (case lookup G v of None \<Rightarrow> set_empty | Some N \<Rightarrow> N)"
  assumes finite_edges: "finite {(u,v) | u v. v \<in> set (\<N>\<^sub>G u)}" \<comment> \<open>We assume the set of edges to be finite.\<close>
      and irrefl: "\<And>v. v \<notin> set (\<N>\<^sub>G v)" \<comment> \<open>The set of edges is irreflexive.\<close>
      and sym: "\<And>u v. u \<in> set (\<N>\<^sub>G v) \<Longrightarrow> v \<in> set (\<N>\<^sub>G u)" \<comment> \<open>The graph is undirected, thus the directed-edges have to be symmetric.\<close>
begin

definition "dE \<equiv> {(u,v) | u v. v \<in> set (\<N>\<^sub>G u)}" \<comment> \<open>We convert the adjacency map to a directed graph.\<close>

lemma finite_dE: "finite dE"
  unfolding dE_def using finite_edges .

lemma irrefl_dE: "(u,u) \<notin> dE"
  unfolding dE_def using irrefl by auto

lemma sym_dE: "(u,v) \<in> dE \<Longrightarrow> (v,u) \<in> dE"
  unfolding dE_def using sym by auto

sublocale irrefl_sym_digraph dE \<comment> \<open>The adjacency map represents a irreflexive & symmetric digraph.\<close>
  using finite_dE irrefl_dE sym_dE by unfold_locales

lemma E_def2: "E = uedge ` {(u,v) | u v. v \<in> set (\<N>\<^sub>G u)}"
  unfolding E_def by (auto simp: dE_def)

end

section \<open>List Implementation for Sets\<close>

type_synonym 'a lset = "'a list"

definition lset_empty :: "'a lset"
  where "lset_empty = []"

fun lset_delete :: "'a \<Rightarrow> 'a lset \<Rightarrow> 'a lset" where
  "lset_delete a as = filter (\<lambda>x. a \<noteq> x) as"

fun lset_insert :: "'a \<Rightarrow> 'a lset \<Rightarrow> 'a lset" where
  "lset_insert a as = a#lset_delete a as"

fun lset_isin :: "'a lset \<Rightarrow> 'a \<Rightarrow> bool" where
  "lset_isin as a = (filter (\<lambda>x. a = x) as \<noteq> [])"

fun lset_set :: "'a lset \<Rightarrow> 'a set" where
  "lset_set as = set as"

fun lset_invar :: "'a lset \<Rightarrow> bool" where
  "lset_invar as = distinct as"

lemma lset_empty: "lset_set lset_empty = {}"
  by (auto simp: lset_empty_def)

lemma lset_isin: "lset_invar s \<Longrightarrow> lset_isin s x = (x \<in> lset_set s)"
  by (induction s) auto

lemma lset_insert: "lset_invar s \<Longrightarrow> lset_set (lset_insert x s) = lset_set s \<union> {x}"
  by auto

lemma lset_delete: "lset_invar s \<Longrightarrow> lset_set (lset_delete x s) = lset_set s - {x}"
  by (induction s) auto

lemma lset_invar_empty: "lset_invar lset_empty"
  by (auto simp: lset_empty_def)

lemma lset_invar_insert: "lset_invar s \<Longrightarrow> lset_invar (lset_insert x s)"
  by auto

lemma lset_invar_delete: "lset_invar s \<Longrightarrow> lset_invar (lset_delete x s)"
  by auto

lemmas lset_specs = lset_empty lset_isin lset_insert lset_delete lset_invar_empty lset_invar_insert
  lset_invar_delete

interpretation lset: Set lset_empty lset_insert lset_delete lset_isin lset_set lset_invar
  using lset_specs by unfold_locales

section \<open>Adjacency List implementation for Maps\<close>

type_synonym ('a,'b) adj_list = "('a \<times> 'b) list"

definition adjl_empty :: "('a,'b) adj_list" where
  "adjl_empty = []"

fun adjl_delete :: "'a \<Rightarrow> ('a,'b) adj_list \<Rightarrow> ('a,'b) adj_list" where
  "adjl_delete a M = filter (\<lambda>(x,y). a \<noteq> x) M"

fun adjl_update :: "'a \<Rightarrow> 'b \<Rightarrow> ('a,'b) adj_list \<Rightarrow> ('a,'b) adj_list" where
  "adjl_update a b M = (a,b)#adjl_delete a M"

fun adjl_lookup :: "('a,'b) adj_list \<Rightarrow> 'a \<Rightarrow> 'b option" where
  "adjl_lookup [] a = None"
| "adjl_lookup ((x,y)#M) a = (if a = x then Some y else adjl_lookup M a)"

fun adjl_invar :: "('a,'b) adj_list \<Rightarrow> bool" where
  "adjl_invar M = distinct (map fst M)"

lemma adj_list_empty: "adjl_lookup adjl_empty = (\<lambda>_. None)"
  unfolding adjl_empty_def by auto

lemma adj_list_delete: "adjl_invar M \<Longrightarrow> adjl_lookup (adjl_delete a M) = (adjl_lookup M) (a := None)"
  by (induction M) auto

lemma adj_list_update: "adjl_invar M \<Longrightarrow> adjl_lookup (adjl_update a b M) = (adjl_lookup M) (a := Some b)"
  by (auto simp add: adj_list_delete simp del: adjl_delete.simps)

lemma adj_list_invar_empty: "adjl_invar adjl_empty"
  by (auto simp: adjl_empty_def)

lemma adj_list_invar_update: "adjl_invar M \<Longrightarrow> adjl_invar (adjl_update a b M)"
  by (induction M) auto

lemma adj_list_invar_delete: "adjl_invar M \<Longrightarrow> adjl_invar (adjl_delete a M)"
  by (induction M) auto

lemmas adj_list_specs = adj_list_empty adj_list_update adj_list_delete adj_list_invar_empty
  adj_list_invar_update adj_list_invar_delete

interpretation adj_list: Map adjl_empty adjl_update adjl_delete adjl_lookup adjl_invar
  using adj_list_specs by unfold_locales

section \<open>Graph Implementation with Adjacency-Lists\<close>

type_synonym 'v graph_adj_list = "('v,'v lset) adj_list"
type_synonym 'v dedge = "'v \<times> 'v" \<comment> \<open>graph list edge\<close>

datatype 'v uedge = uEdge 'v 'v

fun uEdge_eq :: "'v uedge \<Rightarrow> 'v uedge \<Rightarrow> bool" where
  "uEdge_eq (uEdge u\<^sub>1 v\<^sub>1) (uEdge u\<^sub>2 v\<^sub>2) = (u\<^sub>1 = u\<^sub>2 \<and> v\<^sub>1 = v\<^sub>2 \<or> u\<^sub>1 = v\<^sub>2 \<and> v\<^sub>1 = u\<^sub>2)"

(* quotient_type 'v uedge = "'v dedge" / uEdge_eq
  morphisms Rep_uedge Abs_uedge
proof (rule equivpI)
  show "reflp uEdge_eq"
    by (auto simp: reflp_def)
  show "symp uEdge_eq"
    by (auto simp: symp_def)
  show "transp uEdge_eq"
    by (auto simp: transp_def)
qed *)

(* instantiation uedge :: (equal) equal
begin

instance
proof (standard, goal_cases)

end *)

value "uEdge (1::nat) 2 = uEdge (2::nat) 1"

abbreviation "lset_opt A\<^sub>o\<^sub>p\<^sub>t \<equiv> (case A\<^sub>o\<^sub>p\<^sub>t of None \<Rightarrow> lset_empty | Some A \<Rightarrow> A)"

abbreviation "\<N> Es v \<equiv> lset_opt (adjl_lookup Es v)" \<comment> \<open>Neighbourhood\<close>

fun graph_adjl_invar :: "'v graph_adj_list \<Rightarrow> bool" where
  "graph_adjl_invar G = (adjl_invar G \<and> (\<forall>(u,N\<^sub>u) \<in> set G. lset_invar N\<^sub>u))"

fun dedges :: "'v graph_adj_list \<Rightarrow> 'v dedge list" where
  "dedges G = concat (map (\<lambda>(u,N\<^sub>u). map (Pair u) N\<^sub>u) G)"

fun uedge_list :: "'v graph_adj_list \<Rightarrow> 'v uedge list" where
  "uedge_list G = (let f = (\<lambda>(u,v) Es.
      case find (uEdge_eq (uEdge u v)) Es of None \<Rightarrow> (uEdge u v)#Es | Some _ \<Rightarrow> Es) in
    fold f (dedges G) [])"

fun uedges :: "'v graph_adj_list \<Rightarrow> 'v set set" where \<comment> \<open>Abstraction function\<close>
  "uedges G = set (map uedge (dedges G))"

lemma distinct_dedges: "graph_adjl_invar G \<Longrightarrow> distinct (dedges G)"
proof (induction G rule: pair_list.induct)
  case (2 u N\<^sub>u G)
  hence "\<And>e. e \<in> set (dedges G) \<Longrightarrow> fst e \<noteq> u"
    by force
  moreover have "\<And>e. e \<in> set (dedges [(u,N\<^sub>u)]) \<Longrightarrow> fst e = u"
    by auto
  ultimately have "set (dedges [(u,N\<^sub>u)]) \<inter> set (dedges G) = {}"
    by blast
  moreover have "distinct (dedges [(u,N\<^sub>u)])"
    using 2 by (auto simp: distinct_map inj_on_def)
  moreover have "distinct (dedges G)"
    using 2 by auto
  ultimately show ?case
    by auto
qed auto

lemma distinct_uedges: "\<And>u v. uEdge u v \<in> set (uedge_list G) \<Longrightarrow> uEdge v u \<notin> set (uedge_list G)"
proof (induction G rule: pair_list.induct)
  case 1
  then show ?case by auto
next
  case (2 x N\<^sub>x G)
  then show ?case sorry
qed

lemma adjl_member_unique:
  assumes "graph_adjl_invar G" and "(u,N\<^sub>u) \<in> set G" "(u,N\<^sub>v) \<in> set G"
  shows "N\<^sub>u = N\<^sub>v"
proof (rule ccontr)
  assume "N\<^sub>u \<noteq> N\<^sub>v"
  hence "\<not> distinct (map fst G)"
    using assms by (meson eq_key_imp_eq_value)
  thus False
    using assms by auto
qed

lemma adjl_member_adjl_lookup:
  assumes "graph_adjl_invar G" and "(u,N\<^sub>u) \<in> set G"
  shows "adjl_lookup G u = Some N\<^sub>u"
  using assms
proof (induction G rule: pair_list.induct)
  case (2 v N\<^sub>v G)
  thus ?case
  proof cases
    assume "u = v"
    moreover hence "N\<^sub>v = N\<^sub>u"
      using "2.prems" by (intro adjl_member_unique[of "(v,N\<^sub>v)#G"]) auto
    ultimately show ?thesis
      by auto
  qed auto
qed auto

lemma adjl_lookup_adjl_member:
  assumes "graph_adjl_invar G" and "adjl_lookup G u = Some N\<^sub>u"
  shows "(u,N\<^sub>u) \<in> set G"
  using assms
proof (induction G rule: pair_list.induct)
  case (2 v N\<^sub>v Es)
  thus ?case
    by (cases "u = v") (auto simp add: adj_list_delete simp del: adjl_delete.simps)
qed auto

lemma neighbour_member:
  assumes "v \<in> lset_set (\<N> G u)"
  obtains N\<^sub>u where "adjl_lookup G u = Some N\<^sub>u" "v \<in> lset_set N\<^sub>u"
proof -
  obtain N\<^sub>u where "\<N> G u = N\<^sub>u" "v \<in> lset_set N\<^sub>u"
    using assms by auto
  moreover hence "adjl_lookup G u = Some N\<^sub>u"
    using lset_empty by (fastforce split: option.splits)+
  ultimately show ?thesis
    using that by auto
qed

lemma neighbourhood_memberI:
  assumes "graph_adjl_invar G" and "(u,v) \<in> set (dedges G)"
  shows "v \<in> lset_set (\<N> G u)"
proof -
  obtain N\<^sub>u where "v \<in> lset_set N\<^sub>u" "(u,N\<^sub>u) \<in> set G"
    using assms by auto
  moreover hence "adjl_lookup G u = Some N\<^sub>u"
    using assms by (intro adjl_member_adjl_lookup)
  ultimately show ?thesis
    by auto
qed

lemma dedges_memberI:
  assumes "graph_adjl_invar G" and "v \<in> lset_set (\<N> G u)"
  shows "(u,v) \<in> set (dedges G)"
proof -
  obtain N\<^sub>u where "adjl_lookup G u = Some N\<^sub>u" "v \<in> lset_set N\<^sub>u"
    using assms by (elim neighbour_member)
  moreover hence "(u,N\<^sub>u) \<in> set G"
    using assms by (intro adjl_lookup_adjl_member)
  ultimately show ?thesis
    by auto
qed

lemma dedges_superset:
  assumes "graph_adjl_invar G"
  shows "{(u,v) | u v. v \<in> lset_set (\<N> G u)} \<subseteq> set (dedges G)"
  (is "?dE \<subseteq> set (dedges G)")
proof
  fix e
  assume "e \<in> ?dE"
  then obtain u v where [simp]: "e = (u,v)" and "v \<in> lset_set (\<N> G u)"
    by auto
  hence "(u,v) \<in> set (dedges G)"
    using assms by (intro dedges_memberI)
  thus "e \<in> set (dedges G)"
    by auto
qed

lemma dedges_subset:
  assumes "graph_adjl_invar G"
  shows "set (dedges G) \<subseteq> {(u,v) | u v. v \<in> lset_set (\<N> G u)}"
  (is "set (dedges G) \<subseteq> ?dE")
proof (intro subsetI)
  fix e
  assume "e \<in> set (dedges G)"
  moreover then obtain u v where [simp]: "e = (u,v)"
    by auto
  ultimately have "v \<in> lset_set (\<N> G u)"
    using assms by (intro neighbourhood_memberI) auto
  thus "e \<in> ?dE"
    by auto
qed

lemma dedges_eq:
  assumes "graph_adjl_invar G"
  shows "set (dedges G) = {(u,v) | u v. v \<in> lset_set (\<N> G u)}"
  using assms dedges_superset dedges_subset by blast

locale graph_adj_list =
  fixes G :: "'v graph_adj_list"
  assumes graph_G: "graph_adjl_invar G"
    and irrefl: "\<And>v. v \<notin> lset_set (\<N> G v)"
    and sym: "\<And>u v. u \<in> lset_set (\<N> G v) \<Longrightarrow> v \<in> lset_set (\<N> G u)"
    and no_disconnected_vertices: "\<And>u N\<^sub>u. (u,N\<^sub>u) \<in> set G \<Longrightarrow> N\<^sub>u \<noteq> lset_empty"
begin

lemma finite_edge_set: "finite {(u,v) | u v. v \<in> lset_set (\<N> G u)}"
  using graph_G by (intro finite_subset[OF dedges_superset]) auto

sublocale graph_adj_map adjl_empty adjl_update adjl_delete adjl_lookup adjl_invar
  lset_empty lset_insert lset_delete lset_isin lset_set lset_invar G "\<N> G"
  unfolding graph_adj_map_def
  using adj_list.Map_axioms lset.Set_axioms apply auto
  using finite_edge_set irrefl sym by unfold_locales

lemma dE_def2: "dE = set (dedges G)"
  using graph_G by (subst dedges_eq) (auto simp: dE_def)

lemma E_def3: "E = uedges G"
  unfolding E_def using dE_def2 by (auto simp: dE_def)

lemma "Vs E = set (map fst G)"
  sorry

lemma "{u,v} \<in> E \<longleftrightarrow> u \<in> lset_set (\<N> G v)"
  sorry

end

fun compl_graph_exec :: "'a list \<Rightarrow> 'a graph_adj_list" where
  "compl_graph_exec X = map (\<lambda>x. (x,filter ((\<noteq>) x) X)) X"

definition "is_complete_exec G \<equiv> (\<forall>(u,N\<^sub>u) \<in> set G. lset_set N\<^sub>u = set (map fst G) - {u})"

lemma is_complete_execI:
  assumes "\<And>u N\<^sub>u. (u,N\<^sub>u) \<in> set G \<Longrightarrow> lset_set N\<^sub>u = set (map fst G) - {u}"
  shows "is_complete_exec G"
  using assms by (auto simp: is_complete_exec_def)

lemma "is_complete_exec (compl_graph_exec X)"
proof (rule is_complete_execI)
  fix u N\<^sub>u
  assume "(u,N\<^sub>u) \<in> set (compl_graph_exec X)"
  hence "N\<^sub>u = filter ((\<noteq>) u) X"
    by auto
  moreover have "map fst (compl_graph_exec X) = X"
  proof (induction X)
    case Nil
    then show ?case by auto
  next
    case (Cons u X)
    hence "map fst (compl_graph_exec (u#X)) = map fst (map (\<lambda>x. (x,filter ((\<noteq>) x) (u#X))) (u#X))"
      by auto
    also have "... = u#map fst (compl_graph_exec X)"
      by auto
    also have "... = u#X"
      using Cons by auto
    finally show ?case .
  qed
  ultimately show "lset_set N\<^sub>u = set (map fst (compl_graph_exec X)) - {u}"
    by auto
qed

context graph_adj_list
begin

lemma "is_complete_exec G \<longleftrightarrow> is_complete E"
proof
  assume "is_complete_exec G"
  show "is_complete E"
  proof (rule is_completeI)
    fix u v
    assume "u \<in> Vs E" "v \<in> Vs E" "u \<noteq> v"
    show "{u,v} \<in> E"
      sorry
  qed
next
  assume "is_complete E"
  show "is_complete_exec G"
  proof (rule is_complete_execI)
    fix u N\<^sub>u
    assume "(u,N\<^sub>u) \<in> set G"
    show "lset_set N\<^sub>u = set (map fst G) - {u}"
      sorry
  qed
qed

end

locale metric_graph_adj_list =
  graph_adj_list G for G :: "'a graph_adj_list" +
  fixes c :: "'a dedge \<Rightarrow> 'b::{ordered_semiring_0,semiring_numeral}"
  assumes complete: "is_complete E"
    and costs_positive: "\<And>e. c e > 0"
    and tri_ineq: "u \<in> Vs E \<Longrightarrow> v \<in> Vs E \<Longrightarrow> w \<in> Vs E \<Longrightarrow> c (u,w) \<le> c (u,v) + c (v,w)"
begin

end

section \<open>Example: Computing Reachability between Vertices with DFS\<close>

locale some_path =
  graph_abs E for E :: "'v set set" +
  fixes find_path :: "'v \<Rightarrow> 'v \<Rightarrow> 'v list option" \<comment> \<open>Some executable function on a abstract graph representation.\<close>
  assumes find_path_walk: "\<And>u v P. find_path u v = Some P \<Longrightarrow> walk_betw E u P v" \<comment> \<open>The function \<open>find_path\<close> only returns valid paths.\<close>
      and connected_find_path: "\<And>u v. v \<in> connected_component E u \<Longrightarrow> \<exists>P. find_path u v = Some P" \<comment> \<open>If there is a path between the vertices \<open>u\<close> and \<open>v\<close> then the function \<open>find_path\<close> will return a path.\<close>
begin

lemma find_path_connected_iff: "(\<exists>P. find_path u v = Some P) \<longleftrightarrow> v \<in> connected_component E u"
  using find_path_walk connected_find_path by blast

end

lemma "length (dedges (al_delete u Es)) \<le> length (dedges Es)"
  sorry

lemma length_dedges_al_delete_eq:
  assumes "al_lookup Es u = None"
  shows "length (dedges (al_delete u Es)) = length (dedges Es)"
  sorry

lemma length_dedges_al_delete_leq: "length (dedges (al_delete u Es)) \<le> length (dedges Es)"
  sorry

lemma length_edges_al_delete:
  assumes "al_lookup Es u = Some (x#N\<^sub>u)"
  shows "length N\<^sub>u + length (dedges (al_delete u Es)) < length (dedges Es)"
  sorry

function find_path_dfs :: "'v graph_list \<Rightarrow> 'v \<Rightarrow> 'v \<Rightarrow> 'v list option" where
  "find_path_dfs Es u v =
    (if u = v then Some [u]
    else (case al_lookup Es u of
      Some (x#N\<^sub>u) \<Rightarrow>
      if x = v then Some [u,v] \<comment> \<open>We found a path from \<open>u\<close> to \<open>v\<close>.\<close>
      else let Es' = al_update u N\<^sub>u Es in \<comment> \<open>Construct remove the edge \<open>(u,x)\<close> from the graph \<open>G\<close>.\<close>
        (case find_path_dfs Es' x v of
          Some P \<Rightarrow> Some (u#P) \<comment> \<open>Try to find a path from \<open>x\<close> to \<open>v\<close>.\<close>
        | None \<Rightarrow> find_path_dfs Es' u v) \<comment> \<open>There is no path from \<open>x\<close> to \<open>v\<close>. We need to explore a different neighbour of \<open>u\<close>.\<close>
    | _ \<Rightarrow> None))"
  by pat_completeness auto
termination find_path_dfs
  apply (relation "measure (\<lambda>(Es,u,v). length (dedges Es))")
  subgoal
    by simp
  subgoal for Es u v N\<^sub>u x N\<^sub>u' Es'
    using length_edges_al_delete by force
  subgoal for Es u v N\<^sub>u x N\<^sub>u' Es'
    using length_edges_al_delete by force
  done

definition "Es\<^sub>t\<^sub>e\<^sub>s\<^sub>t \<equiv> [(1::nat,[2]),(2,[1,4,3]),(3,[2]),(4,[2])]"
value "find_path_dfs Es\<^sub>t\<^sub>e\<^sub>s\<^sub>t 1 3" \<comment> \<open>Test of the function \<open>find_path_dfs\<close>.\<close>

context graph_adj_list
begin

definition "find_path_dfs\<^sub>G = (\<lambda>u v. find_path_dfs Es u v)"

lemma find_path_walk:
  assumes "find_path_dfs\<^sub>G u v = Some P"
  shows "walk_betw E u P v"
  sorry

lemma connected_find_path:
  assumes "v \<in> connected_component E u"
  shows "\<exists>P. find_path_dfs\<^sub>G u v = Some P"
  sorry

sublocale some_path E find_path_dfs\<^sub>G
  using find_path_walk connected_find_path by unfold_locales

thm find_path_connected_iff

end

end


(* Author: Alexander Maletzky *)

section \<open>Polynomial Mappings and Univariate Polynomials\<close>

theory Univariate_PM
  imports "HOL-Computational_Algebra.Polynomial" Polynomials.MPoly_PM
begin

subsection \<open>Morphisms \<open>pm_of_poly\<close> and \<open>poly_of_pm\<close>\<close>

text \<open>Many things in this section are copied from theory \<open>Polynomials.MPoly_Type_Univariate\<close>.\<close>

lemma pm_of_poly_aux:
  "{t. (poly.coeff p (lookup t x) when t \<in> .[{x}]) \<noteq> 0} =
          Poly_Mapping.single x ` {d. poly.coeff p d \<noteq> 0}" (is "?M = _")
proof (intro subset_antisym subsetI)
  fix t
  assume "t \<in> ?M"
  hence "\<And>y. y \<noteq> x \<Longrightarrow> Poly_Mapping.lookup t y = 0" by (fastforce simp: PPs_def in_keys_iff)
  hence "t = Poly_Mapping.single x (lookup t x)"
    using poly_mapping_eqI by (metis (full_types) lookup_single_eq lookup_single_not_eq)
  then show "t \<in> (Poly_Mapping.single x) ` {d. poly.coeff p d \<noteq> 0}" using \<open>t \<in> ?M\<close> by auto
qed (auto split: if_splits simp: PPs_def)

lift_definition pm_of_poly :: "'x \<Rightarrow> 'a poly \<Rightarrow> ('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_monoid_add"
  is "\<lambda>x p t. (poly.coeff p (lookup t x)) when t \<in> .[{x}]"
proof -
  fix x::'x and p::"'a poly"
  show "finite {t. (poly.coeff p (lookup t x) when t \<in> .[{x}]) \<noteq> 0}" unfolding pm_of_poly_aux
    using finite_surj[OF MOST_coeff_eq_0[unfolded eventually_cofinite]] by blast
qed

definition poly_of_pm :: "'x \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow> 'a::comm_monoid_add poly"
  where "poly_of_pm x p = Abs_poly (\<lambda>d. lookup p (Poly_Mapping.single x d))"

lemma lookup_pm_of_poly_single [simp]:
  "lookup (pm_of_poly x p) (Poly_Mapping.single x d) = poly.coeff p d"
  by (simp add: pm_of_poly.rep_eq PPs_closed_single)

lemma keys_pm_of_poly: "keys (pm_of_poly x p) = Poly_Mapping.single x ` {d. poly.coeff p d \<noteq> 0}"
proof -
  have "keys (pm_of_poly x p) = {t. (poly.coeff p (lookup t x) when t \<in> .[{x}]) \<noteq> 0}"
    by (rule set_eqI) (simp add: pm_of_poly.rep_eq flip: lookup_not_eq_zero_eq_in_keys)
  also have "\<dots> = Poly_Mapping.single x ` {d. poly.coeff p d \<noteq> 0}" by (fact pm_of_poly_aux)
  finally show ?thesis .
qed

lemma coeff_poly_of_pm [simp]: "poly.coeff (poly_of_pm x p) k = lookup p (Poly_Mapping.single x k)"
proof -
  have 0:"Poly_Mapping.single x ` {d. lookup p (Poly_Mapping.single x d) \<noteq> 0} \<subseteq> {d. lookup p d \<noteq> 0}"
    by auto
  have "\<forall>\<^sub>\<infinity> k. lookup p (Poly_Mapping.single x k) = 0" unfolding coeff_def eventually_cofinite
    using finite_imageD[OF finite_subset[OF 0 Poly_Mapping.finite_lookup]] inj_single
    by (metis inj_eq inj_onI)
  then show ?thesis by (simp add: poly_of_pm_def Abs_poly_inverse)
qed

lemma pm_of_poly_of_pm:
  assumes "p \<in> P[{x}]"
  shows "pm_of_poly x (poly_of_pm x p) = p"
proof (rule poly_mapping_eqI)
  fix t
  from assms have "keys p \<subseteq> .[{x}]" by (rule PolysD)
  show "lookup (pm_of_poly x (poly_of_pm x p)) t = lookup p t"
  proof (simp add: pm_of_poly.rep_eq when_def, intro conjI impI)
    assume "t \<in> .[{x}]"
    hence "Poly_Mapping.single x (lookup t x) = t"
      by (simp add: PPsD keys_subset_singleton_imp_monomial)
    thus "lookup p (Poly_Mapping.single x (lookup t x)) = lookup p t" by simp
  next
    assume "t \<notin> .[{x}]"
    with assms PolysD have "t \<notin> keys p" by blast
    thus "lookup p t = 0" by (simp add: in_keys_iff)
  qed
qed

lemma poly_of_pm_of_poly [simp]: "poly_of_pm x (pm_of_poly x p) = p"
  by (simp add: poly_of_pm_def coeff_inverse)

lemma pm_of_poly_in_Polys: "pm_of_poly x p \<in> P[{x}]"
  by (auto simp: keys_pm_of_poly PPs_closed_single intro!: PolysI)

lemma pm_of_poly_zero [simp]: "pm_of_poly x 0 = 0"
  by (rule poly_mapping_eqI) (simp add: pm_of_poly.rep_eq)

lemma pm_of_poly_eq_zero_iff [iff]: "pm_of_poly x p = 0 \<longleftrightarrow> p = 0"
  by (metis poly_of_pm_of_poly pm_of_poly_zero)

lemma pm_of_poly_monom: "pm_of_poly x (Polynomial.monom c d) = monomial c (Poly_Mapping.single x d)"
proof (rule poly_mapping_eqI)
  fix t
  show "lookup (pm_of_poly x (Polynomial.monom c d)) t = lookup (monomial c (monomial d x)) t"
  proof (cases "t \<in> .[{x}]")
    case True
    thus ?thesis
      by (auto simp: pm_of_poly.rep_eq lookup_single PPs_singleton when_def dest: monomial_inj)
  next
    case False
    thus ?thesis by (auto simp add: pm_of_poly.rep_eq lookup_single PPs_singleton)
  qed
qed

lemma pm_of_poly_plus: "pm_of_poly x (p + q) = pm_of_poly x p + pm_of_poly x q"
  by (rule poly_mapping_eqI) (simp add: pm_of_poly.rep_eq lookup_add when_add_distrib)

lemma pm_of_poly_uminus [simp]: "pm_of_poly x (- p) = - pm_of_poly x p"
  by (rule poly_mapping_eqI) (simp add: pm_of_poly.rep_eq when_distrib)

lemma pm_of_poly_minus: "pm_of_poly x (p - q) = pm_of_poly x p - pm_of_poly x q"
  by (rule poly_mapping_eqI) (simp add: pm_of_poly.rep_eq lookup_minus when_diff_distrib)

lemma pm_of_poly_one [simp]: "pm_of_poly x 1 = 1"
  by (simp add: pm_of_poly_monom flip: single_one monom_eq_1)

lemma pm_of_poly_pCons:
  "pm_of_poly x (pCons c p) =
      monomial c 0 + punit.monom_mult (1::_::monoid_mult) (Poly_Mapping.single x 1) (pm_of_poly x p)"
    (is "?l = ?r")
proof (rule poly_mapping_eqI)
  fix t
  let ?x = "Poly_Mapping.single x (Suc 0)"
  show "lookup ?l t = lookup ?r t"
  proof (cases "?x adds t")
    case True
    have 1: "t - ?x \<in> .[{x}] \<longleftrightarrow> t \<in> .[{x}]"
    proof
      assume "t - ?x \<in> .[{x}]"
      moreover have "?x \<in> .[{x}]" by (rule PPs_closed_single) simp
      ultimately have "(t - ?x) + ?x \<in> .[{x}]" by (rule PPs_closed_plus)
      with True show "t \<in> .[{x}]" by (simp add: adds_minus)
    qed (rule PPs_closed_minus)
    from True have "0 < lookup t x"
      by (metis adds_minus lookup_add lookup_single_eq n_not_Suc_n neq0_conv plus_eq_zero_2)
    moreover from this have "t \<noteq> 0" by auto
    ultimately show ?thesis using True
      by (simp add: pm_of_poly.rep_eq lookup_add lookup_single punit.lookup_monom_mult 1 coeff_pCons
                    lookup_minus split: nat.split)
  next
    case False
    moreover have "t \<in> .[{x}] \<longleftrightarrow> t = 0"
    proof
      assume "t \<in> .[{x}]"
      hence "keys t \<subseteq> {x}" by (rule PPsD)
      show "t = 0"
      proof (rule ccontr)
        assume "t \<noteq> 0"
        hence "keys t \<noteq> {}" by simp
        then obtain y where "y \<in> keys t" by blast
        with \<open>keys t \<subseteq> {x}\<close> have "y \<in> {x}" ..
        hence "y = x" by simp
        with \<open>y \<in> keys t\<close> have "Suc 0 \<le> lookup t x" by (simp add: in_keys_iff)
        hence "?x adds t"
          by (metis adds_poly_mappingI le0 le_funI lookup_single_eq lookup_single_not_eq)
        with False show False ..
      qed
    qed (simp only: zero_in_PPs)
    ultimately show ?thesis
      by (simp add: pm_of_poly.rep_eq lookup_add lookup_single punit.lookup_monom_mult when_def)
  qed
qed

lemma pm_of_poly_smult [simp]: "pm_of_poly x (Polynomial.smult c p) = c \<cdot> pm_of_poly x p"
  by (rule poly_mapping_eqI) (simp add: pm_of_poly.rep_eq when_distrib)

lemma pm_of_poly_times: "pm_of_poly x (p * q) = pm_of_poly x p * pm_of_poly x (q::_::ring_1 poly)"
proof (induct p)
  case 0
  show ?case by simp
next
  case (pCons a p)
  show ?case
    by (simp add: pm_of_poly_plus pm_of_poly_pCons map_scale_eq_times pCons(2) algebra_simps
             flip: times_monomial_left)
qed

lemma pm_of_poly_sum: "pm_of_poly x (sum f I) = (\<Sum>i\<in>I. pm_of_poly x (f i))"
  by (induct I rule: infinite_finite_induct) (simp_all add: pm_of_poly_plus)

lemma pm_of_poly_prod: "pm_of_poly x (prod f I) = (\<Prod>i\<in>I. pm_of_poly x (f i :: _::ring_1 poly))"
  by (induct I rule: infinite_finite_induct) (simp_all add: pm_of_poly_times)

lemma pm_of_poly_power [simp]: "pm_of_poly x (p ^ m) = pm_of_poly x (p::_::ring_1 poly) ^ m"
  by (induct m) (simp_all add: pm_of_poly_times)

lemma poly_of_pm_zero [simp]: "poly_of_pm x 0 = 0"
  by (metis poly_of_pm_of_poly pm_of_poly_zero)

lemma poly_of_pm_eq_zero_iff: "poly_of_pm x p = 0 \<longleftrightarrow> keys p \<inter> .[{x}] = {}"
proof
  assume eq: "poly_of_pm x p = 0"
  {
    fix t
    assume "t \<in> .[{x}]"
    then obtain d where "t = Poly_Mapping.single x d" unfolding PPs_singleton ..
    moreover assume "t \<in> keys p"
    ultimately have "0 \<noteq> lookup p (Poly_Mapping.single x d)" by (simp add: in_keys_iff)
    also have "lookup p (Poly_Mapping.single x d) = Polynomial.coeff (poly_of_pm x p) d"
      by simp
    also have "\<dots> = 0" by (simp add: eq)
    finally have False by blast
  }
  thus "keys p \<inter> .[{x}] = {}" by blast
next
  assume *: "keys p \<inter> .[{x}] = {}"
  {
    fix d
    have "Poly_Mapping.single x d \<in> .[{x}]" (is "?x \<in> _") by (rule PPs_closed_single) simp
    with * have "?x \<notin> keys p" by blast
    hence "Polynomial.coeff (poly_of_pm x p) d = 0" by (simp add: in_keys_iff)
  }
  thus "poly_of_pm x p = 0" using leading_coeff_0_iff by blast
qed

lemma poly_of_pm_monomial:
  "poly_of_pm x (monomial c t) = (Polynomial.monom c (lookup t x) when t \<in> .[{x}])"
proof (cases "t \<in> .[{x}]")
  case True
  moreover from this obtain d where "t = Poly_Mapping.single x d"
    by (metis PPsD keys_subset_singleton_imp_monomial)
  ultimately show ?thesis unfolding Polynomial.monom.abs_eq coeff_poly_of_pm
    by (auto simp: poly_of_pm_def lookup_single when_def
        dest!: monomial_inj intro!: arg_cong[where f=Abs_poly])
next
  case False
  moreover from this have "t \<noteq> monomial d x" for d by (auto simp: PPs_closed_single)
  ultimately show ?thesis unfolding Polynomial.monom.abs_eq coeff_poly_of_pm
    by (auto simp: poly_of_pm_def lookup_single when_def zero_poly.abs_eq)
qed

lemma poly_of_pm_plus: "poly_of_pm x (p + q) = poly_of_pm x p + poly_of_pm x q"
  unfolding Polynomial.plus_poly.abs_eq coeff_poly_of_pm by (simp add: poly_of_pm_def lookup_add)

lemma poly_of_pm_uminus [simp]: "poly_of_pm x (- p) = - poly_of_pm x p"
  unfolding Polynomial.uminus_poly.abs_eq coeff_poly_of_pm by (simp add: poly_of_pm_def)

lemma poly_of_pm_minus: "poly_of_pm x (p - q) = poly_of_pm x p - poly_of_pm x q"
  unfolding Polynomial.minus_poly.abs_eq coeff_poly_of_pm by (simp add: poly_of_pm_def lookup_minus)

lemma poly_of_pm_one [simp]: "poly_of_pm x 1 = 1"
  by (simp add: poly_of_pm_monomial zero_in_PPs flip: single_one monom_eq_1)

lemma poly_of_pm_times:
  "poly_of_pm x (p * q) = poly_of_pm x p * poly_of_pm x (q::_ \<Rightarrow>\<^sub>0 'a::comm_semiring_1)"
proof -
  have eq: "poly_of_pm x (monomial c t * q) = poly_of_pm x (monomial c t) * poly_of_pm x q"
    if "c \<noteq> 0" for c t
  proof (cases "t \<in> .[{x}]")
    case True
    then obtain d where t: "t = Poly_Mapping.single x d" unfolding PPs_singleton ..
    have "poly_of_pm x (monomial c t) * poly_of_pm x q = Polynomial.monom c (lookup t x) * poly_of_pm x q"
      by (simp add: True poly_of_pm_monomial)
    also have "\<dots> = poly_of_pm x (monomial c t * q)" unfolding t
    proof (induct d)
      case 0
      have "Polynomial.smult c (poly_of_pm x q) = poly_of_pm x (c \<cdot> q)"
        unfolding Polynomial.smult.abs_eq coeff_poly_of_pm by (simp add: poly_of_pm_def)
      with that show ?case by (simp add: Polynomial.times_poly_def flip: map_scale_eq_times)
    next
      case (Suc d)
      have 1: "Poly_Mapping.single x a adds Poly_Mapping.single x b \<longleftrightarrow> a \<le> b" for a b :: nat
        by (metis adds_def deg_pm_mono deg_pm_single le_Suc_ex single_add)
      have 2: "poly_of_pm x (punit.monom_mult 1 (Poly_Mapping.single x 1) r) = pCons 0 (poly_of_pm x r)"
        for r :: "_ \<Rightarrow>\<^sub>0 'a" unfolding poly.coeff_inject[symmetric]
        by (rule ext) (simp add: coeff_pCons punit.lookup_monom_mult adds_zero monomial_0_iff 1
                            flip: single_diff split: nat.split)
      from Suc that have "Polynomial.monom c (lookup (monomial (Suc d) x) x) * poly_of_pm x q =
                          poly_of_pm x (punit.monom_mult 1 (Poly_Mapping.single x 1)
                                            ((monomial c (monomial d x)) * q))"
        by (simp add: Polynomial.times_poly_def 2 del: One_nat_def)
      also have "\<dots> = poly_of_pm x (monomial c (Poly_Mapping.single x (Suc d)) * q)"
        by (simp add: ac_simps times_monomial_monomial flip: single_add times_monomial_left)
      finally show ?case .
    qed
    finally show ?thesis by (rule sym)
  next
    case False
    {
      fix s
      assume "s \<in> keys (monomial c t * q)"
      also have "\<dots> \<subseteq> (+) t ` keys q" unfolding times_monomial_left
        by (fact punit.keys_monom_mult_subset[simplified])
      finally obtain u where s: "s = t + u" ..
      assume "s \<in> .[{x}]"
      hence "s - u \<in> .[{x}]" by (rule PPs_closed_minus)
      hence "t \<in> .[{x}]" by (simp add: s)
      with False have False ..
    }
    hence "poly_of_pm x (monomial c t * q) = 0" by (auto simp: poly_of_pm_eq_zero_iff)
    with False show ?thesis by (simp add: poly_of_pm_monomial)
  qed
  show ?thesis
    by (induct p rule: poly_mapping_plus_induct) (simp_all add: poly_of_pm_plus eq distrib_right)
qed

lemma poly_of_pm_sum: "poly_of_pm x (sum f I) = (\<Sum>i\<in>I. poly_of_pm x (f i))"
  by (induct I rule: infinite_finite_induct) (simp_all add: poly_of_pm_plus)

lemma poly_of_pm_prod: "poly_of_pm x (prod f I) = (\<Prod>i\<in>I. poly_of_pm x (f i))"
  by (induct I rule: infinite_finite_induct) (simp_all add: poly_of_pm_times)

lemma poly_of_pm_power [simp]: "poly_of_pm x (p ^ m) = poly_of_pm x p ^ m"
  by (induct m) (simp_all add: poly_of_pm_times)

subsection \<open>Evaluating Polynomials\<close>

lemma poly_eq_poly_eval: "poly (poly_of_pm x p) a = poly_eval (\<lambda>y. a when y = x) p"
proof (induction p rule: poly_mapping_plus_induct)
  case 1
  show ?case by simp
next
  case (2 p c t)
  show ?case
  proof (cases "t \<in> .[{x}]")
    case True
    have "poly_eval (\<lambda>y. a when y = x) (monomial c t) = c * (\<Prod>y\<in>keys t. (a when y = x) ^ lookup t y)"
      by (simp only: poly_eval_monomial)
    also from True have "(\<Prod>y\<in>keys t. (a when y = x) ^ lookup t y) = (\<Prod>y\<in>{x}. (a when y = x) ^ lookup t y)"
      by (intro prod.mono_neutral_left ballI) (auto simp: in_keys_iff dest: PPsD)
    also have "\<dots> = a ^ lookup t x" by simp
    finally show ?thesis
      by (simp add: poly_of_pm_plus poly_of_pm_monomial poly_monom poly_eval_plus True 2(3))
  next
    case False
    have "poly_eval (\<lambda>y. a when y = x) (monomial c t) = c * (\<Prod>y\<in>keys t. (a when y = x) ^ lookup t y)"
      by (simp only: poly_eval_monomial)
    also from finite_keys have "(\<Prod>y\<in>keys t. (a when y = x) ^ lookup t y) = 0"
    proof (rule prod_zero)
      from False obtain y where "y \<in> keys t" and "y \<noteq> x" by (auto simp: PPs_def)
      from this(1) show "\<exists>y\<in>keys t. (a when y = x) ^ lookup t y = 0"
      proof
        from \<open>y \<in> keys t\<close> have "0 < lookup t y" by (simp add: in_keys_iff)
        with \<open>y \<noteq> x\<close> show "(a when y = x) ^ lookup t y = 0" by (simp add: zero_power)
      qed
    qed
    finally show ?thesis
      by (simp add: poly_of_pm_plus poly_of_pm_monomial poly_monom poly_eval_plus False 2(3))
  qed
qed

corollary poly_eq_poly_eval':
  assumes "p \<in> P[{x}]"
  shows "poly (poly_of_pm x p) a = poly_eval (\<lambda>_. a) p"
  unfolding poly_eq_poly_eval using refl
proof (rule poly_eval_cong)
  fix y
  assume "y \<in> indets p"
  also from assms have "\<dots> \<subseteq> {x}" by (rule PolysD)
  finally show "(a when y = x) = a" by simp
qed

lemma poly_eval_eq_poly: "poly_eval a (pm_of_poly x p) = poly p (a x)"
  by (induct p)
    (simp_all add: pm_of_poly_pCons poly_eval_plus poly_eval_times poly_eval_monomial
              flip: times_monomial_left)

subsection \<open>Morphisms \<open>flat_pm_of_poly\<close> and \<open>poly_of_focus\<close>\<close>

definition flat_pm_of_poly :: "'x \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) poly \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::semiring_1)"
  where "flat_pm_of_poly x = flatten \<circ> pm_of_poly x"

definition poly_of_focus :: "'x \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a) \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_monoid_add) poly"
  where "poly_of_focus x = poly_of_pm x \<circ> focus {x}"

lemma flat_pm_of_poly_in_Polys:
  assumes "range (poly.coeff p) \<subseteq> P[Y]"
  shows "flat_pm_of_poly x p \<in> P[insert x Y]"
proof -
  let ?p = "pm_of_poly x p"
  from assms have "lookup ?p ` keys ?p \<subseteq> P[Y]" by (simp add: keys_pm_of_poly image_image) blast
  with pm_of_poly_in_Polys have "flatten ?p \<in> P[{x} \<union> Y]" by (rule flatten_in_Polys)
  thus ?thesis by (simp add: flat_pm_of_poly_def)
qed

corollary indets_flat_pm_of_poly_subset:
  "indets (flat_pm_of_poly x p) \<subseteq> insert x (\<Union> (indets ` range (poly.coeff p)))"
proof -
  let ?p = "pm_of_poly x p"
  let ?Y = "\<Union> (indets ` range (poly.coeff p))"
  have "range (poly.coeff p) \<subseteq> P[?Y]" by (auto intro: PolysI_alt)
  hence "flat_pm_of_poly x p \<in> P[insert x ?Y]" by (rule flat_pm_of_poly_in_Polys)
  thus ?thesis by (rule PolysD)
qed

lemma
  shows flat_pm_of_poly_zero [simp]: "flat_pm_of_poly x 0 = 0"
    and flat_pm_of_poly_monom: "flat_pm_of_poly x (Polynomial.monom c d) =
                                    punit.monom_mult 1 (Poly_Mapping.single x d) c"
    and flat_pm_of_poly_plus: "flat_pm_of_poly x (p + q) =
                                  flat_pm_of_poly x p + flat_pm_of_poly x q"
    and flat_pm_of_poly_one [simp]: "flat_pm_of_poly x 1 = 1"
    and flat_pm_of_poly_sum: "flat_pm_of_poly x (sum f I) = (\<Sum>i\<in>I. flat_pm_of_poly x (f i))"
  by (simp_all add: flat_pm_of_poly_def pm_of_poly_monom flatten_monomial pm_of_poly_plus
                    flatten_plus pm_of_poly_sum flatten_sum)

lemma
  shows flat_pm_of_poly_uminus [simp]: "flat_pm_of_poly x (- p) = - flat_pm_of_poly x p"
    and flat_pm_of_poly_minus: "flat_pm_of_poly x (p - q) =
                                  flat_pm_of_poly x p - flat_pm_of_poly x (q::_::ring poly)"
  by (simp_all add: flat_pm_of_poly_def pm_of_poly_minus flatten_minus)

lemma flat_pm_of_poly_pCons:
  "flat_pm_of_poly x (pCons c p) =
    c + punit.monom_mult 1 (Poly_Mapping.single x 1) (flat_pm_of_poly x (p::_::comm_semiring_1 poly))"
  by (simp add: flat_pm_of_poly_def pm_of_poly_pCons flatten_plus flatten_monomial flatten_times
          flip: times_monomial_left)

lemma flat_pm_of_poly_smult [simp]:
  "flat_pm_of_poly x (Polynomial.smult c p) = c * flat_pm_of_poly x (p::_::comm_semiring_1 poly)"
  by (simp add: flat_pm_of_poly_def map_scale_eq_times flatten_times flatten_monomial pm_of_poly_times)

lemma
  shows flat_pm_of_poly_times: "flat_pm_of_poly x (p * q) = flat_pm_of_poly x p * flat_pm_of_poly x q"
    and flat_pm_of_poly_prod: "flat_pm_of_poly x (prod f I) =
                                  (\<Prod>i\<in>I. flat_pm_of_poly x (f i :: _::comm_ring_1 poly))"
    and flat_pm_of_poly_power: "flat_pm_of_poly x (p ^ m) = flat_pm_of_poly x (p::_::comm_ring_1 poly) ^ m"
  by (simp_all add: flat_pm_of_poly_def flatten_times pm_of_poly_times flatten_prod pm_of_poly_prod)

lemma coeff_poly_of_focus_subset_Polys:
  assumes "p \<in> P[X]"
  shows "range (poly.coeff (poly_of_focus x p)) \<subseteq> P[X - {x}]"
proof -
  have "range (poly.coeff (poly_of_focus x p)) \<subseteq> range (lookup (focus {x} p))"
    by (auto simp: poly_of_focus_def)
  also from assms have "\<dots> \<subseteq> P[X - {x}]" by (rule focus_coeffs_subset_Polys')
  finally show ?thesis .
qed

lemma
  shows poly_of_focus_zero [simp]: "poly_of_focus x 0 = 0"
    and poly_of_focus_uminus [simp]: "poly_of_focus x (- p) = - poly_of_focus x p"
    and poly_of_focus_plus: "poly_of_focus x (p + q) = poly_of_focus x p + poly_of_focus x q"
    and poly_of_focus_minus: "poly_of_focus x (p - q) = poly_of_focus x p - poly_of_focus x q"
    and poly_of_focus_one [simp]: "poly_of_focus x 1 = 1"
    and poly_of_focus_sum: "poly_of_focus x (sum f I) = (\<Sum>i\<in>I. poly_of_focus x (f i))"
  by (simp_all add: poly_of_focus_def keys_focus poly_of_pm_plus focus_plus poly_of_pm_minus focus_minus
                    poly_of_pm_sum focus_sum)

lemma poly_of_focus_eq_zero_iff [iff]: "poly_of_focus x p = 0 \<longleftrightarrow> p = 0"
  using focus_in_Polys[of "{x}" p]
  by (auto simp: poly_of_focus_def poly_of_pm_eq_zero_iff Int_absorb2 dest: PolysD)

lemma poly_of_focus_monomial:
  "poly_of_focus x (monomial c t) = Polynomial.monom (monomial c (except t {x})) (lookup t x)"
  by (simp add: poly_of_focus_def focus_monomial poly_of_pm_monomial PPs_def keys_except lookup_except)

lemma
  shows poly_of_focus_times: "poly_of_focus x (p * q) = poly_of_focus x p * poly_of_focus x q"
    and poly_of_focus_prod: "poly_of_focus x (prod f I) =
                                  (\<Prod>i\<in>I. poly_of_focus x (f i :: _ \<Rightarrow>\<^sub>0 _::comm_semiring_1))"
    and poly_of_focus_power: "poly_of_focus x (p ^ m) = poly_of_focus x (p::_ \<Rightarrow>\<^sub>0 _::comm_semiring_1) ^ m"
  by (simp_all add: poly_of_focus_def poly_of_pm_times focus_times poly_of_pm_prod focus_prod)

lemma flat_pm_of_poly_of_focus [simp]: "flat_pm_of_poly x (poly_of_focus x p) = p"
  by (simp add: flat_pm_of_poly_def poly_of_focus_def pm_of_poly_of_pm focus_in_Polys)

lemma poly_of_focus_flat_pm_of_poly:
  assumes "range (poly.coeff p) \<subseteq> P[- {x}]"
  shows "poly_of_focus x (flat_pm_of_poly x p) = p"
proof -
  from assms have "lookup (pm_of_poly x p) ` keys (pm_of_poly x p) \<subseteq> P[- {x}]"
    by (simp add: keys_pm_of_poly image_image) blast
  thus ?thesis by (simp add: flat_pm_of_poly_def poly_of_focus_def focus_flatten pm_of_poly_in_Polys)
qed

lemma flat_pm_of_poly_eq_zeroD:
  assumes "flat_pm_of_poly x p = 0" and "range (poly.coeff p) \<subseteq> P[- {x}]"
  shows "p = 0"
proof -
  from assms(2) have "p = poly_of_focus x (flat_pm_of_poly x p)"
    by (simp only: poly_of_focus_flat_pm_of_poly)
  also have "\<dots> = 0" by (simp add: assms(1))
  finally show ?thesis .
qed

lemma poly_poly_of_focus: "poly (poly_of_focus x p) a = poly_eval (\<lambda>_. a) (focus {x} p)"
  by (simp add: poly_of_focus_def poly_eq_poly_eval' focus_in_Polys)

corollary poly_poly_of_focus_monomial:
  "poly (poly_of_focus x p) (monomial 1 (Poly_Mapping.single x 1)) = (p::_ \<Rightarrow>\<^sub>0 _::comm_semiring_1)"
  unfolding poly_poly_of_focus poly_eval_focus by (rule poly_subst_id) simp

end (* theory *)


theory Lexer
  imports Spec
begin

section {* The Lexer Functions by Sulzmann and Lu  *}

fun
  mkeps :: "rexp \<Rightarrow> val"
where
  "mkeps(ONE) = Void"
| "mkeps(SEQ r1 r2) = Seq (mkeps r1) (mkeps r2)"
| "mkeps(ALT r1 r2) = (if nullable(r1) then Left (mkeps r1) else Right (mkeps r2))"
| "mkeps(STAR r) = Stars []"

fun injval :: "rexp \<Rightarrow> char \<Rightarrow> val \<Rightarrow> val"
where
  "injval (CR d) c Void = Char d"
| "injval (ALT r1 r2) c (Left v1) = Left(injval r1 c v1)"
| "injval (ALT r1 r2) c (Right v2) = Right(injval r2 c v2)"
| "injval (SEQ r1 r2) c (Seq v1 v2) = Seq (injval r1 c v1) v2"
| "injval (SEQ r1 r2) c (Left (Seq v1 v2)) = Seq (injval r1 c v1) v2"
| "injval (SEQ r1 r2) c (Right v2) = Seq (mkeps r1) (injval r2 c v2)"
| "injval (STAR r) c (Seq v (Stars vs)) = Stars ((injval r c v) # vs)"

fun
  lexer :: "rexp \<Rightarrow> string \<Rightarrow> val option"
where
  "lexer r [] = (if nullable r then Some(mkeps r) else None)"
| "lexer r (c#s) = (case (lexer (der c r) s) of
                    None \<Rightarrow> None
                  | Some(v) \<Rightarrow> Some(injval r c v))"

section {* Mkeps, Injval Properties *}

lemma mkeps_nullable:
  assumes "nullable(r)"
  shows "\<Turnstile> mkeps r : r"
using assms
by (induct rule: nullable.induct)
   (auto intro: Prf.intros)

lemma mkeps_flat:
  assumes "nullable(r)"
  shows "flat (mkeps r) = []"
using assms
by (induct rule: nullable.induct) (auto)

lemma Prf_injval_flat:
  assumes "\<Turnstile> v : der c r"
  shows "flat (injval r c v) = c # (flat v)"
using assms
apply(induct c r arbitrary: v rule: der.induct)
apply(auto elim!: Prf_elims intro: mkeps_flat split: if_splits)
done

lemma Prf_injval:
  assumes "\<Turnstile> v : der c r"
  shows "\<Turnstile> (injval r c v) : r"
using assms
apply(induct r arbitrary: c v rule: rexp.induct)
apply(auto intro!: Prf.intros mkeps_nullable elim!: Prf_elims split: if_splits)
apply(simp add: Prf_injval_flat)
done

text {*
  Mkeps and injval produce, or preserve, Posix values.
*}

lemma Posix_mkeps:
  assumes "nullable r"
  shows "[] \<in> r \<rightarrow> mkeps r"
using assms
apply(induct r rule: nullable.induct)
apply(auto intro: Posix.intros simp add: nullable_correctness Sequ_def)
apply(subst append.simps(1)[symmetric])
apply(rule Posix.intros)
apply(auto)
done

lemma Posix_injval:
  assumes "s \<in> (der c r) \<rightarrow> v"
  shows "(c # s) \<in> r \<rightarrow> (injval r c v)"
using assms
proof(induct r arbitrary: s v rule: rexp.induct)
  case ZERO
  have "s \<in> der c ZERO \<rightarrow> v" by fact
  then have "s \<in> ZERO \<rightarrow> v" by simp
  then have "False" by cases
  then show "(c # s) \<in> ZERO \<rightarrow> (injval ZERO c v)" by simp
next
  case ONE
  have "s \<in> der c ONE \<rightarrow> v" by fact
  then have "s \<in> ZERO \<rightarrow> v" by simp
  then have "False" by cases
  then show "(c # s) \<in> ONE \<rightarrow> (injval ONE c v)" by simp
next
  case (CR d)
  consider (eq) "c = d" | (ineq) "c \<noteq> d" by blast
  then show "(c # s) \<in> (CR d) \<rightarrow> (injval (CR d) c v)"
  proof (cases)
    case eq
    have "s \<in> der c (CR d) \<rightarrow> v" by fact
    then have "s \<in> ONE \<rightarrow> v" using eq by simp
    then have eqs: "s = [] \<and> v = Void" by cases simp
    show "(c # s) \<in> CR d \<rightarrow> injval (CR d) c v" using eq eqs
    by (auto intro: Posix.intros)
  next
    case ineq
    have "s \<in> der c (CR d) \<rightarrow> v" by fact
    then have "s \<in> ZERO \<rightarrow> v" using ineq by simp
    then have "False" by cases
    then show "(c # s) \<in> CR d \<rightarrow> injval (CR d) c v" by simp
  qed
next
  case (ALT r1 r2)
  have IH1: "\<And>s v. s \<in> der c r1 \<rightarrow> v \<Longrightarrow> (c # s) \<in> r1 \<rightarrow> injval r1 c v" by fact
  have IH2: "\<And>s v. s \<in> der c r2 \<rightarrow> v \<Longrightarrow> (c # s) \<in> r2 \<rightarrow> injval r2 c v" by fact
  have "s \<in> der c (ALT r1 r2) \<rightarrow> v" by fact
  then have "s \<in> ALT (der c r1) (der c r2) \<rightarrow> v" by simp
  then consider (left) v' where "v = Left v'" "s \<in> der c r1 \<rightarrow> v'"
              | (right) v' where "v = Right v'" "s \<notin> L (der c r1)" "s \<in> der c r2 \<rightarrow> v'"
              by cases auto
  then show "(c # s) \<in> ALT r1 r2 \<rightarrow> injval (ALT r1 r2) c v"
  proof (cases)
    case left
    have "s \<in> der c r1 \<rightarrow> v'" by fact
    then have "(c # s) \<in> r1 \<rightarrow> injval r1 c v'" using IH1 by simp
    then have "(c # s) \<in> ALT r1 r2 \<rightarrow> injval (ALT r1 r2) c (Left v')" by (auto intro: Posix.intros)
    then show "(c # s) \<in> ALT r1 r2 \<rightarrow> injval (ALT r1 r2) c v" using left by simp
  next
    case right
    have "s \<notin> L (der c r1)" by fact
    then have "c # s \<notin> L r1" by (simp add: der_correctness Der_def)
    moreover
    have "s \<in> der c r2 \<rightarrow> v'" by fact
    then have "(c # s) \<in> r2 \<rightarrow> injval r2 c v'" using IH2 by simp
    ultimately have "(c # s) \<in> ALT r1 r2 \<rightarrow> injval (ALT r1 r2) c (Right v')"
      by (auto intro: Posix.intros)
    then show "(c # s) \<in> ALT r1 r2 \<rightarrow> injval (ALT r1 r2) c v" using right by simp
  qed
next
  case (SEQ r1 r2)
  have IH1: "\<And>s v. s \<in> der c r1 \<rightarrow> v \<Longrightarrow> (c # s) \<in> r1 \<rightarrow> injval r1 c v" by fact
  have IH2: "\<And>s v. s \<in> der c r2 \<rightarrow> v \<Longrightarrow> (c # s) \<in> r2 \<rightarrow> injval r2 c v" by fact
  have "s \<in> der c (SEQ r1 r2) \<rightarrow> v" by fact
  then consider
        (left_nullable) v1 v2 s1 s2 where
        "v = Left (Seq v1 v2)"  "s = s1 @ s2"
        "s1 \<in> der c r1 \<rightarrow> v1" "s2 \<in> r2 \<rightarrow> v2" "nullable r1"
        "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L (der c r1) \<and> s\<^sub>4 \<in> L r2)"
      | (right_nullable) v1 s1 s2 where
        "v = Right v1" "s = s1 @ s2"
        "s \<in> der c r2 \<rightarrow> v1" "nullable r1" "s1 @ s2 \<notin> L (SEQ (der c r1) r2)"
      | (not_nullable) v1 v2 s1 s2 where
        "v = Seq v1 v2" "s = s1 @ s2"
        "s1 \<in> der c r1 \<rightarrow> v1" "s2 \<in> r2 \<rightarrow> v2" "\<not>nullable r1"
        "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L (der c r1) \<and> s\<^sub>4 \<in> L r2)"
        by (force split: if_splits elim!: Posix_elims simp add: Sequ_def der_correctness Der_def)
  then show "(c # s) \<in> SEQ r1 r2 \<rightarrow> injval (SEQ r1 r2) c v"
    proof (cases)
      case left_nullable
      have "s1 \<in> der c r1 \<rightarrow> v1" by fact
      then have "(c # s1) \<in> r1 \<rightarrow> injval r1 c v1" using IH1 by simp
      moreover
      have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L (der c r1) \<and> s\<^sub>4 \<in> L r2)" by fact
      then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (c # s1) @ s\<^sub>3 \<in> L r1 \<and> s\<^sub>4 \<in> L r2)" by (simp add: der_correctness Der_def)
      ultimately have "((c # s1) @ s2) \<in> SEQ r1 r2 \<rightarrow> Seq (injval r1 c v1) v2" using left_nullable by (rule_tac Posix.intros)
      then show "(c # s) \<in> SEQ r1 r2 \<rightarrow> injval (SEQ r1 r2) c v" using left_nullable by simp
    next
      case right_nullable
      have "nullable r1" by fact
      then have "[] \<in> r1 \<rightarrow> (mkeps r1)" by (rule Posix_mkeps)
      moreover
      have "s \<in> der c r2 \<rightarrow> v1" by fact
      then have "(c # s) \<in> r2 \<rightarrow> (injval r2 c v1)" using IH2 by simp
      moreover
      have "s1 @ s2 \<notin> L (SEQ (der c r1) r2)" by fact
      then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = c # s \<and> [] @ s\<^sub>3 \<in> L r1 \<and> s\<^sub>4 \<in> L r2)" using right_nullable
        by(auto simp add: der_correctness Der_def append_eq_Cons_conv Sequ_def)
      ultimately have "([] @ (c # s)) \<in> SEQ r1 r2 \<rightarrow> Seq (mkeps r1) (injval r2 c v1)"
      by(rule Posix.intros)
      then show "(c # s) \<in> SEQ r1 r2 \<rightarrow> injval (SEQ r1 r2) c v" using right_nullable by simp
    next
      case not_nullable
      have "s1 \<in> der c r1 \<rightarrow> v1" by fact
      then have "(c # s1) \<in> r1 \<rightarrow> injval r1 c v1" using IH1 by simp
      moreover
      have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L (der c r1) \<and> s\<^sub>4 \<in> L r2)" by fact
      then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (c # s1) @ s\<^sub>3 \<in> L r1 \<and> s\<^sub>4 \<in> L r2)" by (simp add: der_correctness Der_def)
      ultimately have "((c # s1) @ s2) \<in> SEQ r1 r2 \<rightarrow> Seq (injval r1 c v1) v2" using not_nullable
        by (rule_tac Posix.intros) (simp_all)
      then show "(c # s) \<in> SEQ r1 r2 \<rightarrow> injval (SEQ r1 r2) c v" using not_nullable by simp
    qed
next
  case (STAR r)
  have IH: "\<And>s v. s \<in> der c r \<rightarrow> v \<Longrightarrow> (c # s) \<in> r \<rightarrow> injval r c v" by fact
  have "s \<in> der c (STAR r) \<rightarrow> v" by fact
  then consider
      (cons) v1 vs s1 s2 where
        "v = Seq v1 (Stars vs)" "s = s1 @ s2"
        "s1 \<in> der c r \<rightarrow> v1" "s2 \<in> (STAR r) \<rightarrow> (Stars vs)"
        "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L (der c r) \<and> s\<^sub>4 \<in> L (STAR r))"
        apply(auto elim!: Posix_elims(1-5) simp add: der_correctness Der_def intro: Posix.intros)
        apply(rotate_tac 3)
        apply(erule_tac Posix_elims(6))
        apply (simp add: Posix.intros(6))
        using Posix.intros(7) by blast
    then show "(c # s) \<in> STAR r \<rightarrow> injval (STAR r) c v"
    proof (cases)
      case cons
          have "s1 \<in> der c r \<rightarrow> v1" by fact
          then have "(c # s1) \<in> r \<rightarrow> injval r c v1" using IH by simp
        moreover
          have "s2 \<in> STAR r \<rightarrow> Stars vs" by fact
        moreover
          have "(c # s1) \<in> r \<rightarrow> injval r c v1" by fact
          then have "flat (injval r c v1) = (c # s1)" by (rule Posix1)
          then have "flat (injval r c v1) \<noteq> []" by simp
        moreover
          have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> s1 @ s\<^sub>3 \<in> L (der c r) \<and> s\<^sub>4 \<in> L (STAR r))" by fact
          then have "\<not> (\<exists>s\<^sub>3 s\<^sub>4. s\<^sub>3 \<noteq> [] \<and> s\<^sub>3 @ s\<^sub>4 = s2 \<and> (c # s1) @ s\<^sub>3 \<in> L r \<and> s\<^sub>4 \<in> L (STAR r))"
            by (simp add: der_correctness Der_def)
        ultimately
        have "((c # s1) @ s2) \<in> STAR r \<rightarrow> Stars (injval r c v1 # vs)" by (rule Posix.intros)
        then show "(c # s) \<in> STAR r \<rightarrow> injval (STAR r) c v" using cons by(simp)
    qed
qed

section {* Lexer Correctness *}

lemma lexer_correct_None:
  shows "s \<notin> L r \<longleftrightarrow> lexer r s = None"
  apply(induct s arbitrary: r)
  apply(simp)
  apply(simp add: nullable_correctness)
  apply(simp)
  apply(drule_tac x="der a r" in meta_spec)
  apply(auto)
  apply(auto simp add: der_correctness Der_def)
done

lemma lexer_correct_Some:
  shows "s \<in> L r \<longleftrightarrow> (\<exists>v. lexer r s = Some(v) \<and> s \<in> r \<rightarrow> v)"
  apply(induct s arbitrary : r)
  apply(simp only: lexer.simps)
  apply(simp)
  apply(simp add: nullable_correctness Posix_mkeps)
  apply(drule_tac x="der a r" in meta_spec)
  apply(simp (no_asm_use) add: der_correctness Der_def del: lexer.simps)
  apply(simp del: lexer.simps)
  apply(simp only: lexer.simps)
  apply(case_tac "lexer (der a r) s = None")
   apply(auto)[1]
  apply(simp)
  apply(erule exE)
  apply(simp)
  apply(rule iffI)
  apply(simp add: Posix_injval)
  apply(simp add: Posix1(1))
done

lemma lexer_correctness:
  shows "(lexer r s = Some v) \<longleftrightarrow> s \<in> r \<rightarrow> v"
  and   "(lexer r s = None) \<longleftrightarrow> \<not>(\<exists>v. s \<in> r \<rightarrow> v)"
using Posix1(1) Posix_determ lexer_correct_None lexer_correct_Some apply fastforce
using Posix1(1) lexer_correct_None lexer_correct_Some by blast

fun flex :: "rexp \<Rightarrow> (val \<Rightarrow> val) => string \<Rightarrow> (val \<Rightarrow> val)"
  where
  "flex r f [] = f"
| "flex r f (c#s) = flex (der c r) (\<lambda>v. f (injval r c v)) s"

lemma flex_fun_apply:
  shows "g (flex r f s v) = flex r (g o f) s v"
  apply(induct s arbitrary: g f r v)
  apply(simp_all add: comp_def)
  by meson

lemma flex_append:
  shows "flex r f (s1 @ s2) = flex (ders s1 r) (flex r f s1) s2"
  apply(induct s1 arbitrary: s2 r f)
  apply(simp_all)
  done

lemma lexer_flex:
  shows "lexer r s = (if nullable (ders s r)
                      then Some(flex r id s (mkeps (ders s r))) else None)"
  apply(induct s arbitrary: r)
  apply(simp_all add: flex_fun_apply)
  done

unused_thms

end


(*  Title:      HOL/ex/Transfer_Int_Nat.thy
    Author:     Brian Huffman, TU Muenchen
*)

section {* Using the transfer method between nat and int *}

theory Transfer_Int_Nat
imports GCD
begin

subsection {* Correspondence relation *}

definition ZN :: "int \<Rightarrow> nat \<Rightarrow> bool"
  where "ZN = (\<lambda>z n. z = of_nat n)"

subsection {* Transfer domain rules *}

lemma Domainp_ZN [transfer_domain_rule]: "Domainp ZN = (\<lambda>x. x \<ge> 0)"
  unfolding ZN_def Domainp_iff[abs_def] by (auto intro: zero_le_imp_eq_int)

subsection {* Transfer rules *}

context
begin
interpretation lifting_syntax .

lemma bi_unique_ZN [transfer_rule]: "bi_unique ZN"
  unfolding ZN_def bi_unique_def by simp

lemma right_total_ZN [transfer_rule]: "right_total ZN"
  unfolding ZN_def right_total_def by simp

lemma ZN_0 [transfer_rule]: "ZN 0 0"
  unfolding ZN_def by simp

lemma ZN_1 [transfer_rule]: "ZN 1 1"
  unfolding ZN_def by simp

lemma ZN_add [transfer_rule]: "(ZN ===> ZN ===> ZN) (op +) (op +)"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_mult [transfer_rule]: "(ZN ===> ZN ===> ZN) (op *) (op *)"
  unfolding rel_fun_def ZN_def by (simp add: int_mult)

lemma ZN_diff [transfer_rule]: "(ZN ===> ZN ===> ZN) tsub (op -)"
  unfolding rel_fun_def ZN_def tsub_def by (simp add: zdiff_int)

lemma ZN_power [transfer_rule]: "(ZN ===> op = ===> ZN) (op ^) (op ^)"
  unfolding rel_fun_def ZN_def by (simp add: int_power)

lemma ZN_nat_id [transfer_rule]: "(ZN ===> op =) nat id"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_id_int [transfer_rule]: "(ZN ===> op =) id int"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_All [transfer_rule]:
  "((ZN ===> op =) ===> op =) (Ball {0..}) All"
  unfolding rel_fun_def ZN_def by (auto dest: zero_le_imp_eq_int)

lemma ZN_transfer_forall [transfer_rule]:
  "((ZN ===> op =) ===> op =) (transfer_bforall (\<lambda>x. 0 \<le> x)) transfer_forall"
  unfolding transfer_forall_def transfer_bforall_def
  unfolding rel_fun_def ZN_def by (auto dest: zero_le_imp_eq_int)

lemma ZN_Ex [transfer_rule]: "((ZN ===> op =) ===> op =) (Bex {0..}) Ex"
  unfolding rel_fun_def ZN_def Bex_def atLeast_iff
  by (metis zero_le_imp_eq_int zero_zle_int)

lemma ZN_le [transfer_rule]: "(ZN ===> ZN ===> op =) (op \<le>) (op \<le>)"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_less [transfer_rule]: "(ZN ===> ZN ===> op =) (op <) (op <)"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_eq [transfer_rule]: "(ZN ===> ZN ===> op =) (op =) (op =)"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_Suc [transfer_rule]: "(ZN ===> ZN) (\<lambda>x. x + 1) Suc"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_numeral [transfer_rule]:
  "(op = ===> ZN) numeral numeral"
  unfolding rel_fun_def ZN_def by simp

lemma ZN_dvd [transfer_rule]: "(ZN ===> ZN ===> op =) (op dvd) (op dvd)"
  unfolding rel_fun_def ZN_def by (simp add: zdvd_int)

lemma ZN_div [transfer_rule]: "(ZN ===> ZN ===> ZN) (op div) (op div)"
  unfolding rel_fun_def ZN_def by (simp add: zdiv_int)

lemma ZN_mod [transfer_rule]: "(ZN ===> ZN ===> ZN) (op mod) (op mod)"
  unfolding rel_fun_def ZN_def by (simp add: zmod_int)

lemma ZN_gcd [transfer_rule]: "(ZN ===> ZN ===> ZN) gcd gcd"
  unfolding rel_fun_def ZN_def by (simp add: transfer_int_nat_gcd)

lemma ZN_atMost [transfer_rule]:
  "(ZN ===> rel_set ZN) (atLeastAtMost 0) atMost"
  unfolding rel_fun_def ZN_def rel_set_def
  by (clarsimp simp add: Bex_def, arith)

lemma ZN_atLeastAtMost [transfer_rule]:
  "(ZN ===> ZN ===> rel_set ZN) atLeastAtMost atLeastAtMost"
  unfolding rel_fun_def ZN_def rel_set_def
  by (clarsimp simp add: Bex_def, arith)

lemma ZN_setsum [transfer_rule]:
  "bi_unique A \<Longrightarrow> ((A ===> ZN) ===> rel_set A ===> ZN) setsum setsum"
  apply (intro rel_funI)
  apply (erule (1) bi_unique_rel_set_lemma)
  apply (simp add: setsum.reindex int_setsum ZN_def rel_fun_def)
  apply (rule setsum.cong)
  apply simp_all
  done

text {* For derived operations, we can use the @{text "transfer_prover"}
  method to help generate transfer rules. *}

lemma ZN_listsum [transfer_rule]: "(list_all2 ZN ===> ZN) listsum listsum"
  by transfer_prover

end

subsection {* Transfer examples *}

lemma
  assumes "\<And>i::int. 0 \<le> i \<Longrightarrow> i + 0 = i"
  shows "\<And>i::nat. i + 0 = i"
apply transfer
apply fact
done

lemma
  assumes "\<And>i k::int. \<lbrakk>0 \<le> i; 0 \<le> k; i < k\<rbrakk> \<Longrightarrow> \<exists>j\<in>{0..}. i + j = k"
  shows "\<And>i k::nat. i < k \<Longrightarrow> \<exists>j. i + j = k"
apply transfer
apply fact
done

lemma
  assumes "\<forall>x\<in>{0::int..}. \<forall>y\<in>{0..}. x * y div y = x"
  shows "\<forall>x y :: nat. x * y div y = x"
apply transfer
apply fact
done

lemma
  assumes "\<And>m n::int. \<lbrakk>0 \<le> m; 0 \<le> n; m * n = 0\<rbrakk> \<Longrightarrow> m = 0 \<or> n = 0"
  shows "m * n = (0::nat) \<Longrightarrow> m = 0 \<or> n = 0"
apply transfer
apply fact
done

lemma
  assumes "\<forall>x\<in>{0::int..}. \<exists>y\<in>{0..}. \<exists>z\<in>{0..}. x + 3 * y = 5 * z"
  shows "\<forall>x::nat. \<exists>y z. x + 3 * y = 5 * z"
apply transfer
apply fact
done

text {* The @{text "fixing"} option prevents generalization over the free
  variable @{text "n"}, allowing the local transfer rule to be used. *}

lemma
  assumes [transfer_rule]: "ZN x n"
  assumes "\<forall>i\<in>{0..}. i < x \<longrightarrow> 2 * i < 3 * x"
  shows "\<forall>i. i < n \<longrightarrow> 2 * i < 3 * n"
apply (transfer fixing: n)
apply fact
done

lemma
  assumes "gcd (2^i) (3^j) = (1::int)"
  shows "gcd (2^i) (3^j) = (1::nat)"
apply (transfer fixing: i j)
apply fact
done

lemma
  assumes "\<And>x y z::int. \<lbrakk>0 \<le> x; 0 \<le> y; 0 \<le> z\<rbrakk> \<Longrightarrow>
    listsum [x, y, z] = 0 \<longleftrightarrow> list_all (\<lambda>x. x = 0) [x, y, z]"
  shows "listsum [x, y, z] = (0::nat) \<longleftrightarrow> list_all (\<lambda>x. x = 0) [x, y, z]"
apply transfer
apply fact
done

text {* Quantifiers over higher types (e.g. @{text "nat list"}) are
  transferred to a readable formula thanks to the transfer domain rule @{thm Domainp_ZN} *}

lemma
  assumes "\<And>xs::int list. list_all (\<lambda>x. x \<ge> 0) xs \<Longrightarrow>
    (listsum xs = 0) = list_all (\<lambda>x. x = 0) xs"
  shows "listsum xs = (0::nat) \<longleftrightarrow> list_all (\<lambda>x. x = 0) xs"
apply transfer
apply fact
done

text {* Equality on a higher type can be transferred if the relations
  involved are bi-unique. *}

lemma
  assumes "\<And>xs\<Colon>int list. \<lbrakk>list_all (\<lambda>x. x \<ge> 0) xs; xs \<noteq> []\<rbrakk> \<Longrightarrow>
    listsum xs < listsum (map (\<lambda>x. x + 1) xs)"
  shows "xs \<noteq> [] \<Longrightarrow> listsum xs < listsum (map Suc xs)"
apply transfer
apply fact
done

end


section \<open>Coinductive lists\<close>

theory MoreCoinductiveList2
  imports Parity_Game.MoreCoinductiveList (* for notation and lemmas like infinite_small_llength *)
begin

lemma ltake_infinity[simp]: "ltake \<infinity> x = x" by (simp add: ltake_all)

lemma coinductive_eq_iff_lnth_eq:
  "a = b \<longleftrightarrow> (llength a = llength b \<and> (\<forall> n. enat n < llength a \<longrightarrow> a $ n = b $ n))"
proof
  assume "llength a = llength b \<and> (\<forall>n. enat n < llength a \<longrightarrow> a $ n = b $ n)"
  hence len:"llength a = llength b"
    and lnth:"enat n < llength a \<Longrightarrow> a $ n = b $ n" for n by auto
  show "a = b" proof(cases "llength a")
    case (enat nat)
    hence leq:"llist_of (list_of (ltake nat a)) = a" "llist_of (list_of (ltake nat b)) = b"
      by (auto simp add: len llength_eq_enat_lfiniteD ltake_all)
    with lnth_llist_of lnth
    have [intro]:"i < length (list_of (ltake (enat nat) a)) \<Longrightarrow> ltake (enat nat) a $ i = ltake (enat nat) b $ i" for i
      by (metis enat_ord_code(4) enat_ord_simps(2) lfinite_ltake llength_llist_of llist_of_list_of)
    from len have [intro]:"length (list_of (ltake (enat nat) a)) = length (list_of (ltake (enat nat) b))"
      by (simp add: length_list_of_conv_the_enat)
    have "list_of (ltake nat a) = list_of (ltake nat b)" by(subst list_eq_iff_nth_eq, auto)
    then show ?thesis using leq by metis
  next
    case infinity
    hence inf:"\<not> lfinite a" "\<not> lfinite b" using len llength_eq_infty_conv_lfinite by auto
    from lnth[unfolded infinity] have "(($) a) = (($) b)" by auto
    then show ?thesis using inf[THEN inf_llist_lnth] by metis
  qed
qed auto

lemma coinductive_eq_I:
  assumes "(llength a = llength b \<and> (\<forall> n. enat n < llength a \<longrightarrow> a $ n = b $ n))"
  shows "a = b"
  using coinductive_eq_iff_lnth_eq assms by auto
text \<open>Our co-inductive lists will have Option types in them, so we can return None for out of bounds.\<close>
definition lnth_option where
  "lnth_option xs i \<equiv> if enat i < llength xs then xs $ i else None"

lemma enat_times_less:
  "enat c * enat lst < y * enat c \<Longrightarrow> lst < y"
by (cases y;auto)

lemma llist_eq_lcons:
  assumes "a \<noteq> LNil" "b \<noteq> LNil" "lhd a = lhd b" "ltl a = ltl b"
  shows "a = b"
using assms by(cases a;cases b;auto)

end


section \<open> Programs with memory \<close>

theory utp_mem_prog
  imports utp_mem_prelim
begin

text \<open> Heap allocation takes a lens $x$ within the store that holds an address, and an expression
  $e$ over store variables whose return type is countable. The semantics of allocation selects
  an arbitrary memory location not currently allocated in the heap, places the said address
  in $x$, and injects the expression $e$ into the heap at this memory location. \<close>

definition
  heap_alloc :: "(addr \<Longrightarrow> 's) \<Rightarrow> ('a::{countable,infinite}, 's) uexpr \<Rightarrow> 's mprog"
  ("_ := alloc'(_')" [74,0] 75)
  where [upred_defs, ndes_simp]:
    "x := alloc(e) =
     (true \<turnstile>\<^sub>n (\<Sqinter> l \<bullet> ?[\<guillemotleft>l\<guillemotright> \<notin> dom(hp)] ;; str:x := \<guillemotleft>l\<guillemotright> ;; hp := &hp(&str:x \<mapsto> uop to_nat_bij (e \<oplus>\<^sub>p str))\<^sub>u))"

text \<open> Heap lookup retrieves data from the heap and places it into a store variable. If the memory
  location $l$ is unallocated then an abort is the result. \<close>

definition
  heap_lookup :: "('a::{countable,infinite} \<Longrightarrow> 's) \<Rightarrow> (addr, 's) uexpr \<Rightarrow> 's mprog"
  ("_ := *_" [74,75] 75)
  where [upred_defs, ndes_simp]:
    "x := *l = (((l \<oplus>\<^sub>p str) \<in>\<^sub>u dom\<^sub>u(&hp)) \<turnstile>\<^sub>n str:x := uop from_nat_bij (&hp(l \<oplus>\<^sub>p str)\<^sub>a))"

text \<open> Heap mutation updates the value of an already allocated address in the heap. \<close>

definition
  heap_mutate :: "(addr, 's) uexpr \<Rightarrow> ('a::{countable,infinite}, 's) uexpr \<Rightarrow> 's mprog"
  ("*_ := _" [0, 74] 75)
  where [upred_defs, ndes_simp]:
    "*l := e = (((l \<oplus>\<^sub>p str) \<in>\<^sub>u dom\<^sub>u(&hp)) \<turnstile>\<^sub>n hp := &hp((l \<oplus>\<^sub>p str) \<mapsto> uop to_nat_bij (e \<oplus>\<^sub>p str))\<^sub>u)"

text \<open> Heap deallocation removes an area of memory from the heap. \<close>

definition
  heap_dealloc :: "(addr, 's) uexpr \<Rightarrow> 's mprog" ("dealloc'(_')")
  where [upred_defs, ndes_simp]:
  "dealloc(l) = (U((l \<oplus>\<^sub>p str) \<in> fdom(&hp)) \<turnstile>\<^sub>n hp := (fdom(&hp) - {l \<oplus>\<^sub>p str}) \<lhd>\<^sub>f &hp)"

subsection \<open> Weakest Precondition Semantics \<close>

lemma wp_heap_alloc [wp]:
  "\<lbrakk> vwb_lens x; x \<sharp> e \<rbrakk> \<Longrightarrow>
   x := alloc(e) wp\<^sub>D p = (\<^bold>\<forall> l \<in> -dom\<^sub>u(&hp) \<bullet> p\<lbrakk>\<guillemotleft>l\<guillemotright>,&hp(\<guillemotleft>l\<guillemotright> \<mapsto> uop to_nat_bij (e \<oplus>\<^sub>p str))\<^sub>u/&str:x,&hp\<rbrakk>)"
  by (simp add: ndes_simp wp usubst unrest, rel_auto)

lemma wp_heap_dealloc [wp]:
  "dealloc(e) wp\<^sub>D p = U(e \<oplus>\<^sub>p str \<in> fdom(&hp) \<and> p\<lbrakk>(fdom(&hp) - {e \<oplus>\<^sub>p str}) \<lhd>\<^sub>f &hp/&hp\<rbrakk>)"
  by (rel_auto)

subsection \<open> Example properties \<close>

lemma least_nat_Compl_not_in [simp]:
  fixes A :: "nat set"
  assumes "finite A"
  shows "Inf(- A) \<notin> A"
  by (metis ComplD ComplI Inf_nat_def assms ex_new_if_finite infinite_UNIV wellorder_Least_lemma(1))

lemma "vwb_lens x \<Longrightarrow> (x := alloc(\<guillemotleft>u\<guillemotright>) ;; *x :=\<^sub>\<D> \<guillemotleft>Some v\<guillemotright>) = (x := alloc(\<guillemotleft>v\<guillemotright>))"
  apply (ndes_simp, rel_auto') oops

lemma "dealloc(e) ;; dealloc(e) = \<bottom>\<^sub>D"
  by (ndes_simp, rel_auto)

lemma "vwb_lens x \<Longrightarrow> dealloc(&x) ;; *x :=\<^sub>\<D> \<guillemotleft>v\<guillemotright> = \<bottom>\<^sub>D"
  by (ndes_simp, rel_auto)

lemma "vwb_lens x \<Longrightarrow> (x := alloc(\<guillemotleft>5 :: int\<guillemotright>) ;; dealloc(&x) ;; str:x :=\<^sub>D 0) = str:x :=\<^sub>D 0"
  apply (ndes_simp, rel_auto)
  apply (rename_tac ok hp st ok')
  oops

  (*
  apply (rule_tac x="hp(Inf(- fdom(hp)) \<mapsto> to_nat_bij 5)\<^sub>f" in exI)
  apply (rule_tac x="put\<^bsub>x\<^esub> st (\<Squnion>(- fdom(hp)))" in exI, simp)
  apply (auto)
  done
*)

end


(*
Title: Value-Dependent SIFUM-Type-Systems
Authors: Toby Murray, Robert Sison, Edward Pierzchalski, Christine Rizkallah
(Based on the SIFUM-Type-Systems AFP entry, whose authors
 are: Sylvia Grewe, Heiko Mantel, Daniel Schoepe)
*)
theory Example_TypeSystem
imports
  "../TypeSystem"
  TypeSystemTactics
begin

datatype addr = low_var | high_var | control_var | buffer | temp
type_synonym val = nat
type_synonym mem = "addr \<Rightarrow> val"

datatype aexp = Load "addr"

fun
  ev\<^sub>A :: "mem \<Rightarrow> aexp \<Rightarrow> val"
where
  "ev\<^sub>A mem (Load x) = mem x"

fun
  aexp_vars :: "aexp \<Rightarrow> addr set"
where
  "aexp_vars (Load x) = {x}"

datatype bexp = Same "addr" "addr" |
                NotSame "addr" "addr" |
                Eq "addr" "val" |
                Neq "addr" "val" |
                TT | FF

fun
  ev\<^sub>B :: "mem \<Rightarrow> bexp \<Rightarrow> bool"
where
  "ev\<^sub>B mem (Same x y) = ((mem x) = (mem y))" |
  "ev\<^sub>B mem (NotSame x y) = ((mem x) \<noteq> (mem y))" |
  "ev\<^sub>B mem (Eq x c) = ((mem x) = c)" |
  "ev\<^sub>B mem (Neq x c) = ((mem x) \<noteq> c)" |
  "ev\<^sub>B mem TT = True" |
  "ev\<^sub>B mem FF = False"

fun
  bexp_vars :: "bexp \<Rightarrow> addr set"
where
  "bexp_vars (Neq x c) = {x}" |
  "bexp_vars (Eq x c) = {x}" |
  "bexp_vars (Same x y) = {x,y}" |
  "bexp_vars (NotSame x y) = {x,y}" |
  "bexp_vars _ = {}"

fun
  bexp_neg :: "bexp \<Rightarrow> bexp"
where
  "bexp_neg (Neq x y) = (Eq x y)" |
  "bexp_neg (Eq x y) = (Neq x y)" |
  "bexp_neg (Same x y) = (NotSame x y)" |
  "bexp_neg (NotSame x y) = (Same x y)" |
  "bexp_neg TT = FF" |
  "bexp_neg FF = TT"

fun
   bexp_assign :: "addr \<Rightarrow> aexp \<Rightarrow> bexp"
where
  "bexp_assign x (Load y)  = (Same x y)"

definition
  dma_control_var :: "val \<Rightarrow> Sec"
where
  "dma_control_var v \<equiv> if v = 0 then Low else High"

definition
  dma :: "mem \<Rightarrow> addr \<Rightarrow> Sec"
where
  "dma m x \<equiv> if x = buffer then dma_control_var (m control_var) else if x = high_var then High else Low"

definition
  \<C>_vars :: "addr \<Rightarrow> addr set"
where
  "\<C>_vars x \<equiv> if x = buffer then {control_var} else {}"

definition
  mds\<^sub>s :: "Mode \<Rightarrow> 'Var set"
where
  "mds\<^sub>s \<equiv> \<lambda>_. {}"

locale sifum_example =
  sifum_lang_no_dma ev\<^sub>A ev\<^sub>B aexp_vars bexp_vars +
  assumes eval_det: "(lc, lc') \<in> sifum_lang_no_dma.eval\<^sub>w ev\<^sub>A ev\<^sub>B \<Longrightarrow> (lc, lc'') \<in> sifum_lang_no_dma.eval\<^sub>w ev\<^sub>A ev\<^sub>B \<Longrightarrow> lc' = lc''"

definition
  \<C> :: "addr set"
where
  "\<C> \<equiv> \<Union>x. \<C>_vars x"

fun
  dma_type :: "addr \<Rightarrow> bexp set"
where
  "dma_type high_var = {FF}" |
  "dma_type buffer = {Eq control_var 0}" |
  "dma_type _ = {}"

sublocale sifum_example \<subseteq> sifum_types_assign ev\<^sub>A ev\<^sub>B aexp_vars bexp_vars dma \<C>_vars \<C> bexp_neg dma_type FF bexp_assign
  apply(unfold_locales)
              apply(blast intro: eval_det)
             apply(rule Var_finite)
            apply(auto simp: \<C>_vars_def dma_def \<C>_def split: if_splits)[3]
         apply(rename_tac mem e, case_tac e, auto)[1]
        apply(case_tac x, auto simp: dma_def dma_control_var_def)[1]
       apply(case_tac x, auto simp: \<C>_vars_def)[1]
      apply(simp+)[2]
    apply(case_tac e, auto)[1]
   apply(case_tac e, simp)
  apply(auto simp: \<C>_def)
  done

context sifum_example begin

definition
  read_buffer :: "(addr, aexp, bexp) Stmt"
where
  "read_buffer \<equiv>
     ModeDecl Skip (Acq control_var AsmNoWrite) ;;
     ModeDecl Skip (Acq temp AsmNoReadOrWrite) ;;
     Assign temp (Load buffer) ;;
     If (Eq control_var 0) (Assign low_var (Load temp)) (Assign high_var (Load temp))"

lemma \<C>_simp[simp]:
  "\<C> = {control_var}"
  by(auto simp: \<C>_def \<C>_vars_def split: if_splits)

lemma type_aexpr_Load':
  "v \<in> dom \<Gamma> \<Longrightarrow> t = (the (\<Gamma> v)) \<Longrightarrow> type_aexpr \<Gamma> (Load v) t"
  apply(insert type_aexpr[of \<Gamma> "Load v", simplified])
  apply(simp add: to_total_def)
  done

declare restrict_preds_to_vars_def [simp]
declare add_pred_def [simp]
declare stable_def [simp]
declare to_total_def [simp]
declare \<C>_vars_def [simp]
declare anno_type_stable_def [simp]
declare anno_type_sec_def [simp]
declare assign_post_def [simp]

lemma read_buffer_typed:
  "\<Gamma> = (\<lambda>_. None) \<Longrightarrow> \<S> = ({},{}) \<Longrightarrow> P = {} \<Longrightarrow>
  \<exists>\<Gamma>' \<S>' P'. has_type \<Gamma> \<S> P read_buffer \<Gamma>' \<S>' P'"
  apply(intro exI)
  apply(simp add: read_buffer_def)
  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply clarsimp
       apply(rule skip_type)
      apply simp
     apply simp
    apply simp
   apply simp
  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply clarsimp
       apply(rule skip_type)
      apply simp
     apply simp
    apply simp
   apply simp
  apply(rule seq_type)
   apply(rule assign\<^sub>2[OF _ _ _ HOL.refl])
      apply simp
     apply(rule type_aexpr_Load)
     apply simp
    apply simp
   apply simp
  apply(rule if_type')
      apply(rule type_bexprI)
      apply simp
     apply(clarsimp)
    apply(rule assign\<^sub>1)
        apply simp
       apply(simp)
      apply(rule type_aexpr_Load')
       apply simp
      apply simp
     apply(simp add: subtype_def)
    apply(simp)
   apply(rule assign\<^sub>1)
       apply simp
      apply simp
     apply(rule type_aexpr_Load')
      apply simp
     apply simp
    apply(simp add: subtype_def)
   apply(simp)
  apply clarsimp
  apply fastforce
  done

lemma read_buffer_com_sifum_secure:
  "com_sifum_secure (read_buffer,(\<lambda>_. {}))"
  apply(insert read_buffer_typed[OF HOL.refl HOL.refl HOL.refl])
  apply clarify
  apply(rule typed_secure)
   apply(fastforce simp: \<Gamma>_of_mds_def \<S>_of_mds_def)
  apply(auto simp: mds_yields_stable_types_def)
  done

definition
  write_buffer :: "(addr, aexp, bexp) Stmt"
where
  "write_buffer \<equiv>
     ModeDecl Skip (Acq control_var AsmNoWrite) ;;
     ModeDecl Skip (Acq temp AsmNoReadOrWrite) ;;
     If (Eq control_var 0) (Assign temp (Load low_var)) (Assign temp (Load high_var)) ;;
     Assign buffer (Load temp)"

lemma restrict_preds_to_vars_empty[simp]:
  "restrict_preds_to_vars {} V = {}"
  apply(simp add: restrict_preds_to_vars_def)
  done

lemma restrict_preds_to_vars_idemp[simp]:
  "restrict_preds_to_vars (restrict_preds_to_vars P V) V =
   restrict_preds_to_vars P V"
  apply(simp add: restrict_preds_to_vars_def)
  done

lemma restrict_preds_to_vars_insert1[simp]:
  "(\<forall>x\<in>bexp_vars a. x \<in> V) \<Longrightarrow> restrict_preds_to_vars (insert a P) V = (insert a (restrict_preds_to_vars P V))"
  apply(simp add: restrict_preds_to_vars_def)
  apply fastforce
  done

lemma restrict_preds_to_vars_insert2[simp]:
  "(\<exists>x\<in>bexp_vars a. x \<notin> V) \<Longrightarrow> restrict_preds_to_vars (insert a P) V = ((restrict_preds_to_vars P V))"
  apply(simp add: restrict_preds_to_vars_def)
  apply fastforce
  done

lemma [simp]:
  "Eq a b \<in> P \<Longrightarrow> Neq a b \<in> P \<Longrightarrow> pred_entailment P Q"
  apply(clarsimp simp: pred_entailment_def pred_def)
  apply(frule bspec, assumption)
  apply(drule bspec, assumption, fastforce)
  done

declare restrict_preds_to_vars_def[simp del]

lemma write_buffer_typed:
  "\<Gamma> = (\<lambda>_. None) \<Longrightarrow> \<S> = ({},{}) \<Longrightarrow> P = {} \<Longrightarrow>
  \<exists>\<Gamma>' \<S>' P'. has_type \<Gamma> \<S> P write_buffer \<Gamma>' \<S>' P'"
  apply(intro exI)
  apply(simp add: write_buffer_def)
  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply clarsimp
       apply(rule skip_type)
      apply simp
     apply simp
    apply simp
   apply simp
  apply(rule seq_type)
   apply(rule anno_type[OF HOL.refl HOL.refl HOL.refl])
       apply clarsimp
       apply(rule skip_type)
      apply simp
     apply simp
    apply simp
   apply simp
  apply(rule seq_type)
   apply(rule if_type[where \<Gamma>'''="[temp \<mapsto> dma_type buffer]" and P'''="{}"])
            apply(rule type_bexprI)
            apply simp
           apply simp
          apply(rule assign\<^sub>2[OF _ _ _ HOL.refl])
             apply simp
            apply(rule type_aexpr_Load)
            apply simp
           apply simp
          apply simp
         apply(rule assign\<^sub>2[OF _ _ _ HOL.refl])
            apply simp
           apply(rule type_aexpr_Load)
           apply simp
          apply(simp)
         apply simp
        apply(clarsimp simp: context_equiv_def  type_equiv_def subtype_def)
       apply(clarsimp simp: context_equiv_def type_equiv_def subtype_def)
      apply(blast intro: subset_entailment)
     apply(blast intro: subset_entailment)
    (* need to be careful how we unfold here as otherwise the tactics get overwhelmed *)
    apply clarsimp
    apply(subst tyenv_wellformed_def)
    apply(clarsimp simp: mds_consistent_def types_wellformed_def type_wellformed_def types_stable_def)
    apply(simp add: tyenv_wellformed_def mds_consistent_def)
    apply blast
   apply clarsimp
   apply(subst tyenv_wellformed_def)
   apply(clarsimp simp: mds_consistent_def types_wellformed_def type_wellformed_def types_stable_def)
   apply(simp add: tyenv_wellformed_def mds_consistent_def)
   apply blast
  apply(rule assign\<^sub>1)
      apply simp+
    apply(rule type_aexpr_Load')
     apply simp
    apply simp
   apply simp
  apply blast
  done

lemma read_buffer_typed':
  "\<Gamma> = (\<lambda>_. None) \<Longrightarrow> \<S> = ({},{}) \<Longrightarrow> P = {} \<Longrightarrow>
  \<exists>\<Gamma>' \<S>' P'. has_type \<Gamma> \<S> P read_buffer \<Gamma>' \<S>' P'"
  by (has_type_tac prog: read_buffer_def
       aexpr:type_aexpr_Load' type_aexpr_Load
       bexpr:type_bexprI)

lemma write_buffer_typed':
  "\<Gamma> = (\<lambda>_. None) \<Longrightarrow> \<S> = ({},{}) \<Longrightarrow> P = {} \<Longrightarrow>
  \<exists>\<Gamma>' \<S>' P'. has_type \<Gamma> \<S> P write_buffer \<Gamma>' \<S>' P'"
  apply (has_type_tac prog: write_buffer_def aexpr:type_aexpr_Load' type_aexpr_Load bexpr:type_bexprI)
  apply (if_type_tac bexpr: type_bexprI
          custom_if: if_type[where \<Gamma>'''="[temp \<mapsto> dma_type buffer]" and P'''="{}"])
  apply (has_type_tac' aexpr:type_aexpr_Load' type_aexpr_Load bexpr:type_bexprI)
  done

end

end