section \<open>Lists\<close>

theory List_Extensions
imports "HOL-Library.Sublist"
begin

  declare remove1_idem[simp]

  lemma nth_append_simps[simp]:
    "i < length xs \<Longrightarrow> (xs @ ys) ! i = xs ! i"
    "i \<ge> length xs \<Longrightarrow> (xs @ ys) ! i = ys ! (i - length xs)"
    unfolding nth_append by simp+

  notation zip (infixr "||" 51)

  abbreviation "project A \<equiv> filter (\<lambda> a. a \<in> A)"
  abbreviation "select s w \<equiv> nths w s"

  lemma map_plus[simp]: "map (plus n) [i ..< j] = [i + n ..< j + n]"
  proof (induct n)
    case 0
    show ?case by simp
  next
    case (Suc n)
    have "map (plus (Suc n)) [i ..< j] = map (Suc \<circ> plus n) [i ..< j]" by simp
    also have "\<dots> = (map Suc \<circ> map (plus n)) [i ..< j]" by simp
    also have "\<dots> = map Suc (map (plus n) [i ..< j])" by simp
    also have "\<dots> = map Suc [i + n ..< j + n]" unfolding Suc by simp
    also have "\<dots> = [Suc (i + n) ..< Suc (j + n)]" unfolding map_Suc_upt by simp
    also have "\<dots> = [i + Suc n ..< j + Suc n]" by simp
    finally show ?case by this
  qed

  lemma singleton_list_lengthE[elim]:
    assumes "length xs = 1"
    obtains x
    where "xs = [x]"
  proof -
    have 0: "length xs = Suc 0" using assms by simp
    obtain y ys where 1: "xs = y # ys" "length ys = 0" using 0 Suc_length_conv by metis
    show ?thesis using that 1 by blast
  qed

  lemma singleton_hd_last: "length xs = 1 \<Longrightarrow> hd xs = last xs" by fastforce

  lemma set_subsetI[intro]:
    assumes "\<And> i. i < length xs \<Longrightarrow> xs ! i \<in> S"
    shows "set xs \<subseteq> S"
  proof
    fix x
    assume 0: "x \<in> set xs"
    obtain i where 1: "i < length xs" "x = xs ! i" using 0 unfolding in_set_conv_nth by blast
    show "x \<in> S" using assms(1) 1 by auto
  qed

  lemma hd_take[simp]:
    assumes "n \<noteq> 0" "xs \<noteq> []"
    shows "hd (take n xs) = hd xs"
  proof -
    have 1: "take n xs \<noteq> []" using assms by simp
    have 2: "0 < n" using assms by simp
    have "hd (take n xs) = take n xs ! 0" using hd_conv_nth[OF 1] by this
    also have "\<dots> = xs ! 0" using nth_take[OF 2] by this
    also have "\<dots> = hd xs" using hd_conv_nth[OF assms(2)] by simp
    finally show ?thesis by this
  qed
  lemma hd_drop[simp]:
    assumes "n < length xs"
    shows "hd (drop n xs) = xs ! n"
    using hd_drop_conv_nth assms by this
  lemma last_take[simp]:
    assumes "n < length xs"
    shows "last (take (Suc n) xs) = xs ! n"
  using assms
  proof (induct xs arbitrary: n)
    case (Nil)
    show ?case using Nil by simp
  next
    case (Cons x xs)
    show ?case using Cons by (auto) (metis Suc_less_eq Suc_pred)
  qed

  lemma split_list_first_unique:
    assumes "u\<^sub>1 @ [a] @ u\<^sub>2 = v\<^sub>1 @ [a] @ v\<^sub>2" "a \<notin> set u\<^sub>1" "a \<notin> set v\<^sub>1"
    shows "u\<^sub>1 = v\<^sub>1"
  proof -
    obtain w where "u\<^sub>1 = v\<^sub>1 @ w \<and> w @ [a] @ u\<^sub>2 = [a] @ v\<^sub>2 \<or>
      u\<^sub>1 @ w = v\<^sub>1 \<and> [a] @ u\<^sub>2 = w @ [a] @ v\<^sub>2" using assms(1) append_eq_append_conv2 by blast
    thus ?thesis using assms(2, 3) by (auto) (metis hd_append2 list.sel(1) list.set_sel(1))+
  qed

end


section "Kruskal on Symmetric Directed Graph"

theory Graph_Definition_Impl
imports
 Kruskal_Impl Graph_Definition_Aux
begin

subsection "Interpreting \<open>Kruskl_Impl\<close>"

locale fromlist = fixes
  L :: "(nat \<times> int \<times> nat) list"
begin

  abbreviation "E\<equiv>set L"
  abbreviation "V\<equiv>fst ` E \<union> (snd \<circ> snd) ` E"
  abbreviation "ind (E'::(nat \<times> int \<times> nat) set) \<equiv> \<lparr>nodes=V, edges=E'\<rparr>"
  abbreviation "subforest E' \<equiv> forest (ind E') \<and> subgraph (ind E')  (ind E)"

  lemma max_node_is_Max_V: " E =  set la \<Longrightarrow> max_node la = Max (insert 0 V)"
  proof -
    assume E: "E =  set la"
    have *: "fst ` set la \<union> (snd \<circ> snd) ` set la
             = (\<Union>x\<in>set la. case x of (x1, x1a, x2a) \<Rightarrow> {x1, x2a})"
      by auto force
    show ?thesis
    unfolding E
    by (auto simp add:    max_node_def prod.case_distrib * )
  qed

  lemma ind_valid_graph: "\<And>E'. E' \<subseteq> E \<Longrightarrow> valid_graph (ind E')"
    unfolding valid_graph_def by force

  lemma vE: "valid_graph (ind E)" apply(rule ind_valid_graph) by simp

  lemma ind_valid_graph': "\<And>E'. subgraph (ind E') (ind E) \<Longrightarrow> valid_graph (ind E')"
    apply(rule ind_valid_graph) by(auto simp: subgraph_def)

  lemma add_edge_ind: "(a,w,b)\<in>E \<Longrightarrow> add_edge a w b (ind F) = ind (insert (a,w,b) F)"
    unfolding add_edge_def by force

  lemma nodes_connected_ind_sym: "F\<subseteq>E \<Longrightarrow> sym {(x, y) |x y. nodes_connected (ind F) x y}"
    apply(frule ind_valid_graph)
      unfolding sym_def using valid_graph.nodes_connected_sym by fast
  lemma nodes_connected_ind_trans: "F\<subseteq>E \<Longrightarrow> trans {(x, y) |x y. nodes_connected (ind F) x y}"
    apply(frule ind_valid_graph)
     unfolding trans_def using valid_graph.is_path_undir_append by fast

  lemma part_equiv_nodes_connected_ind:
    "F\<subseteq>E \<Longrightarrow> part_equiv {(x, y) |x y. nodes_connected (ind F) x y}"
     apply(rule) using nodes_connected_ind_trans nodes_connected_ind_sym by auto

  sublocale s: Kruskal_Impl E V
    "\<lambda>e. {fst e, snd (snd e)}" "\<lambda>u v (a,w,b). u=a \<and> v=b \<or> u=b \<and> v=a"
    "subforest"
    "\<lambda>E'. { (a,b) |a b. nodes_connected (ind E') a b}"
    "\<lambda>(u,w,v). w" id  "PR_CONST (\<lambda>(u,w,v). RETURN (u,v))"
    "PR_CONST (RETURN L)" "return L" "set L" "(\<lambda>(u,w,v). return (u,v))"
  proof (unfold_locales, goal_cases)
    show "finite E" by simp
  next
    fix E'
    assume "forest (ind E') \<and> subgraph (ind E')  \<lparr>nodes=V, edges=E\<rparr>"
    then show "E' \<subseteq> E" unfolding subgraph_def by auto
  next
    show "subforest {}" by (auto simp: subgraph_def forest_def valid_graph_def forest_axioms_def)
  next
    case (4 X Y)
    then have *: "subgraph (ind Y) (ind X)" "subgraph (ind Y) (ind E)"
      unfolding subgraph_def by auto
    with 4 show ?case using forest.subgraph_forest by auto
  next
    case (5 u v)
    have k: "valid_graph (ind {})" apply(rule ind_valid_graph) by simp
    show ?case
      apply auto
      subgoal for p  apply(cases p) by auto
      subgoal for p  apply(cases p) by auto
      subgoal apply(rule exI[where x="[]"]) by auto
      subgoal apply(rule exI[where x="[]"]) by force
      done
  next
    case (6 E1 E2 u v)
    have *: "valid_graph (ind E)" apply(rule ind_valid_graph) by simp
    from 6 show ?case using valid_graph.augment_edge[of "ind E" "ind E1" "ind E2" u v, OF *]
      unfolding subgraph_def by simp
  next
    case (7 F e u v)
    then have f: "forest (ind F)" and s: "subgraph (ind F) (ind E)" by auto
    from 7 have uv: "u\<in>V" "v\<in>V" by force+
    obtain a w b where e: "e=(a,w,b)" apply(cases e) by auto
    from e 7(3) have abuv: "u=a \<and> v=b \<or> u=b \<and> v=a" by auto
    show ?case
    proof
      assume "forest (ind (insert e F)) \<and> subgraph (ind (insert e F)) (ind E) "
      then have "(\<forall>(a, w, b)\<in> insert e F.
                \<not>nodes_connected (delete_edge a w b (ind (insert e F))) a b)"
        unfolding forest_def forest_axioms_def by auto
      with e have i: "\<not> nodes_connected (delete_edge a w b (ind (insert e F))) a b" by auto
      have ii: "(delete_edge a w b (ind (insert e F))) = ind F"
        using 7(2) e by (auto simp: delete_edge_def)
      from i have "\<not> nodes_connected (ind F) a b" using ii by auto
      then show "(u, v) \<notin> {(a, b) |a b. nodes_connected (ind F) a b}"
        using 7(3)   valid_graph.nodes_connected_sym[OF ind_valid_graph'[OF s]] e by auto
    next
      from s 7(2) have sg: "subgraph (ind (insert e F)) (ind E)"
        unfolding subgraph_def by auto
      assume "(u, v) \<notin> {(a, b) |a b. nodes_connected (ind F) a b}"
      with abuv have "(a, b) \<notin> {(a, b) |a b. nodes_connected (ind F) a b}"
        using  valid_graph.nodes_connected_sym[OF ind_valid_graph'[OF s]]
        by auto
      then have nn: "~nodes_connected (ind F) a b" by auto
      have "forest (add_edge a w b (ind F))" apply(rule forest.forest_add_edge[OF f _ _ nn])
        using uv abuv by auto
      then have f': "forest (ind (insert e F))" using 7(2) add_edge_ind by (auto simp add: e)
      from f' sg show "forest (ind (insert e F)) \<and> subgraph (ind (insert e F)) (ind E) "
        by auto
    qed
  next
    case (8 F)
    then have s: "subgraph (ind F) (ind E)" unfolding subgraph_def by auto
    from valid_graph.connected_VV[OF vE s]
      show i: "{(x, y) |x y. nodes_connected (ind F) x y} \<subseteq> V\<times>V" by simp

    from valid_graph.connected_equiv[OF vE s]
      show "equiv V {(x, y) |x y. nodes_connected (ind F) x y}" by simp
  next
    case (10 x y F e)
    from 10 have xy: "x\<in>V" "y\<in>V" by force+
    obtain a w b where e: "e=(a,w,b)" apply(cases e) by auto

    from 10(4) have ad_eq: "add_edge a w b (ind F) = ind (insert e F)"
      using e unfolding add_edge_def by (auto simp add: rev_image_eqI)
    have *: "\<And>x y. nodes_connected (add_edge a w b (ind F)) x y
             = ((x, y) \<in> per_union {(x, y) |x y. nodes_connected (ind F) x y} a b)"
      apply(rule valid_graph.nodes_connected_insert_per_union[of "ind E"])
      subgoal apply(rule ind_valid_graph) by simp
      subgoal using 10(3) by(auto simp: subgraph_def)
      subgoal apply(rule part_equiv_nodes_connected_ind) by fact
      using xy e 10(5) by auto
    show ?case
      using 10(5) e * ad_eq by auto
  next
    case 11
    then show ?case by auto
  next
    case 12
    then show ?case by auto
  next
    case 13
    then show ?case by auto
  next
    case (14 a F e)
    then obtain w where "e=(a,w,a)" by auto
    with 14 have "a\<in>V" and p: "(a,w,a): edges (ind (insert e F))" by auto
    then have *: "nodes_connected (delete_edge a w a (ind (insert e F))) a a"
      apply (intro exI[where x="[]"]) by simp
    have "\<exists>(a, w, b)\<in>edges (ind (insert e F)).
          nodes_connected (delete_edge a w b (ind (insert e F))) a b"
      apply (rule bexI[where x="(a,w,a)"])
      using * p by auto
    then
      have "\<not> forest (ind (insert e F))"
        unfolding forest_def forest_axioms_def by blast
    then show ?case by auto
  next
    case (15 e)
    then show ?case by auto
  next
    case 16
    thus ?case by force
  next
    case 17
    thus ?case by auto
  next
    case (18 a b)
    then show ?case apply auto
        subgoal for w apply(rule exI[where x="[(a, w, b)]"]) by force
        subgoal for w apply(rule exI[where x="[(a, w, b)]"]) apply simp by blast
        done
  next
    case 19
    thus ?case by (auto split: prod.split )
  next
    case 20
    thus ?case by auto
  next
    case 21
    thus ?case apply sepref_to_hoare apply sep_auto by(auto simp: pure_fold list_assn_emp)
  next
    case (22 l)
    then show ?case using max_node_is_Max_V by auto
  next
    case 23
    then show ?case apply sepref_to_hoare by sep_auto
  qed

  subsection \<open>Showing the equivalence of minimum spanning forest definitions\<close>

  text \<open>As the definition of the minimum spanning forest from the minWeightBasis algorithm differs
    from the one of our graph formalization, we new show their equivalence.\<close>

  lemma spanning_forest_eq: "s.SpanningForest E' = spanning_forest (ind E') (ind E)"
  proof rule
    assume t: "s.SpanningForest E'"
    have f: "(forest (ind E'))" and sub: "subgraph (ind E') (ind E)" and
        n: "(\<forall>x\<in>E - E'.  \<not> (forest (ind ( insert x E')) \<and> subgraph (ind ( insert x E')) (ind E)))"
      using t[unfolded  s.SpanningForest_def ]  by auto

    have vE: "valid_graph (ind E)" apply(rule ind_valid_graph) by simp

    have "\<And>x. x\<in>E-E' \<Longrightarrow> subgraph (ind ( insert x E')) (ind E)"
      using sub unfolding subgraph_def by auto
    with n have "(\<forall>x\<in>E - E'.  \<not> (forest (ind ( insert x E'))))" by blast
    then have n': "(\<forall>(a,w,b)\<in>edges (ind E) - edges (ind E').  \<not> (forest (add_edge a w b (ind E'))))"
      using valid_graph.E_validD[OF vE]  by(auto simp: add_edge_def insert_absorb)

    have mc: "maximally_connected (ind E') (ind E)"
      apply(rule valid_graph.forest_maximally_connected_incl_max1) by fact+

    show " spanning_forest (ind E') (ind E)"
      unfolding spanning_forest_def using f sub mc by blast
  next
    assume t: "spanning_forest (ind E') (ind E)"
    have  f: "(forest (ind E'))" and sub: "subgraph (ind E') (ind E)" and
        n: "maximally_connected (ind E') (ind E)" using t[unfolded spanning_forest_def] by auto

    have i: "\<And>x. x\<in>E-E' \<Longrightarrow> subgraph (ind ( insert x E')) (ind E)"
      using sub unfolding subgraph_def by auto
    have vE: "valid_graph (ind E)" apply(rule ind_valid_graph) by simp

    have "\<forall>(a, w, b)\<in>edges (ind E) - edges (ind E'). \<not> forest (add_edge a w b (ind E'))"
      apply(rule valid_graph.forest_maximally_connected_incl_max2) by fact+
    then have t: "\<And>a w b. (a, w, b)\<in>edges (ind E) - edges (ind E')
                   \<Longrightarrow> \<not> forest (add_edge a w b (ind E'))"
      by blast

    have ii: "(\<forall>x\<in>E - E'.  \<not> (forest (ind ( insert x E'))))"
      apply (auto simp: add_edge_def)
      subgoal for a w b using t[of a w b] valid_graph.E_validD[OF vE]
        by(auto simp: add_edge_def insert_absorb)
      done

    from i ii have
      iii: "(\<forall>x\<in>E - E'. \<not>(forest (ind ( insert x E')) \<and> subgraph (ind ( insert x E')) (ind E)))"
      by blast

    show "s.SpanningForest E'"
      unfolding s.SpanningForest_def using iii f sub  by blast
  qed

  lemma edge_weight_alt: "edge_weight G = sum (\<lambda>(u,w,v). w) (edges G)"
  proof -
    have f: "fst o snd  = (\<lambda>(u,w,v). w) " by auto
    show ?thesis unfolding edge_weight_def f by (auto cong: )
  qed

  lemma MSF_eq: "s.MSF E' = minimum_spanning_forest (ind E') (ind E)"
    unfolding s.MSF_def minimum_spanning_forest_def optimal_forest_def
    unfolding spanning_forest_eq edge_weight_alt
  proof safe
    fix F'
    assume "spanning_forest (ind E') (ind E)"
      and B: "(\<forall>B'. spanning_forest (ind B') (ind E)
             \<longrightarrow> (\<Sum>(u, w, v)\<in>E'. w) \<le> (\<Sum>(u, w, v)\<in>B'. w))"
      and sf: "spanning_forest F' (ind E)"
    from sf have "subgraph F' (ind E)" by(auto simp: spanning_forest_def)
    then have "F' = ind (edges F')" unfolding subgraph_def by auto
    with B sf show "(\<Sum>(u, w, v)\<in>edges (ind E'). w) \<le> (\<Sum>(u, w, v)\<in>edges F'. w)" by auto
  qed auto

  lemma kruskal_correct:
    "<emp> kruskal (return L) (\<lambda>(u,w,v). return (u,v)) ()
      <\<lambda>F. \<up> (distinct F \<and> set F \<subseteq> E \<and> minimum_spanning_forest (ind (set F)) (ind E))>\<^sub>t"
    using s.kruskal_correct_forest unfolding MSF_eq by auto

  definition (in -) "kruskal_algo L = kruskal (return L) (\<lambda>(u,w,v). return (u,v)) ()"

end

subsection \<open>Outside the locale\<close>

definition "GD_from_list_\<alpha>_weight L e = (case e of (u,w,v) \<Rightarrow> w)"
abbreviation "GD_from_list_\<alpha>_graph G L \<equiv> \<lparr>nodes=fst ` (set G) \<union> (snd \<circ> snd) ` (set G), edges=set L\<rparr>"

lemma corr: "
  <emp> kruskal_algo L
     <\<lambda>F. \<up> (set F \<subseteq> set L \<and>
       minimum_spanning_forest (GD_from_list_\<alpha>_graph L F) (GD_from_list_\<alpha>_graph L L))>\<^sub>t"
  by(sep_auto heap: fromlist.kruskal_correct simp:  kruskal_algo_def  )

lemma kruskal_correct: "<emp> kruskal_algo L
     <\<lambda>F. \<up> (set F \<subseteq> set L \<and>
       spanning_forest (GD_from_list_\<alpha>_graph L F) (GD_from_list_\<alpha>_graph L L)
      \<and> (\<forall>F'. spanning_forest (GD_from_list_\<alpha>_graph L F') (GD_from_list_\<alpha>_graph L L)
               \<longrightarrow>  sum (\<lambda>(u,w,v). w) (set F) \<le> sum (\<lambda>(u,w,v). w) (set F')))>\<^sub>t"
proof -
  interpret fromlist L by unfold_locales
  have *: "\<And>F'. edge_weight (ind F') = sum (\<lambda>(u,w,v). w) F'"
    unfolding edge_weight_def apply auto by (metis fn_snd_conv fst_def)
  show ?thesis using *
    by (sep_auto heap: corr simp: minimum_spanning_forest_def optimal_forest_def)
qed

subsection \<open>Code export\<close>

export_code kruskal_algo checking SML_imp

ML_val \<open>
  val export_nat = @{code integer_of_nat}
  val import_nat = @{code nat_of_integer}
  val export_int = @{code integer_of_int}
  val import_int = @{code int_of_integer}
  val import_list = map (fn (a,b,c) => (import_nat a, (import_int b, import_nat c)))
  val export_list = map (fn (a,(b,c)) => (export_nat a, export_int b, export_nat c))
  val export_Some_list = (fn SOME l => SOME (export_list l) | NONE => NONE)

  fun kruskal l = @{code kruskal} (fn () => import_list l) (fn (a,(_,c)) => fn () => (a,c)) () ()
                     |> export_list
  fun kruskal_algo l = @{code kruskal_algo} (import_list l) ()  |> export_list

  val result = kruskal [(1,~9,2),(2,~3,3),(3,~4,1)]
  val result4 = kruskal [(1,~100,4), (3,64,5), (1,13,2), (3,20,2), (2,5,5), (4,80,3), (4,40,5)]

  val result' = kruskal_algo [(1,~9,2),(2,~3,3),(3,~4,1)]
  val result1' = kruskal_algo [(1,~9,2),(2,~3,3),(3,~4,1),(1,5,3)]
  val result2' = kruskal_algo [(1,~9,2),(2,~3,3),(3,~4,1),(1,~4,3)]
  val result3' = kruskal_algo [(1,~9,2),(2,~3,3),(3,~4,1),(1,~4,1)]
  val result4' = kruskal_algo [(1,~100,4), (3,64,5), (1,13,2), (3,20,2),
                               (2,5,5), (4,80,3), (4,40,5)]
\<close>

end


(*  Author:     Ning Zhang and Christian Urban

Example theory involving Unicode characters (UTF-8 encoding) -- both
formal and informal ones.
*)

section \<open>A Chinese theory\<close>

theory Chinese imports MainRLT begin

text\<open>数学家能把咖啡变成理论,如今中国的数学家也可
       以在伊莎贝拉的帮助下把茶变成理论.

       伊莎贝拉-世界数学家的新宠,现今能识别中文,成为
       中国数学家理论推导的得力助手.

\<close>

datatype shuzi =
    One   ("一")
  | Two   ("二")
  | Three ("三")
  | Four  ("四")
  | Five  ("五")
  | Six   ("六")
  | Seven ("七")
  | Eight ("八")
  | Nine  ("九")
  | Ten   ("十")

primrec translate :: "shuzi \<Rightarrow> nat" ("|_|" [100] 100) where
 "|一| = 1"
|"|二| = 2"
|"|三| = 3"
|"|四| = 4"
|"|五| = 5"
|"|六| = 6"
|"|七| = 7"
|"|八| = 8"
|"|九| = 9"
|"|十| = 10"

thm translate.simps

lemma "|四| + |六| = |十|"
  by simp

end


(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory Accumulator
imports
  HOLCF
  LList
  WorkerWrapperNew
begin
(*>*)

section{* Naive reverse becomes accumulator-reverse. *}

text{* \label{sec:accum} *}

subsection{* Hughes lists, naive reverse, worker-wrapper optimisation. *}

text{* The ``Hughes'' list type. *}

type_synonym 'a H = "'a llist \<rightarrow> 'a llist"

definition
  list2H :: "'a llist \<rightarrow> 'a H" where
  "list2H \<equiv> lappend"

lemma acc_c2a_strict[simp]: "list2H\<cdot>\<bottom> = \<bottom>"
  by (rule cfun_eqI, simp add: list2H_def)

definition
  H2list :: "'a H \<rightarrow> 'a llist" where
  "H2list \<equiv> \<Lambda> f . f\<cdot>lnil"

text{* The paper only claims the homomorphism holds for finite lists,
but in fact it holds for all lazy lists in HOLCF. They are trying to
dodge an explicit appeal to the equation @{thm "inst_cfun_pcpo"},
which does not hold in Haskell. *}

lemma H_llist_hom_append: "list2H\<cdot>(xs :++ ys) = list2H\<cdot>xs oo list2H\<cdot>ys" (is "?lhs = ?rhs")
proof(rule cfun_eqI)
  fix zs
  have "?lhs\<cdot>zs = (xs :++ ys) :++ zs" by (simp add: list2H_def)
  also have "\<dots> = xs :++ (ys :++ zs)" by (rule lappend_assoc)
  also have "\<dots> = list2H\<cdot>xs\<cdot>(ys :++ zs)" by (simp add: list2H_def)
  also have "\<dots> = list2H\<cdot>xs\<cdot>(list2H\<cdot>ys\<cdot>zs)" by (simp add: list2H_def)
  also have "\<dots> = (list2H\<cdot>xs oo list2H\<cdot>ys)\<cdot>zs" by simp
  finally show "?lhs\<cdot>zs = (list2H\<cdot>xs oo list2H\<cdot>ys)\<cdot>zs" .
qed

lemma H_llist_hom_id: "list2H\<cdot>lnil = ID" by (simp add: list2H_def)

lemma H2list_list2H_inv: "H2list oo list2H = ID"
  by (rule cfun_eqI, simp add: H2list_def list2H_def)

text{* \citet[\S4.2]{GillHutton:2009} define the naive reverse
function as follows. *}

fixrec lrev :: "'a llist \<rightarrow> 'a llist"
where
  "lrev\<cdot>lnil = lnil"
| "lrev\<cdot>(x :@ xs) = lrev\<cdot>xs :++ (x :@ lnil)"

text{* Note ``body'' is the generator of @{term "lrev_def"}. *}

lemma lrev_strict[simp]: "lrev\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

fixrec lrev_body :: "('a llist \<rightarrow> 'a llist) \<rightarrow> 'a llist \<rightarrow> 'a llist"
where
  "lrev_body\<cdot>r\<cdot>lnil = lnil"
| "lrev_body\<cdot>r\<cdot>(x :@ xs) = r\<cdot>xs :++ (x :@ lnil)"

lemma lrev_body_strict[simp]: "lrev_body\<cdot>r\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

text{* This is trivial but syntactically a bit touchy. Would be nicer
to define @{term "lrev_body"} as the generator of the fixpoint
definition of @{term "lrev"} directly. *}

lemma lrev_lrev_body_eq: "lrev = fix\<cdot>lrev_body"
  by (rule cfun_eqI, subst lrev_def, subst lrev_body.unfold, simp)

text{* Wrap / unwrap functions. *}

definition
  unwrapH :: "('a llist \<rightarrow> 'a llist) \<rightarrow> 'a llist \<rightarrow> 'a H" where
  "unwrapH \<equiv> \<Lambda> f xs . list2H\<cdot>(f\<cdot>xs)"

lemma unwrapH_strict[simp]: "unwrapH\<cdot>\<bottom> = \<bottom>"
  unfolding unwrapH_def by (rule cfun_eqI, simp)

definition
  wrapH :: "('a llist \<rightarrow> 'a H) \<rightarrow> 'a llist \<rightarrow> 'a llist" where
  "wrapH \<equiv> \<Lambda> f xs . H2list\<cdot>(f\<cdot>xs)"

lemma wrapH_unwrapH_id: "wrapH oo unwrapH = ID" (is "?lhs = ?rhs")
proof(rule cfun_eqI)+
  fix f xs
  have "?lhs\<cdot>f\<cdot>xs = H2list\<cdot>(list2H\<cdot>(f\<cdot>xs))" by (simp add: wrapH_def unwrapH_def)
  also have "\<dots> = (H2list oo list2H)\<cdot>(f\<cdot>xs)" by simp
  also have "\<dots> = ID\<cdot>(f\<cdot>xs)" by (simp only: H2list_list2H_inv)
  also have "\<dots> = ?rhs\<cdot>f\<cdot>xs" by simp
  finally show "?lhs\<cdot>f\<cdot>xs = ?rhs\<cdot>f\<cdot>xs" .
qed

subsection{* Gill/Hutton-style worker/wrapper. *}

definition
  lrev_work :: "'a llist \<rightarrow> 'a H" where
  "lrev_work \<equiv> fix\<cdot>(unwrapH oo lrev_body oo wrapH)"

definition
  lrev_wrap :: "'a llist \<rightarrow> 'a llist" where
  "lrev_wrap \<equiv> wrapH\<cdot>lrev_work"

lemma lrev_lrev_ww_eq: "lrev = lrev_wrap"
  using worker_wrapper_id[OF wrapH_unwrapH_id lrev_lrev_body_eq]
  by (simp add: lrev_wrap_def lrev_work_def)

subsection{* Optimise worker/wrapper. *}

text{* Intermediate worker. *}

fixrec lrev_body1 :: "('a llist \<rightarrow> 'a H) \<rightarrow> 'a llist \<rightarrow> 'a H"
where
  "lrev_body1\<cdot>r\<cdot>lnil = list2H\<cdot>lnil"
| "lrev_body1\<cdot>r\<cdot>(x :@ xs) = list2H\<cdot>(wrapH\<cdot>r\<cdot>xs :++ (x :@ lnil))"

definition
  lrev_work1 :: "'a llist \<rightarrow> 'a H" where
  "lrev_work1 \<equiv> fix\<cdot>lrev_body1"

lemma lrev_body_lrev_body1_eq: "lrev_body1 = unwrapH oo lrev_body oo wrapH"
  apply (rule cfun_eqI)+
  apply (subst lrev_body.unfold)
  apply (subst lrev_body1.unfold)
  apply (case_tac xa)
  apply (simp_all add: list2H_def wrapH_def unwrapH_def)
  done

lemma lrev_work1_lrev_work_eq: "lrev_work1 = lrev_work"
  by (unfold lrev_work_def lrev_work1_def,
      rule cfun_arg_cong[OF lrev_body_lrev_body1_eq])

text{* Now use the homomorphism. *}

fixrec lrev_body2 :: "('a llist \<rightarrow> 'a H) \<rightarrow> 'a llist \<rightarrow> 'a H"
where
  "lrev_body2\<cdot>r\<cdot>lnil = ID"
| "lrev_body2\<cdot>r\<cdot>(x :@ xs) = list2H\<cdot>(wrapH\<cdot>r\<cdot>xs) oo list2H\<cdot>(x :@ lnil)"

lemma lrev_body2_strict[simp]: "lrev_body2\<cdot>r\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

definition
  lrev_work2 :: "'a llist \<rightarrow> 'a H" where
  "lrev_work2 \<equiv> fix\<cdot>lrev_body2"

lemma lrev_work2_strict[simp]: "lrev_work2\<cdot>\<bottom> = \<bottom>"
  unfolding lrev_work2_def
  by (subst fix_eq) simp

lemma lrev_body2_lrev_body1_eq: "lrev_body2 = lrev_body1"
  by ((rule cfun_eqI)+
     , (subst lrev_body1.unfold, subst lrev_body2.unfold)
     , (simp add: H_llist_hom_append[symmetric] H_llist_hom_id))

lemma lrev_work2_lrev_work1_eq: "lrev_work2 = lrev_work1"
  by (unfold lrev_work2_def lrev_work1_def
     , rule cfun_arg_cong[OF lrev_body2_lrev_body1_eq])

text {* Simplify. *}

fixrec lrev_body3 :: "('a llist \<rightarrow> 'a H) \<rightarrow> 'a llist \<rightarrow> 'a H"
where
  "lrev_body3\<cdot>r\<cdot>lnil = ID"
| "lrev_body3\<cdot>r\<cdot>(x :@ xs) = r\<cdot>xs oo list2H\<cdot>(x :@ lnil)"

lemma lrev_body3_strict[simp]: "lrev_body3\<cdot>r\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

definition
  lrev_work3 :: "'a llist \<rightarrow> 'a H" where
  "lrev_work3 \<equiv> fix\<cdot>lrev_body3"

lemma lrev_wwfusion: "list2H\<cdot>((wrapH\<cdot>lrev_work2)\<cdot>xs) = lrev_work2\<cdot>xs"
proof -
  {
    have "list2H oo wrapH\<cdot>lrev_work2 = unwrapH\<cdot>(wrapH\<cdot>lrev_work2)"
      by (rule cfun_eqI, simp add: unwrapH_def)
    also have "\<dots> = (unwrapH oo wrapH)\<cdot>lrev_work2" by simp
    also have "\<dots> = lrev_work2"
      apply -
      apply (rule worker_wrapper_fusion[OF wrapH_unwrapH_id, where body="lrev_body"])
      apply (auto iff: lrev_body2_lrev_body1_eq lrev_body_lrev_body1_eq lrev_work2_def lrev_work1_def)
      done
    finally have "list2H oo wrapH\<cdot>lrev_work2 = lrev_work2" .
  }
  thus ?thesis using cfun_eq_iff[where f="list2H oo wrapH\<cdot>lrev_work2" and g="lrev_work2"] by auto
qed

text{* If we use this result directly, we only get a partially-correct
program transformation, see \citet{Tullsen:PhDThesis} for details. *}

lemma "lrev_work3 \<sqsubseteq> lrev_work2"
  unfolding lrev_work3_def
proof(rule fix_least)
  {
    fix xs have "lrev_body3\<cdot>lrev_work2\<cdot>xs = lrev_work2\<cdot>xs"
    proof(cases xs)
      case bottom thus ?thesis by simp
    next
      case lnil thus ?thesis
        unfolding lrev_work2_def
        by (subst fix_eq[where F="lrev_body2"], simp)
    next
      case (lcons y ys)
      hence "lrev_body3\<cdot>lrev_work2\<cdot>xs = lrev_work2\<cdot>ys oo list2H\<cdot>(y :@ lnil)" by simp
      also have "\<dots> = list2H\<cdot>((wrapH\<cdot>lrev_work2)\<cdot>ys) oo list2H\<cdot>(y :@ lnil)"
        using lrev_wwfusion[where xs=ys] by simp
      also from lcons have "\<dots> = lrev_body2\<cdot>lrev_work2\<cdot>xs" by simp
      also have "\<dots> = lrev_work2\<cdot>xs"
        unfolding lrev_work2_def by (simp only: fix_eq[symmetric])
      finally show ?thesis by simp
    qed
  }
  thus "lrev_body3\<cdot>lrev_work2 = lrev_work2" by (rule cfun_eqI)
qed

text{* We can't show the reverse inclusion in the same way as the
fusion law doesn't hold for the optimised definition. (Intuitively we
haven't established that it is equal to the original @{term "lrev"}
definition.) We could show termination of the optimised definition
though, as it operates on finite lists. Alternatively we can use
induction (over the list argument) to show total equivalence.

The following lemma shows that the fusion Gill/Hutton want to do is
completely sound in this context, by appealing to the lazy list
induction principle. *}

lemma lrev_work3_lrev_work2_eq: "lrev_work3 = lrev_work2" (is "?lhs = ?rhs")
proof(rule cfun_eqI)
  fix x
  show "?lhs\<cdot>x = ?rhs\<cdot>x"
  proof(induct x)
    show "lrev_work3\<cdot>\<bottom> = lrev_work2\<cdot>\<bottom>"
      apply (unfold lrev_work3_def lrev_work2_def)
      apply (subst fix_eq[where F="lrev_body2"])
      apply (subst fix_eq[where F="lrev_body3"])
      by (simp add: lrev_body3.unfold lrev_body2.unfold)
  next
    show "lrev_work3\<cdot>lnil = lrev_work2\<cdot>lnil"
      apply (unfold lrev_work3_def lrev_work2_def)
      apply (subst fix_eq[where F="lrev_body2"])
      apply (subst fix_eq[where F="lrev_body3"])
      by (simp add: lrev_body3.unfold lrev_body2.unfold)
  next
    fix a l assume "lrev_work3\<cdot>l = lrev_work2\<cdot>l"
    thus "lrev_work3\<cdot>(a :@ l) = lrev_work2\<cdot>(a :@ l)"
      apply (unfold lrev_work3_def lrev_work2_def)
      apply (subst fix_eq[where F="lrev_body2"])
      apply (subst fix_eq[where F="lrev_body3"])
      apply (fold lrev_work3_def lrev_work2_def)
      apply (simp add: lrev_body3.unfold lrev_body2.unfold lrev_wwfusion)
      done
  qed simp_all
qed

text{* Use the combined worker/wrapper-fusion rule. Note we get a weaker lemma. *}

lemma lrev3_2_syntactic: "lrev_body3 oo (unwrapH oo wrapH) = lrev_body2"
  apply (subst lrev_body2.unfold, subst lrev_body3.unfold)
  apply (rule cfun_eqI)+
  apply (case_tac xa)
    apply (simp_all add: unwrapH_def)
  done

lemma lrev_work3_lrev_work2_eq': "lrev = wrapH\<cdot>lrev_work3"
proof -
  from lrev_lrev_body_eq
  have "lrev = fix\<cdot>lrev_body" .
  also from wrapH_unwrapH_id unwrapH_strict
  have "\<dots> = wrapH\<cdot>(fix\<cdot>lrev_body3)"
    by (rule worker_wrapper_fusion_new
       , simp add: lrev3_2_syntactic lrev_body2_lrev_body1_eq lrev_body_lrev_body1_eq)
  finally show ?thesis unfolding lrev_work3_def by simp
qed

text{* Final syntactic tidy-up. *}

fixrec lrev_body_final :: "('a llist \<rightarrow> 'a H) \<rightarrow> 'a llist \<rightarrow> 'a H"
where
  "lrev_body_final\<cdot>r\<cdot>lnil\<cdot>ys = ys"
| "lrev_body_final\<cdot>r\<cdot>(x :@ xs)\<cdot>ys = r\<cdot>xs\<cdot>(x :@ ys)"

definition
  lrev_work_final :: "'a llist \<rightarrow> 'a H" where
  "lrev_work_final \<equiv> fix\<cdot>lrev_body_final"

definition
  lrev_final :: "'a llist \<rightarrow> 'a llist" where
  "lrev_final \<equiv> \<Lambda> xs. lrev_work_final\<cdot>xs\<cdot>lnil"

lemma lrev_body_final_lrev_body3_eq': "lrev_body_final\<cdot>r\<cdot>xs = lrev_body3\<cdot>r\<cdot>xs"
  apply (subst lrev_body_final.unfold)
  apply (subst lrev_body3.unfold)
  apply (cases xs)
  apply (simp_all add: list2H_def ID_def cfun_eqI)
  done

lemma lrev_body_final_lrev_body3_eq: "lrev_body_final = lrev_body3"
  by (simp only: lrev_body_final_lrev_body3_eq' cfun_eqI)

lemma lrev_final_lrev_eq: "lrev = lrev_final" (is "?lhs = ?rhs")
proof -
  have "?lhs = lrev_wrap" by (rule lrev_lrev_ww_eq)
  also have "\<dots> = wrapH\<cdot>lrev_work" by (simp only: lrev_wrap_def)
  also have "\<dots> = wrapH\<cdot>lrev_work1" by (simp only: lrev_work1_lrev_work_eq)
  also have "\<dots> = wrapH\<cdot>lrev_work2" by (simp only: lrev_work2_lrev_work1_eq)
  also have "\<dots> = wrapH\<cdot>lrev_work3" by (simp only: lrev_work3_lrev_work2_eq)
  also have "\<dots> = wrapH\<cdot>lrev_work_final" by (simp only: lrev_work3_def lrev_work_final_def lrev_body_final_lrev_body3_eq)
  also have "\<dots> = lrev_final" by (simp add: lrev_final_def cfun_eqI H2list_def wrapH_def)
  finally show ?thesis .
qed

(*<*)
end
(*>*)


theory prop_31
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  fun qrev :: "'a list => 'a list => 'a list" where
  "qrev (Nil2) y = y"
  | "qrev (Cons2 z xs) y = qrev xs (Cons2 z y)"
  (*hipster qrev *)

lemma lemma_a [thy_expl]: "qrev (qrev x2 y2) Nil2 = qrev y2 x2"
by (hipster_induct_schemes qrev.simps)

  theorem x0 :
    "(qrev (qrev x (Nil2)) (Nil2)) = x"
    by (hipster_induct_schemes qrev.simps)
end


theory Summary
  imports VertexCover4ToMetricTravelingSalesman
begin

section \<open>Reduction Functions\<close>

fun V\<^sub>H :: "'g1 \<Rightarrow> 'v2set" where
  "V\<^sub>H G = fold_g1_uedges1 (union2 o V\<^sub>H\<^sub>e) G set_empty2"
  \<comment> \<open>Compute the vertices of the graph \<open>H := f G\<close>.\<close>

fun f :: "'g1 \<Rightarrow> 'g2" where
  "f G = complete_graph (V\<^sub>H G)" \<comment> \<open>The graph \<open>H\<close> is the complete graph for the vertices \<open>V\<^sub>H\<close>.\<close>

fun c :: "'g1 \<Rightarrow> ('v1 uedge \<times> 'v1 \<times> nat) \<Rightarrow> ('v1 uedge \<times> 'v1 \<times> nat) \<Rightarrow> nat" where
  "c G (e\<^sub>1,w\<^sub>1,i\<^sub>1) (e\<^sub>2,w\<^sub>2,i\<^sub>2) =
    (if is_edge_in_H\<^sub>e G (uEdge (e\<^sub>1,w\<^sub>1,i\<^sub>1) (e\<^sub>2,w\<^sub>2,i\<^sub>2)) then 1
    else if are_vertices_in_H\<^sub>e G (e\<^sub>1,w\<^sub>1,i\<^sub>1) (e\<^sub>2,w\<^sub>2,i\<^sub>2) then
      the_enat (min_dist_in_H\<^sub>e G (e\<^sub>1,w\<^sub>1,i\<^sub>1) (e\<^sub>2,w\<^sub>2,i\<^sub>2))
    else if w\<^sub>1 = w\<^sub>2 \<and> rep1 e\<^sub>1 \<noteq> rep1 e\<^sub>2 then 4
    else 5)"

fun g :: "'g1 \<Rightarrow> ('v1 uedge \<times> 'v1 \<times> nat) list \<Rightarrow> 'v1set" where
  "g G T = fold_g1_uedges5 (insert1 o (map_edge_to_covering_vertex G T)) G set_empty1"

section \<open>Feasibility of Reduction Functions\<close>

lemma f_is_complete:
  assumes "g1.ugraph_adj_map_invar G"
  shows "is_complete (set_of_uedge ` g2.uedges (f G))"
  \<comment> \<open>The graph \<open>f G\<close> is complete.\<close>
  sorry

lemma c_tri_inequality:
  assumes "x \<in> g2.vertices (f G)" "y \<in> g2.vertices (f G)" "z \<in> g2.vertices (f G)"
  shows "c G x z \<le> c G x y + c G y z"
  \<comment> \<open>The cost function \<open>c\<close> for the graph \<open>f G\<close> satisfies the triangle-inequality.\<close>
  sorry (* TODO *)

lemma g_is_vc:
  assumes "g1.ugraph_adj_map_invar G" and "g2.is_hc_Adj (f G) T"
  shows "g1.is_vc_Adj G (g G T)"
  \<comment> \<open>The function \<open>g\<close> always computes a vertex cover of the graph \<open>G\<close> (feasible solution).\<close>
  sorry

section \<open>Reduction Properties\<close>

lemma l_reduction1:
  assumes "g1.ugraph_adj_map_invar G"
      and max_degree: "\<And>v. v \<in> g1.vertices G \<Longrightarrow> g1.degree_Adj G v \<le> enat 4"
      and opt_vc: "g1.is_min_vc_Adj G OPT\<^sub>V\<^sub>C"
      and opt_mtsp: "g2.is_tsp_Adj (f G) (c G) OPT\<^sub>m\<^sub>T\<^sub>S\<^sub>P"
  shows "cost_of_path (c G) OPT\<^sub>m\<^sub>T\<^sub>S\<^sub>P \<le> 61 * card (set1 OPT\<^sub>V\<^sub>C)" (is "?c' OPT\<^sub>m\<^sub>T\<^sub>S\<^sub>P \<le> ?\<alpha> * ?\<tau>_G")
  \<comment> \<open>First condition for a L-Reduction.\<close>
  sorry

lemma l_reduction2:
  assumes "g1.ugraph_adj_map_invar G"
      and opt_vc: "g1.is_min_vc_Adj G OPT\<^sub>V\<^sub>C"
      and opt_mtsp: "g2.is_tsp_Adj (f G) (c G) OPT\<^sub>m\<^sub>T\<^sub>S\<^sub>P"
      and "g2.is_hc_Adj (f G) T"
  shows "\<bar> card (set1 (g G T)) - card (set1 OPT\<^sub>V\<^sub>C) \<bar>
    \<le> 1 * \<bar> cost_of_path (c G) T - cost_of_path (c G) OPT\<^sub>m\<^sub>T\<^sub>S\<^sub>P \<bar>" (is "\<bar> card _ - ?\<tau>_G \<bar> \<le> _")
  \<comment> \<open>Second condition for a L-Reduction.\<close>
  sorry

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_NStoogeSortCount
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

(*fun did not finish the proof*)
function third :: "int => int" where
  "third y =
   (if (y = 2) then 0 else
      (if (y = 1) then 0 else
         (if (y = 0) then 0 else 1 + (third (y - 3)))))"
  by pat_completeness auto

fun take :: "int => 'a list => 'a list" where
  "take y z =
   (if y <= 0 then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => cons2 z2 (take (y - 1) xs)))"

fun sort2 :: "int => int => int list" where
  "sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun reverse :: "'a list => 'a list" where
  "reverse (nil2) = nil2"
| "reverse (cons2 z xs) = x (reverse xs) (cons2 z (nil2))"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 z l) = 1 + (length l)"

fun drop :: "int => 'a list => 'a list" where
  "drop y z =
   (if y <= 0 then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => drop (y - 1) xs1))"

fun splitAt :: "int => 'a list =>
                (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge1sort2 :: "int list => int list"
  and nstoogesort :: "int list => int list"
  and nstooge1sort1 :: "int list => int list" where
  "nstooge1sort2 y =
   (case splitAt (third (length y)) (reverse y) of
      pair2 ys2 zs2 => x (nstoogesort zs2) (reverse ys2))"
| "nstoogesort (nil2) = nil2"
| "nstoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge1sort2
       (nstooge1sort1 (nstooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge1sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort zs1))"
  by pat_completeness auto

fun count :: "'a => 'a list => int" where
  "count y (nil2) = 0"
| "count y (cons2 z2 ys) =
     (if (y = z2) then 1 + (count y ys) else count y ys)"

theorem property0 :
  "((count y (nstoogesort xs)) = (count y xs))"
  oops

end


section \<open> General Minimal Mereology \<close>

(*<*)
theory GMM
 imports GM MM
begin
(*>*)

text \<open> The theory of \emph{general minimal mereology} adds general mereology to minimal mereology.\footnote{
See \<^cite>\<open>"casati_parts_1999"\<close> p. 46.} \<close>

locale GMM = GM + MM
begin

text \<open> It is natural to assume that just as closed minimal mereology and closed extensional mereology
are the same theory, so are general minimal mereology and general extensional mereology.\footnote{For
this mistake see \<^cite>\<open>"simons_parts:_1987"\<close> p. 37 and \<^cite>\<open>"casati_parts_1999"\<close> p. 46. The mistake
is corrected in \<^cite>\<open>"pontow_note_2004"\<close> and \<^cite>\<open>"hovda_what_2009"\<close>. For discussion of the significance
of this issue see, for example, \<^cite>\<open>"varzi_universalism_2009"\<close> and \<^cite>\<open>"cotnoir_does_2016"\<close>.}
But this is not the case, since the proof of strong supplementation in closed minimal mereology
required the product closure axiom. However, in general minimal mereology, the fusion axiom does not
entail the product closure axiom. So neither product closure nor strong supplementation are theorems. \<close>

lemma product_closure:
  "O x y \<Longrightarrow> (\<exists> z. \<forall> v. P v z \<longleftrightarrow> P v x \<and> P v y)"
  nitpick [expect = genuine] oops

lemma strong_supplementation: "\<not> P x y \<Longrightarrow> (\<exists> z. P z x \<and> \<not> O z y)"
  nitpick [expect = genuine] oops

end

(*<*) end (*>*)


theory display
  imports Main def
begin
section "display proof"

subsection"display Antecedent"

lemma displayAnt : "ant_part Z (X \<turnstile>\<^sub>C Y) \<Longrightarrow> \<exists>W.((X \<turnstile>\<^sub>C Y) \<equiv>\<^sub>D (Z \<turnstile>\<^sub>C W))"
  apply simp
proof-
  have "pos_ant Z X \<Longrightarrow> \<forall>Y.\<exists>W.((X \<turnstile>\<^sub>C Y) \<equiv>\<^sub>D (Z \<turnstile>\<^sub>C W))"
       and "neg_con Z Y \<Longrightarrow> \<forall>X.\<exists>W.((X \<turnstile>\<^sub>C Y) \<equiv>\<^sub>D (Z \<turnstile>\<^sub>C W))"
  proof(induction rule: pos_ant_neg_con.inducts)
case (1 X)
then show ?case
  using display_refl by blast
next
  case (2 Z X)
  then show ?case
    using  display_trans postulateCL5 postulateCL5S postulateCL6S by metis
next
case (3 Z X1 X2)
  then show ?case
    using display_trans postulateCL1 by blast
next
  case (4 Z X2 X1)
then show ?case
  using display_trans postulateCL2S by blast
next
  case (5 Z X1 X2)
  then show ?case
    using display_trans postulateCL7 by blast
next
  case (6 Z X2 X1)
  then show ?case
    using display_trans postulateCL8S by blast
next
  case (7 Z X)
  then show ?case
    using display_trans postulateCL5 postulateCL5S postulateCL6 by metis
next
  case (8 Z X1 X2)
  then show ?case
    using display_trans postulateCL4S by blast
next
  case (9 Z X2 X1)
  then show ?case
    using display_trans postulateCL3 by blast
next
  case (10 Z X1 X2)
  then show ?case
    using display_trans postulateCL7 postulateCL8 by blast
next
  case (11 Z X2 X1)
  then show ?case
    using display_trans postulateCL8 by blast
qed
  then show "pos_ant Z X \<or> neg_con Z Y \<Longrightarrow> \<exists>W. (X \<turnstile>\<^sub>C Y) \<equiv>\<^sub>D (Z \<turnstile>\<^sub>C W)"
    by blast
qed

subsection"display Consequent"
lemma displayCon : "con_part Z (X \<turnstile>\<^sub>C Y) \<Longrightarrow> \<exists>W.((X \<turnstile>\<^sub>C Y) \<equiv>\<^sub>D (W \<turnstile>\<^sub>C Z))"
  apply simp
proof-
  have "pos_con Z Y \<Longrightarrow>  \<forall>X.\<exists>W.((X \<turnstile>\<^sub>C Y) \<equiv>\<^sub>D (W \<turnstile>\<^sub>C Z))"
       and "neg_ant Z X \<Longrightarrow>  \<forall>Y.\<exists>W.((X \<turnstile>\<^sub>C Y) \<equiv>\<^sub>D (W \<turnstile>\<^sub>C Z))"
  proof(induction rule: pos_con_neg_ant.inducts)
case (1 X)
then show ?case
  using display_refl by blast
next
case (2 Z X)
then show ?case
  using display_trans postulateCL5 postulateCL5S postulateCL6S by metis
next
  case (3 Z X1 X2)
  then show ?case
    using display_trans postulateCL4S by blast
next
  case (4 Z X2 X1)
  then show ?case
    using display_trans postulateCL3 by blast
next
  case (5 Z X1 X2)
  then show ?case
    using display_trans postulateCL7 postulateCL8 by blast
next
  case (6 Z X2 X1)
  then show ?case
    using display_trans postulateCL8 by blast
next
  case (7 Z X)
  then show ?case
    using display_trans postulateCL5 postulateCL5S postulateCL6S by metis
next
  case (8 Z X1 X2)
  then show ?case
    using display_trans postulateCL1 by blast
next
  case (9 Z X2 X1)
  then show ?case
    using display_trans postulateCL2S by blast
next
  case (10 Z X1 X2)
  then show ?case
    using display_trans postulateCL7 by blast
next
  case (11 Z X2 X1)
  then show ?case
    using display_trans postulateCL8S by blast
qed
  then show "neg_ant Z X \<or> pos_con Z Y \<Longrightarrow> \<exists>W. (X \<turnstile>\<^sub>C Y) \<equiv>\<^sub>D (W \<turnstile>\<^sub>C Z)"
    by blast
qed
end


(*  Title:      HOL/Datatype_Examples/Derivation_Trees/DTree.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Derivation trees with nonterminal internal nodes and terminal leaves.
*)

section \<open>Trees with Nonterminal Internal Nodes and Terminal Leaves\<close>

theory DTree
imports Prelim
begin

typedecl N
typedecl T

codatatype dtree = NNode (root: N) (ccont: "(T + dtree) fset")

subsection\<open>Transporting the Characteristic Lemmas from \<open>fset\<close> to \<open>set\<close>\<close>

definition "Node n as \<equiv> NNode n (the_inv fset as)"
definition "cont \<equiv> fset o ccont"
definition "unfold rt ct \<equiv> corec_dtree rt (the_inv fset o image (map_sum id Inr) o ct)"
definition "corec rt ct \<equiv> corec_dtree rt (the_inv fset o ct)"

lemma finite_cont[simp]: "finite (cont tr)"
  unfolding cont_def comp_apply by (cases tr, clarsimp)

lemma Node_root_cont[simp]:
  "Node (root tr) (cont tr) = tr"
  unfolding Node_def cont_def comp_apply
  apply (rule trans[OF _ dtree.collapse])
  apply (rule arg_cong2[OF refl the_inv_into_f_f[unfolded inj_on_def]])
  apply (simp_all add: fset_inject)
  done

lemma dtree_simps[simp]:
assumes "finite as" and "finite as'"
shows "Node n as = Node n' as' \<longleftrightarrow> n = n' \<and> as = as'"
using assms dtree.inject unfolding Node_def
by (metis fset_to_fset)

lemma dtree_cases[elim, case_names Node Choice]:
assumes Node: "\<And> n as. \<lbrakk>finite as; tr = Node n as\<rbrakk> \<Longrightarrow> phi"
shows phi
apply(cases rule: dtree.exhaust[of tr])
using Node unfolding Node_def
by (metis Node Node_root_cont finite_cont)

lemma dtree_sel_ctr[simp]:
"root (Node n as) = n"
"finite as \<Longrightarrow> cont (Node n as) = as"
unfolding Node_def cont_def by auto

lemmas root_Node = dtree_sel_ctr(1)
lemmas cont_Node = dtree_sel_ctr(2)

lemma dtree_cong:
assumes "root tr = root tr'" and "cont tr = cont tr'"
shows "tr = tr'"
by (metis Node_root_cont assms)

lemma rel_set_cont:
"rel_set \<chi> (cont tr1) (cont tr2) = rel_fset \<chi> (ccont tr1) (ccont tr2)"
unfolding cont_def comp_def rel_fset_fset ..

lemma dtree_coinduct[elim, consumes 1, case_names Lift, induct pred: "HOL.eq"]:
assumes phi: "\<phi> tr1 tr2" and
Lift: "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow>
                  root tr1 = root tr2 \<and> rel_set (rel_sum (=) \<phi>) (cont tr1) (cont tr2)"
shows "tr1 = tr2"
using phi apply(elim dtree.coinduct)
apply(rule Lift[unfolded rel_set_cont]) .

lemma unfold:
"root (unfold rt ct b) = rt b"
"finite (ct b) \<Longrightarrow> cont (unfold rt ct b) = image (id \<oplus> unfold rt ct) (ct b)"
using dtree.corec_sel[of rt "the_inv fset o image (map_sum id Inr) o ct" b] unfolding unfold_def
apply blast
unfolding cont_def comp_def
by (simp add: case_sum_o_inj map_sum.compositionality image_image)

lemma corec:
"root (corec rt ct b) = rt b"
"finite (ct b) \<Longrightarrow> cont (corec rt ct b) = image (id \<oplus> ([[id, corec rt ct]])) (ct b)"
using dtree.corec_sel[of rt "the_inv fset \<circ> ct" b] unfolding corec_def
unfolding cont_def comp_def id_def
by simp_all

end


(*  Title:      JinjaThreads/DFA/Kildall.thy
    Author:     Tobias Nipkow, Gerwin Klein, Andreas Lochbihler
    Copyright   2000 TUM, 2010 KIT

Kildall's algorithm.
*)

section \<open>Kildall's Algorithm \label{sec:Kildall}\<close>

theory Kildall
imports SemilatAlg "../Basic/Auxiliary"
begin

locale Kildall_base =
  fixes s_\<alpha> :: "'w \<Rightarrow> nat set"
  and s_empty :: "'w"
  and s_is_empty :: "'w \<Rightarrow> bool"
  and s_choose :: "'w \<Rightarrow> nat"
  and s_remove :: "nat \<Rightarrow> 'w \<Rightarrow> 'w"
  and s_insert :: "nat \<Rightarrow> 'w \<Rightarrow> 'w"
begin

primrec propa :: "'s binop \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's list \<Rightarrow> 'w \<Rightarrow> 's list * 'w"
where
  "propa f []      \<tau>s w = (\<tau>s,w)"
| "propa f (q'#qs) \<tau>s w = (let (q,\<tau>) = q';
                             u = \<tau> \<squnion>\<^bsub>f\<^esub> \<tau>s!q;
                             w' = (if u = \<tau>s!q then w else s_insert q w)
                         in propa f qs (\<tau>s[q := u]) w')"

definition iter :: "'s binop \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> 'w \<Rightarrow> 's list \<times> 'w"
where
  "iter f step \<tau>s w =
  while (\<lambda>(\<tau>s,w). \<not> s_is_empty w)
        (\<lambda>(\<tau>s,w). let p = s_choose w in propa f (step p (\<tau>s!p)) \<tau>s (s_remove p w))
        (\<tau>s,w)"

definition unstables :: "'s ord \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> 'w"
where
  "unstables r step \<tau>s = foldr s_insert (filter (\<lambda>p. \<not>stable r step \<tau>s p) [0..<size \<tau>s]) s_empty"

definition kildall :: "'s ord \<Rightarrow> 's binop \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> 's list"
where "kildall r f step \<tau>s \<equiv> fst(iter f step \<tau>s (unstables r step \<tau>s))"

primrec t_\<alpha> :: "'s list \<times> 'w \<Rightarrow> 's list \<times> nat set"
where "t_\<alpha> (\<tau>s, w) = (\<tau>s, s_\<alpha> w)"

end

primrec merges :: "'s binop \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's list \<Rightarrow> 's list"
where
  "merges f []      \<tau>s = \<tau>s"
| "merges f (p'#ps) \<tau>s = (let (p,\<tau>) = p' in merges f ps (\<tau>s[p := \<tau> \<squnion>\<^bsub>f\<^esub> \<tau>s!p]))"

locale Kildall =
  Kildall_base +
  assumes empty_spec [simp]: "s_\<alpha> s_empty = {}"
  and is_empty_spec [simp]: "s_is_empty A \<longleftrightarrow> s_\<alpha> A = {}"
  and choose_spec: "s_\<alpha> A \<noteq> {} \<Longrightarrow> s_choose A \<in> s_\<alpha> A"
  and remove_spec [simp]: "s_\<alpha> (s_remove n A) = s_\<alpha> A - {n}"
  and insert_spec [simp]: "s_\<alpha> (s_insert n A) = insert n (s_\<alpha> A)"
begin

lemma s_\<alpha>_foldr_s_insert:
  "s_\<alpha> (foldr s_insert xs A) = foldr insert xs (s_\<alpha> A)"
by(induct xs arbitrary: A) simp_all

lemma unstables_spec [simp]: "s_\<alpha> (unstables r step \<tau>s) = {p. p < size \<tau>s \<and> \<not>stable r step \<tau>s p}"
proof -
  have "{p. p < size \<tau>s \<and> \<not>stable r step \<tau>s p} = foldr insert (filter (\<lambda>p. \<not>stable r step \<tau>s p) [0..<size \<tau>s]) {}"
    unfolding foldr_insert_conv_set by auto
  thus ?thesis by(simp add: unstables_def s_\<alpha>_foldr_s_insert)
qed

end

lemmas [simp] = Let_def Semilat.le_iff_plus_unchanged [OF Semilat.intro, symmetric]

lemma (in Semilat) nth_merges:
 "\<And>ss. \<lbrakk>p < length ss; ss \<in> list n A; \<forall>(p,t)\<in>set ps. p<n \<and> t\<in>A \<rbrakk> \<Longrightarrow>
  (merges f ps ss)!p = map snd [(p',t') \<leftarrow> ps. p'=p] \<Squnion>\<^bsub>f\<^esub> ss!p"
  (is "\<And>ss. \<lbrakk>_; _; ?steptype ps\<rbrakk> \<Longrightarrow> ?P ss ps")
(*<*)
proof (induct ps)
  show "\<And>ss. ?P ss []" by simp

  fix ss p' ps'
  assume ss: "ss \<in> list n A"
  assume l:  "p < length ss"
  assume "?steptype (p'#ps')"
  then obtain a b where
    p': "p'=(a,b)" and ab: "a<n" "b\<in>A" and ps': "?steptype ps'"
    by (cases p') auto
  assume "\<And>ss. p< length ss \<Longrightarrow> ss \<in> list n A \<Longrightarrow> ?steptype ps' \<Longrightarrow> ?P ss ps'"
  hence IH: "\<And>ss. ss \<in> list n A \<Longrightarrow> p < length ss \<Longrightarrow> ?P ss ps'" using ps' by iprover

  from ss ab
  have "ss[a := b \<squnion>\<^bsub>f\<^esub> ss!a] \<in> list n A" by (simp add: closedD)
  moreover
  with l have "p < length (ss[a := b \<squnion>\<^bsub>f\<^esub> ss!a])" by simp
  ultimately
  have "?P (ss[a := b \<squnion>\<^bsub>f\<^esub> ss!a]) ps'" by (rule IH)
  with p' l
  show "?P ss (p'#ps')" by simp
qed
(*>*)

(** merges **)

lemma length_merges [simp]:
  "\<And>ss. size(merges f ps ss) = size ss"
(*<*) by (induct ps, auto) (*>*)

lemma (in Semilat) merges_preserves_type_lemma:
shows "\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x) \<in> set ps. p<n \<and> x\<in>A)
         \<longrightarrow> merges f ps xs \<in> list n A"
(*<*)
apply (insert closedI)
apply (unfold Semilat.closed_def)
apply (induct ps)
 apply simp
apply clarsimp
done
(*>*)

lemma (in Semilat) merges_preserves_type [simp]:
 "\<lbrakk> xs \<in> list n A; \<forall>(p,x) \<in> set ps. p<n \<and> x\<in>A \<rbrakk>
  \<Longrightarrow> merges f ps xs \<in> list n A"
by (simp add: merges_preserves_type_lemma)

lemma (in Semilat) merges_incr_lemma:
 "\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x)\<in>set ps. p<size xs \<and> x \<in> A) \<longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] merges f ps xs"
(*<*)
apply (induct ps)
 apply simp
apply simp
apply clarify
apply (rule order_trans)
  apply simp
 apply (erule list_update_incr)
  apply simp
 apply simp
apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
done
(*>*)

lemma (in Semilat) merges_incr:
 "\<lbrakk> xs \<in> list n A; \<forall>(p,x)\<in>set ps. p<size xs \<and> x \<in> A \<rbrakk>
  \<Longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] merges f ps xs"
  by (simp add: merges_incr_lemma)

lemma (in Semilat) merges_same_conv [rule_format]:
 "(\<forall>xs. xs \<in> list n A \<longrightarrow> (\<forall>(p,x)\<in>set ps. p<size xs \<and> x\<in>A) \<longrightarrow>
     (merges f ps xs = xs) = (\<forall>(p,x)\<in>set ps. x \<sqsubseteq>\<^bsub>r\<^esub> xs!p))"
(*<*)
  apply (induct_tac ps)
   apply simp
  apply clarsimp
  apply (rename_tac p x ps xs)
  apply (rule iffI)
   apply (rule context_conjI)
    apply (subgoal_tac "xs[p := x \<squnion>\<^bsub>f\<^esub> xs!p] [\<sqsubseteq>\<^bsub>r\<^esub>] xs")
     apply (force dest!: le_listD simp add: nth_list_update)
    apply (erule subst, rule merges_incr)
       apply (blast intro!: listE_set intro: closedD listE_length [THEN nth_in])
      apply clarify
      apply (rule conjI)
       apply simp
       apply (blast dest: boundedD)
      apply blast
   apply clarify
   apply (erule allE)
   apply (erule impE)
    apply assumption
   apply (drule bspec)
    apply assumption
   apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
   apply blast
  apply clarify
  apply (simp add: le_iff_plus_unchanged [THEN iffD1] list_update_same_conv [THEN iffD2])
  done
(*>*)

lemma (in Semilat) list_update_le_listI [rule_format]:
  "set xs \<subseteq> A \<longrightarrow> set ys \<subseteq> A \<longrightarrow> xs [\<sqsubseteq>\<^bsub>r\<^esub>] ys \<longrightarrow> p < size xs \<longrightarrow>
   x \<sqsubseteq>\<^bsub>r\<^esub> ys!p \<longrightarrow> x\<in>A \<longrightarrow> xs[p := x \<squnion>\<^bsub>f\<^esub> xs!p] [\<sqsubseteq>\<^bsub>r\<^esub>] ys"
(*<*)
  apply(insert semilat)
  apply (simp only: Listn.le_def lesub_def semilat_def)
  apply (simp add: list_all2_conv_all_nth nth_list_update)
  done
(*>*)

lemma (in Semilat) merges_pres_le_ub:
  assumes "set ts \<subseteq> A"  "set ss \<subseteq> A"
    "\<forall>(p,t)\<in>set ps. t \<sqsubseteq>\<^bsub>r\<^esub> ts!p \<and> t \<in> A \<and> p < size ts"  "ss [\<sqsubseteq>\<^bsub>r\<^esub>] ts"
  shows "merges f ps ss [\<sqsubseteq>\<^bsub>r\<^esub>] ts"
(*<*)
proof -
  { fix t ts ps
    have
    "\<And>qs. \<lbrakk>set ts \<subseteq> A; \<forall>(p,t)\<in>set ps. t \<sqsubseteq>\<^bsub>r\<^esub> ts!p \<and> t \<in> A \<and> p< size ts \<rbrakk> \<Longrightarrow>
    set qs \<subseteq> set ps  \<longrightarrow>
    (\<forall>ss. set ss \<subseteq> A \<longrightarrow> ss [\<sqsubseteq>\<^bsub>r\<^esub>] ts \<longrightarrow> merges f qs ss [\<sqsubseteq>\<^bsub>r\<^esub>] ts)"
    apply (induct_tac qs)
     apply simp
    apply (simp (no_asm_simp))
    apply clarify
    apply simp
    apply (erule allE, erule impE, erule_tac [2] mp)
     apply (drule bspec, assumption)
     apply (simp add: closedD)
    apply (drule bspec, assumption)
    apply (simp add: list_update_le_listI)
    done
  } note this [dest]
  from assms show ?thesis by blast
qed
(*>*)

context Kildall begin

subsection \<open>@{term propa}\<close>

lemma decomp_propa:
  "\<And>ss w. (\<forall>(q,t)\<in>set qs. q < size ss) \<Longrightarrow>
   t_\<alpha> (propa f qs ss w) =
   (merges f qs ss, {q. \<exists>t.(q,t)\<in>set qs \<and> t \<squnion>\<^bsub>f\<^esub> ss!q \<noteq> ss!q} \<union> s_\<alpha> w)"
  apply (induct qs)
   apply simp
  apply (simp (no_asm))
  apply clarify
  apply simp
  apply (rule conjI)
   apply blast
  apply (simp add: nth_list_update)
  apply blast
  done

end

lemma (in Semilat) stable_pres_lemma:
shows "\<lbrakk>pres_type step n A; bounded step n;
     ss \<in> list n A; p \<in> w; \<forall>q\<in>w. q < n;
     \<forall>q. q < n \<longrightarrow> q \<notin> w \<longrightarrow> stable r step ss q; q < n;
     \<forall>s'. (q,s') \<in> set (step p (ss!p)) \<longrightarrow> s' \<squnion>\<^bsub>f\<^esub> ss!q = ss!q;
     q \<notin> w \<or> q = p \<rbrakk>
  \<Longrightarrow> stable r step (merges f (step p (ss!p)) ss) q"
(*<*)
  apply (unfold stable_def)
  apply (subgoal_tac "\<forall>s'. (q,s') \<in> set (step p (ss!p)) \<longrightarrow> s' : A")
   prefer 2
   apply clarify
   apply (erule pres_typeD)
    prefer 3 apply assumption
    apply (rule listE_nth_in)
     apply assumption
    apply simp
   apply simp
  apply simp
  apply clarify
  apply (subst nth_merges)
       apply simp
       apply (blast dest: boundedD)
      apply assumption
     apply clarify
     apply (rule conjI)
      apply (blast dest: boundedD)
     apply (erule pres_typeD)
       prefer 3 apply assumption
      apply simp
     apply simp
apply(subgoal_tac "q < length ss")
prefer 2 apply simp
  apply (frule nth_merges [of q _ _ "step p (ss!p)"]) (* fixme: why does method subst not work?? *)
apply assumption
  apply clarify
  apply (rule conjI)
   apply (blast dest: boundedD)
  apply (erule pres_typeD)
     prefer 3 apply assumption
    apply simp
   apply simp
  apply (drule_tac P = "\<lambda>x. (a, b) \<in> set (step q x)" in subst)
   apply assumption

 apply (simp add: plusplus_empty)
 apply (cases "q \<in> w")
  apply simp
  apply (rule ub1')
     apply (rule Semilat.intro)
     apply (rule semilat)
    apply clarify
    apply (rule pres_typeD)
       apply assumption
      prefer 3 apply assumption
     apply (blast intro: listE_nth_in dest: boundedD)
    apply (blast intro: pres_typeD dest: boundedD)
   apply (blast intro: listE_nth_in dest: boundedD)
  apply assumption

 apply simp
 apply (erule allE, erule impE, assumption, erule impE, assumption)
 apply (rule order_trans)
   apply simp
  defer
 apply (rule pp_ub2)(*
    apply assumption*)
   apply simp
   apply clarify
   apply simp
   apply (rule pres_typeD)
      apply assumption
     prefer 3 apply assumption
    apply (blast intro: listE_nth_in dest: boundedD)
   apply (blast intro: pres_typeD dest: boundedD)
  apply (blast intro: listE_nth_in dest: boundedD)
 apply blast
 done
(*>*)

lemma (in Semilat) merges_bounded_lemma:
 "\<lbrakk> mono r step n A; bounded step n;
    \<forall>(p',s') \<in> set (step p (ss!p)). s' \<in> A; ss \<in> list n A; ts \<in> list n A; p < n;
    ss [\<sqsubseteq>\<^sub>r] ts; \<forall>p. p < n \<longrightarrow> stable r step ts p \<rbrakk>
  \<Longrightarrow> merges f (step p (ss!p)) ss [\<sqsubseteq>\<^sub>r] ts"
(*<*)
  apply (unfold stable_def)
  apply (rule merges_pres_le_ub)
     apply simp
    apply simp
   prefer 2 apply assumption

  apply clarsimp
  apply (drule boundedD, assumption+)
  apply (erule allE, erule impE, assumption)
  apply (drule bspec, assumption)
  apply simp

  apply (drule monoD [of _ _ _ _ p "ss!p"  "ts!p"])
     apply assumption
    apply simp
   apply (simp add: le_listD)

  apply (drule lesub_step_typeD, assumption)
  apply clarify
  apply (drule bspec, assumption)
  apply simp
  apply (blast intro: order_trans)
  done
(*>*)

lemma termination_lemma: assumes "Semilat A r f"
shows "\<lbrakk> ss \<in> list n A; \<forall>(q,t)\<in>set qs. q<n \<and> t\<in>A; p\<in>w \<rbrakk> \<Longrightarrow>
      ss [\<sqsubset>\<^sub>r] merges f qs ss \<or>
  merges f qs ss = ss \<and> {q. \<exists>t. (q,t)\<in>set qs \<and> t \<squnion>\<^bsub>f\<^esub> ss!q \<noteq> ss!q} \<union> (w-{p}) \<subset> w"
(*<*) (is "PROP ?P")
proof -
  interpret Semilat A r f by fact
  show "PROP ?P"
  apply(insert semilat)
    apply (unfold lesssub_def)
    apply (simp (no_asm_simp) add: merges_incr)
    apply (rule impI)
    apply (rule merges_same_conv [THEN iffD1, elim_format])
    apply assumption+
      defer
      apply (rule sym, assumption)
     defer apply simp
     apply (subgoal_tac "\<forall>q t. \<not>((q, t) \<in> set qs \<and> t \<squnion>\<^bsub>f\<^esub> ss ! q \<noteq> ss ! q)")
     apply (blast intro!: psubsetI elim: equalityE)
     apply clarsimp
     apply (drule bspec, assumption)
     apply (drule bspec, assumption)
     apply clarsimp
    done
qed
(*>*)

context Kildall_base begin

definition s_finite_psubset  :: "('w * 'w) set"
where "s_finite_psubset == {(A,B). s_\<alpha> A < s_\<alpha> B & finite (s_\<alpha> B)}"

lemma s_finite_psubset_inv_image:
  "s_finite_psubset = inv_image finite_psubset s_\<alpha>"
by(auto simp add: s_finite_psubset_def finite_psubset_def)

lemma wf_s_finite_psubset [simp]: "wf s_finite_psubset"
unfolding s_finite_psubset_inv_image by simp

end

context Kildall begin

subsection \<open>@{term iter}\<close>

lemma iter_properties[rule_format]: assumes "Semilat A r f"
shows "\<lbrakk> acc A r; pres_type step n A; mono r step n A;
     bounded step n; \<forall>p\<in>s_\<alpha> w0. p < n; ss0 \<in> list n A;
     \<forall>p<n. p \<notin> s_\<alpha> w0 \<longrightarrow> stable r step ss0 p \<rbrakk> \<Longrightarrow>
   t_\<alpha> (iter f step ss0 w0) = (ss',w')
   \<longrightarrow>
   ss' \<in> list n A \<and> stables r step ss' \<and> ss0 [\<sqsubseteq>\<^sub>r] ss' \<and>
   (\<forall>ts\<in>list n A. ss0 [\<sqsubseteq>\<^sub>r] ts \<and> stables r step ts \<longrightarrow> ss' [\<sqsubseteq>\<^sub>r] ts)"
(*<*) (is "PROP ?P")
proof -
  interpret Semilat A r f by fact
  show "PROP ?P"
  apply(insert semilat)
  apply (unfold iter_def stables_def)
  apply(unfold is_empty_spec)
  apply (rule_tac P = "\<lambda>(ss,w).
   ss \<in> list n A \<and> (\<forall>p<n. p \<notin> s_\<alpha> w \<longrightarrow> stable r step ss p) \<and> ss0 [\<sqsubseteq>\<^sub>r] ss \<and>
   (\<forall>ts\<in>list n A. ss0 [\<sqsubseteq>\<^sub>r] ts \<and> stables r step ts \<longrightarrow> ss [\<sqsubseteq>\<^sub>r] ts) \<and>
   (\<forall>p\<in> s_\<alpha> w. p < n)" and
   r = "{(ss',ss) . ss \<in> list n A \<and> ss' \<in> list n A \<and> ss [\<sqsubset>\<^sub>r] ss'} <*lex*> s_finite_psubset"
         in while_rule)

  \<comment> \<open>Invariant holds initially:\<close>
  apply (simp add:stables_def)

  \<comment> \<open>Invariant is preserved:\<close>
  apply(simp add: stables_def split_paired_all)
  apply(rename_tac ss w)
  apply(subgoal_tac "s_choose w \<in> s_\<alpha> w")
   prefer 2 apply(erule choose_spec)
  apply(subgoal_tac "\<forall>(q,t) \<in> set (step (s_choose w) (ss ! (s_choose w))). q < length ss \<and> t \<in> A")
   prefer 2
   apply clarify
   apply (rule conjI)
    apply(clarsimp, blast dest!: boundedD)
   apply (erule pres_typeD)
    prefer 3
    apply assumption
    apply (erule listE_nth_in)
    apply blast
   apply blast
  apply(subgoal_tac "(\<lambda>(ss, w).
              ss \<in> list n A \<and>
              (\<forall>p<n. p \<notin> w \<longrightarrow> stable r step ss p) \<and>
              ss0 [\<sqsubseteq>\<^bsub>r\<^esub>] ss \<and>
              (\<forall>ts\<in>list n A.
                  ss0 [\<sqsubseteq>\<^bsub>r\<^esub>] ts \<and> (\<forall>p<n. stable r step ts p) \<longrightarrow> ss [\<sqsubseteq>\<^bsub>r\<^esub>] ts) \<and>
              (\<forall>p\<in>w. p < n))
           (t_\<alpha> (propa f (step (s_choose w) (ss ! s_choose w)) ss
             (s_remove (s_choose w) w)))")
   apply(case_tac "propa f (step (s_choose w) (ss ! s_choose w)) ss (s_remove (s_choose w) w)")
   apply(simp)
  apply (subst decomp_propa)
   apply blast
  apply simp
  apply (rule conjI)
   apply (rule merges_preserves_type)
   apply blast
   apply clarify
   apply (rule conjI)
    apply(clarsimp, blast dest!: boundedD)
   apply (erule pres_typeD)
    prefer 3
    apply assumption
    apply (erule listE_nth_in)
    apply blast
   apply blast
  apply (rule conjI)
   apply clarify
   apply (blast intro!: stable_pres_lemma)
  apply (rule conjI)
   apply (blast intro!: merges_incr intro: le_list_trans)
  apply (rule conjI)
   apply clarsimp
   apply (blast intro!: merges_bounded_lemma)
  apply (blast dest!: boundedD)

  \<comment> \<open>Postcondition holds upon termination:\<close>
  apply(clarsimp simp add: stables_def split_paired_all)

  \<comment> \<open>Well-foundedness of the termination relation:\<close>
  apply (rule wf_lex_prod)
   apply (insert orderI [THEN acc_le_listI])
   apply (simp only: acc_def lesssub_def)
  apply (rule wf_s_finite_psubset)

  \<comment> \<open>Loop decreases along termination relation:\<close>
  apply(simp add: stables_def split_paired_all)
  apply(rename_tac ss w)
  apply(subgoal_tac "s_choose w \<in> s_\<alpha> w")
   prefer 2 apply (erule choose_spec)
  apply(subgoal_tac "\<forall>(q,t) \<in> set (step (s_choose w) (ss ! (s_choose w))). q < length ss \<and> t \<in> A")
   prefer 2
   apply clarify
   apply (rule conjI)
    apply(clarsimp, blast dest!: boundedD)
   apply (erule pres_typeD)
    prefer 3
    apply assumption
    apply (erule listE_nth_in)
    apply blast
   apply blast
  apply(subgoal_tac "(t_\<alpha> (propa f (step (s_choose w) (ss ! s_choose w)) ss
            (s_remove (s_choose w) w)),
           ss, s_\<alpha> w)
          \<in> {(ss', ss). ss \<in> list n A \<and> ss' \<in> list n A \<and> ss [\<sqsubset>\<^bsub>r\<^esub>] ss'} <*lex*> finite_psubset")
   prefer 2
   apply (subst decomp_propa)
    apply blast
   apply clarify
   apply (simp del: listE_length
               add: lex_prod_def finite_psubset_def bounded_nat_set_is_finite)
   apply(subgoal_tac "merges f (step (s_choose w) (ss ! s_choose w)) ss \<in> list n A")
    apply simp
    apply (rule termination_lemma)
    apply (rule assms)
    apply assumption+
   apply clarsimp
  apply(case_tac "propa f (step (s_choose w) (ss ! s_choose w)) ss
               (s_remove (s_choose w) w)")
  apply(simp add: s_finite_psubset_inv_image)
  done
qed
(*>*)

lemma kildall_properties: assumes "Semilat A r f"
shows "\<lbrakk> acc A r; pres_type step n A; mono r step n A;
     bounded step n; ss0 \<in> list n A \<rbrakk> \<Longrightarrow>
  kildall r f step ss0 \<in> list n A \<and>
  stables r step (kildall r f step ss0) \<and>
  ss0 [\<sqsubseteq>\<^sub>r] kildall r f step ss0 \<and>
  (\<forall>ts\<in>list n A. ss0 [\<sqsubseteq>\<^sub>r] ts \<and> stables r step ts \<longrightarrow>
                 kildall r f step ss0 [\<sqsubseteq>\<^sub>r] ts)"
(*<*) (is "PROP ?P")
proof -
  interpret Semilat A r f by fact
  show "PROP ?P"
  apply (unfold kildall_def)
  apply(case_tac "iter f step ss0 (unstables r step ss0)")
  apply(simp)
  apply (rule iter_properties[where ?w0.0="unstables r step ss0"])
  apply(rule assms)
  apply (simp_all add: unstables_def stable_def s_\<alpha>_foldr_s_insert foldr_insert_conv_set)
  done
qed

lemma is_bcv_kildall: assumes "Semilat A r f"
shows "\<lbrakk> acc A r; top r T; pres_type step n A; bounded step n; mono r step n A \<rbrakk>
  \<Longrightarrow> is_bcv r T step n A (kildall r f step)" (is "PROP ?P")
proof -
  interpret Semilat A r f by fact
  show "PROP ?P"
  apply(unfold is_bcv_def wt_step_def)
  apply(insert \<open>Semilat A r f\<close> semilat kildall_properties[of A])
  apply(simp add:stables_def)
  apply clarify
  apply(subgoal_tac "kildall r f step \<tau>s\<^sub>0 \<in> list n A")
   prefer 2 apply (simp(no_asm_simp))
  apply (rule iffI)
   apply (rule_tac x = "kildall r f step \<tau>s\<^sub>0" in bexI)
    apply (rule conjI)
     apply (blast)
    apply (simp  (no_asm_simp))
   apply(assumption)
  apply clarify
  apply(subgoal_tac "kildall r f step \<tau>s\<^sub>0!p <=_r \<tau>s!p")
   apply simp
  apply (blast intro!: le_listD less_lengthI)
  done
qed
(*>*)

end

interpretation Kildall "set" "[]" "\<lambda>xs. xs = []" "hd" "removeAll" "Cons"
by(unfold_locales) auto

lemmas kildall_code [code] =
  kildall_def
  Kildall_base.propa.simps
  Kildall_base.iter_def
  Kildall_base.unstables_def
  Kildall_base.kildall_def

end


header{*Uniqueness Results: Syntactic Relations are Functions*}

theory Functions
imports Coding_Predicates
begin

subsection {*SeqStTermP*}

lemma not_IndP_VarP: "{IndP x, VarP x} \<turnstile> A"
proof -
  obtain m::name  where "atom m \<sharp> (x,A)"
    by (metis obtain_fresh)
  thus ?thesis
    by  (auto simp: fresh_Pair) (blast intro: ExFalso cut_same [OF VarP_cong [THEN Iff_MP_same]])
qed

text{*It IS a pair, but not just any pair.*}
lemma IndP_HPairE: "insert (IndP (HPair (HPair Zero (HPair Zero Zero)) x)) H \<turnstile> A"
proof -
  obtain m::name  where "atom m \<sharp> (x,A)"
    by (metis obtain_fresh)
  hence "{ IndP (HPair (HPair Zero (HPair Zero Zero)) x) } \<turnstile> A"
    by (auto simp: IndP.simps [of m] HTuple_minus_1 intro: thin1)
  thus ?thesis
    by (metis Assume cut1)
qed

lemma atom_HPairE:
  assumes "H \<turnstile> x EQ HPair (HPair Zero (HPair Zero Zero)) y"
    shows "insert (IndP x OR x NEQ v) H \<turnstile> A"
proof -
  have "{ IndP x OR x NEQ v, x EQ HPair (HPair Zero (HPair Zero Zero)) y } \<turnstile> A"
    by (auto intro!: OrdNotEqP_OrdP_E IndP_HPairE
             intro: cut_same [OF IndP_cong [THEN Iff_MP_same]]
                    cut_same [OF OrdP_cong [THEN Iff_MP_same]])
  thus ?thesis
    by (metis Assume assms rcut2)
qed

lemma SeqStTermP_lemma:
  assumes "atom m \<sharp> (v,i,t,u,s,k,n,sm,sm',sn,sn')" "atom n \<sharp> (v,i,t,u,s,k,sm,sm',sn,sn')"
          "atom sm \<sharp> (v,i,t,u,s,k,sm',sn,sn')" "atom sm' \<sharp> (v,i,t,u,s,k,sn,sn')"
          "atom sn \<sharp> (v,i,t,u,s,k,sn')" "atom sn' \<sharp> (v,i,t,u,s,k)"
    shows "{ SeqStTermP v i t u s k }
           \<turnstile> ((t EQ v AND u EQ i) OR
              ((IndP t OR t NEQ v) AND u EQ t)) OR
              Ex m (Ex n (Ex sm (Ex sm' (Ex sn (Ex sn' (Var m IN k AND Var n IN k AND
                       SeqStTermP v i (Var sm) (Var sm') s (Var m) AND
                       SeqStTermP v i (Var sn) (Var sn') s (Var n) AND
                       t EQ Q_Eats (Var sm) (Var sn) AND
                       u EQ Q_Eats (Var sm') (Var sn')))))))"
proof -
  obtain l::name and sl::name and sl'::name
    where "atom l \<sharp> (v,i,t,u,s,k,sl,sl',m,n,sm,sm',sn,sn')"
          "atom sl \<sharp> (v,i,t,u,s,k,sl',m,n,sm,sm',sn,sn')"
          "atom sl' \<sharp> (v,i,t,u,s,k,m,n,sm,sm',sn,sn')"
    by (metis obtain_fresh)
  thus ?thesis using assms
    apply (simp add: SeqStTermP.simps [of l s k v i sl sl' m n sm sm' sn sn'])
    apply (rule Conj_EH Ex_EH All2_SUCC_E [THEN rotate2] | simp)+
    apply (rule cut_same [where A = "HPair t u EQ HPair (Var sl) (Var sl')"])
    apply (metis Assume AssumeH(4) LstSeqP_EQ)
    apply clarify
    apply (rule Disj_EH)
    apply (rule Disj_I1)
    apply (rule anti_deduction)
    apply (rule Var_Eq_subst_Iff [THEN Sym_L, THEN Iff_MP_same])
    apply (rule Sym_L [THEN rotate2])
    apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same], force)
    --{*now the quantified case*}
    --{*auto could be used but is VERY SLOW*}
    apply (rule Ex_EH Conj_EH)+
    apply simp_all
    apply (rule Disj_I2)
    apply (rule Ex_I [where x = "Var m"], simp)
    apply (rule Ex_I [where x = "Var n"], simp)
    apply (rule Ex_I [where x = "Var sm"], simp)
    apply (rule Ex_I [where x = "Var sm'"], simp)
    apply (rule Ex_I [where x = "Var sn"], simp)
    apply (rule Ex_I [where x = "Var sn'"], simp)
    apply (simp_all add: SeqStTermP.simps [of l s _ v i sl sl' m n sm sm' sn sn'])
    apply ((rule Conj_I)+, blast intro: LstSeqP_Mem)+
    --{*first SeqStTermP subgoal*}
    apply (rule All2_Subset [OF Hyp], blast)
    apply (blast intro!: SUCC_Subset_Ord LstSeqP_OrdP, blast, simp)
    --{*next SeqStTermP subgoal*}
    apply ((rule Conj_I)+, blast intro: LstSeqP_Mem)+
    apply (rule All2_Subset [OF Hyp], blast)
    apply (blast intro!: SUCC_Subset_Ord LstSeqP_OrdP, blast, simp)
    --{*finally, the equality pair*}
    apply (blast intro: Trans)
    done
qed

lemma SeqStTermP_unique: "{SeqStTermP v a t u s kk, SeqStTermP v a t u' s' kk'} \<turnstile> u' EQ u"
proof -
  obtain i::name and j::name and j'::name and k::name and k'::name and l::name
     and m::name and n::name and sm::name and sn::name and sm'::name and sn'::name
     and m2::name and n2::name and sm2::name and sn2::name and sm2'::name and sn2'::name
    where atoms:  "atom i \<sharp> (s,s',v,a,t,u,u')"   "atom j \<sharp> (s,s',v,a,t,i,t,u,u')"
                  "atom j' \<sharp> (s,s',v,a,t,i,j,t,u,u')"
                  "atom k \<sharp> (s,s',v,a,t,u,u',kk',i,j,j')" "atom k' \<sharp> (s,s',v,a,t,u,u',k,i,j,j')"
                  "atom l \<sharp> (s,s',v,a,t,i,j,j',k,k')"
                  "atom m \<sharp> (s,s',v,a,i,j,j',k,k',l)"   "atom n \<sharp> (s,s',v,a,i,j,j',k,k',l,m)"
                  "atom sm \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n)"  "atom sn \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm)"
                  "atom sm' \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn)"   "atom sn' \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm')"
                  "atom m2 \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn')"   "atom n2 \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2)"
                  "atom sm2 \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2)"  "atom sn2 \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2)"
                  "atom sm2' \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2,sn2)"   "atom sn2' \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2,sn2,sm2')"
    by (metis obtain_fresh)
  have "{ OrdP (Var k), VarP v }
       \<turnstile> All i (All j (All j' (All k' (SeqStTermP v a (Var i) (Var j) s (Var k)
                                  IMP (SeqStTermP v a (Var i) (Var j') s' (Var k') IMP Var j' EQ Var j)))))"
    apply (rule OrdIndH [where j=l])
    using atoms apply auto
    apply (rule Swap)
    apply (rule cut_same)
    apply (rule cut1 [OF SeqStTermP_lemma [of m v a "Var i" "Var j" s "Var k" n sm sm' sn sn']], simp_all, blast)
    apply (rule cut_same)
    apply (rule cut1 [OF SeqStTermP_lemma [of m2 v a "Var i" "Var j'" s' "Var k'" n2 sm2 sm2' sn2 sn2']], simp_all, blast)
    apply (rule Disj_EH Conj_EH)+
    --{*case 1, both sides equal "v"*}
    apply (blast intro: Trans Sym)
    --{*case 2, @{term "Var i EQ v"} and also @{term "IndP (Var i) OR Var i NEQ v"}*}
    apply (rule Conj_EH Disj_EH)+
    apply (blast intro: IndP_cong [THEN Iff_MP_same] not_IndP_VarP [THEN cut2])
    apply (metis Assume OrdNotEqP_E)
    --{*case 3, both a variable and a pair*}
    apply (rule Ex_EH Conj_EH)+
    apply simp_all
    apply (rule cut_same [where A = "VarP (Q_Eats (Var sm) (Var sn))"])
    apply (blast intro: Trans Sym VarP_cong [where x=v, THEN Iff_MP_same] Hyp, blast)
    --{*towards remaining cases*}
    apply (rule Disj_EH Ex_EH)+
    --{*case 4, @{term "Var i EQ v"} and also @{term "IndP (Var i) OR Var i NEQ v"}*}
    apply (blast intro: IndP_cong [THEN Iff_MP_same] not_IndP_VarP [THEN cut2] OrdNotEqP_E)
    --{*case 5, @{term "Var i EQ v"} for both*}
    apply (blast intro: Trans Sym)
    --{*case 6, both an atom and a pair*}
    apply (rule Ex_EH Conj_EH)+
    apply simp_all
    apply (rule atom_HPairE)
    apply (simp add: HTuple.simps)
    apply (blast intro: Trans)
    --{*towards remaining cases*}
    apply (rule Conj_EH Disj_EH Ex_EH)+
    apply simp_all
    --{*case 7, both an atom and a pair*}
    apply (rule cut_same [where A = "VarP (Q_Eats (Var sm2) (Var sn2))"])
    apply (blast intro: Trans Sym VarP_cong [where x=v, THEN Iff_MP_same] Hyp, blast)
    --{*case 8, both an atom and a pair*}
    apply (rule Ex_EH Conj_EH)+
    apply simp_all
    apply (rule atom_HPairE)
    apply (simp add: HTuple.simps)
    apply (blast intro: Trans)
    --{*case 9, two Eats terms*}
    apply (rule Ex_EH Disj_EH Conj_EH)+
    apply simp_all
    apply (rule All_E' [OF Hyp, where x="Var m"], blast)
    apply (rule All_E' [OF Hyp, where x="Var n"], blast, simp)
    apply (rule Disj_EH, blast intro: thin1 ContraProve)+
    apply (rule All_E [where x="Var sm"], simp)
    apply (rule All_E [where x="Var sm'"], simp)
    apply (rule All_E [where x="Var sm2'"], simp)
    apply (rule All_E [where x="Var m2"], simp)
    apply (rule All_E [where x="Var sn", THEN rotate2], simp)
    apply (rule All_E [where x="Var sn'"], simp)
    apply (rule All_E [where x="Var sn2'"], simp)
    apply (rule All_E [where x="Var n2"], simp)
    apply (rule cut_same [where A = "Q_Eats (Var sm) (Var sn) EQ Q_Eats (Var sm2) (Var sn2)"])
    apply (blast intro: Sym Trans, clarify)
    apply (rule cut_same [where A = "SeqStTermP v a (Var sn) (Var sn2') s' (Var n2)"])
    apply (blast intro: Hyp SeqStTermP_cong [OF Hyp Refl Refl, THEN Iff_MP2_same])
    apply (rule cut_same [where A = "SeqStTermP v a (Var sm) (Var sm2') s' (Var m2)"])
    apply (blast intro: Hyp SeqStTermP_cong [OF Hyp Refl Refl, THEN Iff_MP2_same])
    apply (rule Disj_EH, blast intro: thin1 ContraProve)+
    apply (blast intro: HPair_cong Trans [OF Hyp Sym])
    done
  hence p1: "{OrdP (Var k), VarP v}
             \<turnstile> (All j (All j' (All k' (SeqStTermP v a (Var i) (Var j) s (Var k)
                 IMP (SeqStTermP v a (Var i) (Var j') s' (Var k') IMP Var j' EQ Var j)))))(i::=t)"
    by (metis All_D)
  have p2: "{OrdP (Var k), VarP v}
         \<turnstile> (All j' (All k' (SeqStTermP v a t (Var j) s (Var k)
                 IMP (SeqStTermP v a t (Var j') s' (Var k') IMP Var j' EQ Var j))))(j::=u)"
    apply (rule All_D)
    using atoms p1 by simp
  have p3: "{OrdP (Var k), VarP v}
             \<turnstile> (All k' (SeqStTermP v a t u s (Var k) IMP (SeqStTermP v a t (Var j') s' (Var k') IMP Var j' EQ u)))(j'::=u')"
    apply (rule All_D)
    using atoms p2 by simp
  have p4: "{OrdP (Var k), VarP v}
          \<turnstile> (SeqStTermP v a t u s (Var k) IMP (SeqStTermP v a t u' s' (Var k') IMP u' EQ u))(k'::=kk')"
    apply (rule All_D)
    using atoms p3 by simp
  hence "{SeqStTermP v a t u s (Var k), VarP v} \<turnstile> SeqStTermP v a t u s (Var k) IMP (SeqStTermP v a t u' s' kk' IMP u' EQ u)"
    using atoms apply simp
    by (metis SeqStTermP_imp_OrdP rcut1)
  hence "{VarP v} \<turnstile> ((SeqStTermP v a t u s (Var k) IMP (SeqStTermP v a t u' s' kk' IMP u' EQ u)))"
    by (metis Assume MP_same Imp_I)
  hence "{VarP v} \<turnstile> ((SeqStTermP v a t u s (Var k) IMP (SeqStTermP v a t u' s' kk' IMP u' EQ u)))(k::=kk)"
   using atoms by (force intro!: Subst)
  hence "{VarP v} \<turnstile> SeqStTermP v a t u s kk IMP (SeqStTermP v a t u' s' kk' IMP u' EQ u)"
    using atoms by simp
  hence "{SeqStTermP v a t u s kk} \<turnstile> SeqStTermP v a t u s kk IMP (SeqStTermP v a t u' s' kk' IMP u' EQ u)"
    by (metis SeqStTermP_imp_VarP rcut1)
  thus ?thesis
    by (metis Assume AssumeH(2) MP_same rcut1)
qed

theorem SubstTermP_unique: "{SubstTermP v tm t u, SubstTermP v tm t u'} \<turnstile> u' EQ u"
proof -
  obtain s::name and s'::name and k::name and k'::name
    where "atom s \<sharp> (v,tm,t,u,u',k,k')" "atom s' \<sharp> (v,tm,t,u,u',k,k',s)"
          "atom k \<sharp> (v,tm,t,u,u')" "atom k' \<sharp> (v,tm,t,u,u',k)"
    by (metis obtain_fresh)
  thus ?thesis
    by (auto simp: SubstTermP.simps [of s v tm t u k]  SubstTermP.simps [of s' v tm t u' k'])
       (metis SeqStTermP_unique rotate3 thin1)
qed

subsection{*@{term SubstAtomicP}*}

lemma SubstTermP_eq:
  "\<lbrakk>H \<turnstile> SubstTermP v tm x z; insert (SubstTermP v tm y z) H \<turnstile> A\<rbrakk> \<Longrightarrow> insert (x EQ y) H \<turnstile> A"
  by (metis Assume rotate2 Iff_E1 cut_same thin1 SubstTermP_cong [OF Refl Refl _ Refl])

lemma SubstAtomicP_unique: "{SubstAtomicP v tm x y, SubstAtomicP v tm x y'} \<turnstile> y' EQ y"
proof -
  obtain t::name and ts::name and u::name and us::name
     and t'::name and ts'::name and u'::name and us'::name
    where "atom t \<sharp> (v,tm,x,y,y',ts,u,us)"  "atom ts \<sharp> (v,tm,x,y,y',u,us)"
          "atom u \<sharp> (v,tm,x,y,y',us)"       "atom us \<sharp> (v,tm,x,y,y')"
          "atom t' \<sharp> (v,tm,x,y,y',t,ts,u,us,ts',u',us')" "atom ts' \<sharp> (v,tm,x,y,y',t,ts,u,us,u',us')"
          "atom u' \<sharp> (v,tm,x,y,y',t,ts,u,us,us')"        "atom us' \<sharp> (v,tm,x,y,y',t,ts,u,us)"
    by (metis obtain_fresh)
  thus ?thesis
    apply (simp add: SubstAtomicP.simps [of t v tm x y ts u us]
                     SubstAtomicP.simps [of t' v tm x y' ts' u' us'])
    apply (rule Ex_EH Disj_EH Conj_EH)+
    apply simp_all
    apply (rule Eq_Trans_E [OF Hyp], auto simp: HTS)
    apply (rule SubstTermP_eq [THEN thin1], blast)
    apply (rule SubstTermP_eq [THEN rotate2], blast)
    apply (rule Trans [OF Hyp Sym], blast)
    apply (rule Trans [OF Hyp], blast)
    apply (metis Assume AssumeH(8) HPair_cong Refl cut2 [OF SubstTermP_unique] thin1)
    apply (rule Eq_Trans_E [OF Hyp], blast, force simp add: HTS)
    apply (rule Eq_Trans_E [OF Hyp], blast, force simp add: HTS)
    apply (rule Eq_Trans_E [OF Hyp], auto simp: HTS)
    apply (rule SubstTermP_eq [THEN thin1], blast)
    apply (rule SubstTermP_eq [THEN rotate2], blast)
    apply (rule Trans [OF Hyp Sym], blast)
    apply (rule Trans [OF Hyp], blast)
    apply (metis Assume AssumeH(8) HPair_cong Refl cut2 [OF SubstTermP_unique] thin1)
    done
qed

subsection{*@{term SeqSubstFormP}*}

lemma SeqSubstFormP_lemma:
  assumes "atom m \<sharp> (v,u,x,y,s,k,n,sm,sm',sn,sn')" "atom n \<sharp> (v,u,x,y,s,k,sm,sm',sn,sn')"
          "atom sm \<sharp> (v,u,x,y,s,k,sm',sn,sn')"  "atom sm' \<sharp> (v,u,x,y,s,k,sn,sn')"
          "atom sn \<sharp> (v,u,x,y,s,k,sn')"         "atom sn' \<sharp> (v,u,x,y,s,k)"
  shows "{ SeqSubstFormP v u x y s k }
         \<turnstile> SubstAtomicP v u x y  OR
           Ex m (Ex n (Ex sm (Ex sm' (Ex sn (Ex sn' (Var m IN k AND Var n IN k AND
                       SeqSubstFormP v u (Var sm) (Var sm') s (Var m) AND
                       SeqSubstFormP v u (Var sn) (Var sn') s (Var n) AND
                       (((x EQ Q_Disj (Var sm) (Var sn) AND y EQ Q_Disj (Var sm') (Var sn')) OR
                        (x EQ Q_Neg (Var sm) AND y EQ Q_Neg (Var sm')) OR
                        (x EQ Q_Ex (Var sm) AND y EQ Q_Ex (Var sm'))))))))))"
proof -
  obtain l::name and sl::name and sl'::name
    where "atom l \<sharp> (v,u,x,y,s,k,sl,sl',m,n,sm,sm',sn,sn')"
          "atom sl \<sharp> (v,u,x,y,s,k,sl',m,n,sm,sm',sn,sn')"
          "atom sl' \<sharp> (v,u,x,y,s,k,m,n,sm,sm',sn,sn')"
    by (metis obtain_fresh)
  thus ?thesis using assms
    apply (simp add: SeqSubstFormP.simps [of l s k v u sl sl' m n sm sm' sn sn'])
    apply (rule Conj_EH Ex_EH All2_SUCC_E [THEN rotate2] | simp)+
    apply (rule cut_same [where A = "HPair x y EQ HPair (Var sl) (Var sl')"])
    apply (metis Assume AssumeH(4) LstSeqP_EQ)
    apply clarify
    apply (rule Disj_EH)
    apply (blast intro: Disj_I1 SubstAtomicP_cong [THEN Iff_MP2_same])
    --{*now the quantified cases*}
    apply (rule Ex_EH Conj_EH)+
    apply simp_all
    apply (rule Disj_I2)
    apply (rule Ex_I [where x = "Var m"], simp)
    apply (rule Ex_I [where x = "Var n"], simp)
    apply (rule Ex_I [where x = "Var sm"], simp)
    apply (rule Ex_I [where x = "Var sm'"], simp)
    apply (rule Ex_I [where x = "Var sn"], simp)
    apply (rule Ex_I [where x = "Var sn'"], simp)
    apply (simp_all add: SeqSubstFormP.simps [of l s _ v u sl sl' m n sm sm' sn sn'])
    apply ((rule Conj_I)+, blast intro: LstSeqP_Mem)+
    --{*first SeqSubstFormP subgoal*}
    apply (rule All2_Subset [OF Hyp], blast)
    apply (blast intro!: SUCC_Subset_Ord LstSeqP_OrdP, blast, simp)
    --{*next SeqSubstFormP subgoal*}
    apply ((rule Conj_I)+, blast intro: LstSeqP_Mem)+
    apply (rule All2_Subset [OF Hyp], blast)
    apply (blast intro!: SUCC_Subset_Ord LstSeqP_OrdP, blast, simp)
    --{*finally, the equality pairs*}
    apply (rule anti_deduction [THEN thin1])
    apply (rule Sym_L [THEN rotate4])
    apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same])
    apply (rule Sym_L [THEN rotate5])
    apply (rule Var_Eq_subst_Iff [THEN Iff_MP_same], force)
    done
qed

lemma
  shows Neg_SubstAtomicP_Fls:  "{y EQ Q_Neg z,  SubstAtomicP v tm y y'} \<turnstile> Fls"    (is ?thesis1)
    and Disj_SubstAtomicP_Fls: "{y EQ Q_Disj z w, SubstAtomicP v tm y y'} \<turnstile> Fls"  (is ?thesis2)
    and Ex_SubstAtomicP_Fls:   "{y EQ Q_Ex z,   SubstAtomicP v tm y y'} \<turnstile> Fls"    (is ?thesis3)
proof -
  obtain t::name and u::name and t'::name  and u'::name
    where "atom t \<sharp> (z,w,v,tm,y,y',t',u,u')" "atom t' \<sharp> (z,w,v,tm,y,y',u,u')"
          "atom u \<sharp> (z,w,v,tm,y,y',u')" "atom u' \<sharp> (z,w,v,tm,y,y')"
    by (metis obtain_fresh)
  thus ?thesis1 ?thesis2 ?thesis3
    by (auto simp: SubstAtomicP.simps [of t v tm y y' t' u u'] HTS  intro: Eq_Trans_E [OF Hyp])
qed

lemma SeqSubstFormP_eq:
  "\<lbrakk>H \<turnstile> SeqSubstFormP v tm x z s k; insert (SeqSubstFormP v tm y z s k) H \<turnstile> A\<rbrakk>
   \<Longrightarrow> insert (x EQ y) H \<turnstile> A"
  apply (rule cut_same [OF SeqSubstFormP_cong [OF Assume Refl Refl Refl, THEN Iff_MP_same]])
  apply (auto simp: insert_commute intro: thin1)
  done

lemma SeqSubstFormP_unique: "{SeqSubstFormP v a x y s kk, SeqSubstFormP v a x y' s' kk'} \<turnstile> y' EQ y"
proof -
  obtain i::name and j::name and j'::name and k::name and k'::name and l::name
     and m::name and n::name and sm::name and sn::name and sm'::name and sn'::name
     and m2::name and n2::name and sm2::name and sn2::name and sm2'::name and sn2'::name
    where atoms:  "atom i \<sharp> (s,s',v,a,x,y,y')"   "atom j \<sharp> (s,s',v,a,x,i,x,y,y')"
                  "atom j' \<sharp> (s,s',v,a,x,i,j,x,y,y')"
                  "atom k \<sharp> (s,s',v,a,x,y,y',kk',i,j,j')" "atom k' \<sharp> (s,s',v,a,x,y,y',k,i,j,j')"
                  "atom l \<sharp> (s,s',v,a,x,i,j,j',k,k')"
                  "atom m \<sharp> (s,s',v,a,i,j,j',k,k',l)"   "atom n \<sharp> (s,s',v,a,i,j,j',k,k',l,m)"
                  "atom sm \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n)"  "atom sn \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm)"
                  "atom sm' \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn)"   "atom sn' \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm')"
                  "atom m2 \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn')"   "atom n2 \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2)"
                  "atom sm2 \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2)"  "atom sn2 \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2)"
                  "atom sm2' \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2,sn2)"   "atom sn2' \<sharp> (s,s',v,a,i,j,j',k,k',l,m,n,sm,sn,sm',sn',m2,n2,sm2,sn2,sm2')"
    by (metis obtain_fresh)
  have "{ OrdP (Var k) }
       \<turnstile> All i (All j (All j' (All k' (SeqSubstFormP v a (Var i) (Var j) s (Var k)
                                  IMP (SeqSubstFormP v a (Var i) (Var j') s' (Var k') IMP Var j' EQ Var j)))))"
    apply (rule OrdIndH [where j=l])
    using atoms apply auto
    apply (rule Swap)
    apply (rule cut_same)
    apply (rule cut1 [OF SeqSubstFormP_lemma [of m v a "Var i" "Var j" s "Var k" n sm sm' sn sn']], simp_all, blast)
    apply (rule cut_same)
    apply (rule cut1 [OF SeqSubstFormP_lemma [of m2 v a "Var i" "Var j'" s' "Var k'" n2 sm2 sm2' sn2 sn2']], simp_all, blast)
    apply (rule Disj_EH Conj_EH)+
    --{*case 1, both sides are atomic*}
    apply (blast intro: cut2 [OF SubstAtomicP_unique])
    --{*case 2, atomic and also not*}
    apply (rule Ex_EH Conj_EH Disj_EH)+
    apply simp_all
    apply (metis Assume AssumeH(7) Disj_I1 Neg_I anti_deduction cut2 [OF Disj_SubstAtomicP_Fls])
    apply (rule Conj_EH Disj_EH)+
    apply (metis Assume AssumeH(7) Disj_I1 Neg_I anti_deduction cut2 [OF Neg_SubstAtomicP_Fls])
    apply (rule Conj_EH)+
    apply (metis Assume AssumeH(7) Disj_I1 Neg_I anti_deduction cut2 [OF Ex_SubstAtomicP_Fls])
    --{*towards remaining cases*}
    apply (rule Conj_EH Disj_EH Ex_EH)+
    apply simp_all
    apply (metis Assume AssumeH(7) Disj_I1 Neg_I anti_deduction cut2 [OF Disj_SubstAtomicP_Fls])
    apply (rule Conj_EH Disj_EH)+
    apply (metis Assume AssumeH(7) Disj_I1 Neg_I anti_deduction cut2 [OF Neg_SubstAtomicP_Fls])
    apply (rule Conj_EH)+
    apply (metis Assume AssumeH(7) Disj_I1 Neg_I anti_deduction cut2 [OF Ex_SubstAtomicP_Fls])
    --{*towards remaining cases*}
    apply (rule Conj_EH Disj_EH Ex_EH)+
    apply simp_all
    --{*case two Disj terms*}
    apply (rule All_E' [OF Hyp, where x="Var m"], blast)
    apply (rule All_E' [OF Hyp, where x="Var n"], blast, simp)
    apply (rule Disj_EH, blast intro: thin1 ContraProve)+
    apply (rule All_E [where x="Var sm"], simp)
    apply (rule All_E [where x="Var sm'"], simp)
    apply (rule All_E [where x="Var sm2'"], simp)
    apply (rule All_E [where x="Var m2"], simp)
    apply (rule All_E [where x="Var sn", THEN rotate2], simp)
    apply (rule All_E [where x="Var sn'"], simp)
    apply (rule All_E [where x="Var sn2'"], simp)
    apply (rule All_E [where x="Var n2"], simp)
    apply (rule rotate3)
    apply (rule Eq_Trans_E [OF Hyp], blast)
    apply (clarsimp simp add: HTS)
    apply (rule thin1)
    apply (rule Disj_EH [OF ContraProve], blast intro: thin1 SeqSubstFormP_eq)+
    apply (blast intro: HPair_cong Trans [OF Hyp Sym])
    --{*towards remaining cases*}
    apply (rule Conj_EH Disj_EH)+
    --{*Negation = Disjunction?*}
    apply (rule Eq_Trans_E [OF Hyp], blast, force simp add: HTS)
   --{*Existential = Disjunction?*}
    apply (rule Conj_EH)
    apply (rule Eq_Trans_E [OF Hyp], blast, force simp add: HTS)
     --{*towards remaining cases*}
    apply (rule Conj_EH Disj_EH Ex_EH)+
    apply simp_all
    --{*Disjunction = Negation?*}
    apply (rule Eq_Trans_E [OF Hyp], blast, force simp add: HTS)
    apply (rule Conj_EH Disj_EH)+
    --{*case two Neg terms*}
    apply (rule Eq_Trans_E [OF Hyp], blast, clarify)
    apply (rule thin1)
    apply (rule All_E' [OF Hyp, where x="Var m"], blast, simp)
    apply (rule Disj_EH, blast intro: thin1 ContraProve)+
    apply (rule All_E [where x="Var sm"], simp)
    apply (rule All_E [where x="Var sm'"], simp)
    apply (rule All_E [where x="Var sm2'"], simp)
    apply (rule All_E [where x="Var m2"], simp)
    apply (rule Disj_EH [OF ContraProve], blast intro: SeqSubstFormP_eq Sym_L)+
    apply (blast intro: HPair_cong Sym Trans [OF Hyp])
    --{*Existential = Negation?*}
    apply (rule Conj_EH)+
    apply (rule Eq_Trans_E [OF Hyp], blast, force simp add: HTS)
     --{*towards remaining cases*}
    apply (rule Conj_EH Disj_EH Ex_EH)+
    apply simp_all
    --{*Disjunction = Existential*}
    apply (rule Eq_Trans_E [OF Hyp], blast, force simp add: HTS)
    apply (rule Conj_EH Disj_EH Ex_EH)+
    --{*Negation = Existential*}
    apply (rule Eq_Trans_E [OF Hyp], blast, force simp add: HTS)
   --{*case two Ex terms*}
    apply (rule Conj_EH)+
    apply (rule Eq_Trans_E [OF Hyp], blast, clarify)
    apply (rule thin1)
    apply (rule All_E' [OF Hyp, where x="Var m"], blast, simp)
    apply (rule Disj_EH, blast intro: thin1 ContraProve)+
    apply (rule All_E [where x="Var sm"], simp)
    apply (rule All_E [where x="Var sm'"], simp)
    apply (rule All_E [where x="Var sm2'"], simp)
    apply (rule All_E [where x="Var m2"], simp)
    apply (rule Disj_EH [OF ContraProve], blast intro: SeqSubstFormP_eq Sym_L)+
    apply (blast intro: HPair_cong Sym Trans [OF Hyp])
    done
  hence p1: "{OrdP (Var k)}
             \<turnstile> (All j (All j' (All k' (SeqSubstFormP v a (Var i) (Var j) s (Var k)
                 IMP (SeqSubstFormP v a (Var i) (Var j') s' (Var k') IMP Var j' EQ Var j)))))(i::=x)"
    by (metis All_D)
  have p2: "{OrdP (Var k)}
            \<turnstile> (All j' (All k' (SeqSubstFormP v a x (Var j) s (Var k)
                 IMP (SeqSubstFormP v a x (Var j') s' (Var k') IMP Var j' EQ Var j))))(j::=y)"
    apply (rule All_D)
    using atoms p1 by simp
  have p3: "{OrdP (Var k)}
            \<turnstile> (All k' (SeqSubstFormP v a x y s (Var k)
                 IMP (SeqSubstFormP v a x (Var j') s' (Var k') IMP Var j' EQ y)))(j'::=y')"
    apply (rule All_D)
    using atoms p2 by simp
  have p4: "{OrdP (Var k)}
          \<turnstile> (SeqSubstFormP v a x y s (Var k) IMP (SeqSubstFormP v a x y' s' (Var k') IMP y' EQ y))(k'::=kk')"
    apply (rule All_D)
    using atoms p3 by simp
  hence "{OrdP (Var k)} \<turnstile> SeqSubstFormP v a x y s (Var k) IMP (SeqSubstFormP v a x y' s' kk' IMP y' EQ y)"
    using atoms by simp
  hence "{SeqSubstFormP v a x y s (Var k)}
         \<turnstile> SeqSubstFormP v a x y s (Var k) IMP (SeqSubstFormP v a x y' s' kk' IMP y' EQ y)"
    by (metis SeqSubstFormP_imp_OrdP rcut1)
  hence "{} \<turnstile> SeqSubstFormP v a x y s (Var k) IMP (SeqSubstFormP v a x y' s' kk' IMP y' EQ y)"
    by (metis Assume Disj_Neg_2 Disj_commute anti_deduction Imp_I)
  hence "{} \<turnstile> ((SeqSubstFormP v a x y s (Var k) IMP (SeqSubstFormP v a x y' s' kk' IMP y' EQ y)))(k::=kk)"
    using atoms by (force intro!: Subst)
  thus ?thesis
    using atoms by simp (metis DisjAssoc2 Disj_commute anti_deduction)
qed

subsection{*@{term SubstFormP}*}

theorem SubstFormP_unique: "{SubstFormP v tm x y, SubstFormP v tm x y'} \<turnstile> y' EQ y"
proof -
  obtain s::name and s'::name and k::name and k'::name
    where "atom s \<sharp> (v,tm,x,y,y',k,k')" "atom s' \<sharp> (v,tm,x,y,y',k,k',s)"
          "atom k \<sharp> (v,tm,x,y,y')" "atom k' \<sharp> (v,tm,x,y,y',k)"
    by (metis obtain_fresh)
  thus ?thesis
    by (force simp: SubstFormP.simps [of s v tm x y k]  SubstFormP.simps [of s' v tm x y' k']
                    SeqSubstFormP_unique rotate3 thin1)
qed

end