(*  Title:      HOL/Hoare/SepLogHeap.thy
    Author:     Tobias Nipkow
    Copyright   2002 TUM
*)

section \<open>Heap abstractions for Separation Logic\<close>

text \<open>(at the moment only Path and List)\<close>

theory SepLogHeap
  imports Main
begin

type_synonym heap = "(nat \<Rightarrow> nat option)"

text\<open>\<open>Some\<close> means allocated, \<open>None\<close> means
free. Address \<open>0\<close> serves as the null reference.\<close>

subsection "Paths in the heap"

primrec Path :: "heap \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> bool"
where
  "Path h x [] y = (x = y)"
| "Path h x (a#as) y = (x\<noteq>0 \<and> a=x \<and> (\<exists>b. h x = Some b \<and> Path h b as y))"

lemma [simp]: "\<And>x. Path f x (as@bs) z = (\<exists>y. Path f x as y \<and> Path f y bs z)"
by (induct as) auto

lemma Path_upd[simp]:
 "\<And>x. u \<notin> set as \<Longrightarrow> Path (f(u := v)) x as y = Path f x as y"
by (induct as) simp_all

subsection "Lists on the heap"

definition List :: "heap \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> bool"
  where "List h x as = Path h x as 0"

lemma [simp]: "List h x [] = (x = 0)"
by (simp add: List_def)

lemma [simp]:
 "List h x (a#as) = (x\<noteq>0 \<and> a=x \<and> (\<exists>y. h x = Some y \<and> List h y as))"
by (simp add: List_def)

lemma [simp]: "List h 0 as = (as = [])"
by (cases as) simp_all

lemma List_non_null: "a\<noteq>0 \<Longrightarrow>
 List h a as = (\<exists>b bs. as = a#bs \<and> h a = Some b \<and> List h b bs)"
by (cases as) simp_all

lemma List_unique: "\<And>x bs. List h x as \<Longrightarrow> List h x bs \<Longrightarrow> as = bs"
by (induct as) (auto simp add:List_non_null)

lemma List_unique1: "List h p as \<Longrightarrow> \<exists>!as. List h p as"
by (blast intro: List_unique)

lemma List_app: "\<And>x. List h x (as@bs) = (\<exists>y. Path h x as y \<and> List h y bs)"
by (induct as) auto

lemma List_hd_not_in_tl[simp]: "List h b as \<Longrightarrow> h a = Some b \<Longrightarrow> a \<notin> set as"
apply (clarsimp simp add:in_set_conv_decomp)
apply(frule List_app[THEN iffD1])
apply(fastforce dest: List_unique)
done

lemma List_distinct[simp]: "\<And>x. List h x as \<Longrightarrow> distinct as"
by (induct as) (auto dest:List_hd_not_in_tl)

lemma list_in_heap: "\<And>p. List h p ps \<Longrightarrow> set ps \<subseteq> dom h"
by (induct ps) auto

lemma list_ortho_sum1[simp]:
 "\<And>p. \<lbrakk> List h1 p ps; dom h1 \<inter> dom h2 = {}\<rbrakk> \<Longrightarrow> List (h1++h2) p ps"
by (induct ps) (auto simp add:map_add_def split:option.split)

lemma list_ortho_sum2[simp]:
 "\<And>p. \<lbrakk> List h2 p ps; dom h1 \<inter> dom h2 = {}\<rbrakk> \<Longrightarrow> List (h1++h2) p ps"
by (induct ps) (auto simp add:map_add_def split:option.split)

end


theory Lists1_3
imports Main
begin

primrec alls :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "alls P [] = True" |
  "alls P (x # xs) = (if (P x) then (alls P xs) else False)"

primrec exs :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "exs P [] = False" |
  "exs P (x # xs) = (if (P x) then True else (exs P xs))"

lemma "alls (\<lambda>x. P x \<and> Q x) xs = (alls P xs \<and> alls Q xs)"
  apply (induct xs)
  apply auto
done

lemma alls_append: "alls P (xs @ ys) = ((alls P xs) \<and> (alls P ys))"
  apply (induct xs)
  apply simp+
done

lemma "alls P (rev xs) = alls P xs"
  apply (induct xs)
  apply simp
  apply (simp add:alls_append)
done

lemma "exs (\<lambda>x. Px \<and> Qx) xs = (exs P xs \<and> exs Q xs)"
  quickcheck
oops

lemma "exs P (map f xs) = exs (P o f) xs"
  apply (induct xs)
  apply auto
done

lemma exs_append: "exs P (xs @ ys) = ((exs P xs) \<or> (exs P ys))"
  apply (induct xs)
  apply simp+
done

lemma "exs P (rev xs) = exs P xs"
  apply (induct xs)
  apply simp
  apply (simp add:exs_append)
done

lemma "exs (\<lambda>x. P x \<or> Q x) xs = ((exs P xs) \<or> (exs Q xs))"
  apply (induct xs)
  apply auto
done

lemma "exs P xs = (\<not> alls (\<lambda>x. \<not>(P x)) xs)"
  apply (induct xs)
  apply auto
done

primrec is_in :: "'a \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "is_in x [] = False" |
  "is_in x (y # ys) = (if x = y then True else (is_in x ys))"

value "is_in 1 [1,2,3]"
value "is_in 1"

theorem "is_in a xs = exs (\<lambda>x. is_in a [x]) xs"
  apply (induct xs)
  apply simp+
done

primrec nodups :: "'a list \<Rightarrow> bool"
where
  "nodups [] = True" |
  "nodups (x # xs) = (if (is_in x xs) then False else (nodups xs))"

value "nodups [1,1]"

primrec deldups :: "'a list \<Rightarrow> 'a list"
where
  "deldups [] = []"
| "deldups (x # xs) = (if (is_in x xs) then (deldups xs) else (x # (deldups xs)))"

value "deldups [1,1]"

lemma "length (deldups xs) \<le> length xs"
  apply (induct xs)
  apply simp+
done

lemma is_in_deldups: "is_in a (deldups xs) \<longrightarrow> is_in a xs"
  apply (induct xs)
  apply simp
  apply simp
done

lemma "nodups (deldups xs)"
  apply (induct xs)
  apply simp
  apply (simp add:is_in_deldups)
done

lemma "deldups (rev xs) = rev (deldups xs)"
  quickcheck
oops

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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_nat_pow_times
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun times :: "Nat => Nat => Nat" where
"times (Z) y = Z"
| "times (S z) y = plus y (times z y)"

fun formulapow3 :: "Nat => Nat => Nat" where
"formulapow3 x (Z) = S Z"
| "formulapow3 x (S z) = times x (formulapow3 x z)"

fun formulapow2 :: "Nat => Nat => Nat" where
"formulapow2 x (Z) = S Z"
| "formulapow2 x (S z) = times x (formulapow2 x z)"

fun formulapow :: "Nat => Nat => Nat" where
"formulapow x (Z) = S Z"
| "formulapow x (S z) = times x (formulapow x z)"

theorem property0 :
  "((formulapow x (plus y z)) =
      (times (formulapow2 x y) (formulapow3 x z)))"
  oops

end


theory IO_Sequence_Set
imports FSM
begin

section \<open>Properties of Sets of IO Sequences\<close>

fun output_completion :: "(Input \<times> Output) list set \<Rightarrow> Output set \<Rightarrow> (Input \<times> Output) list set" where
  "output_completion P Out = P \<union> {io@[(fst xy, y)] | io xy y . y \<in> Out \<and> io@[xy] \<in> P \<and> io@[(fst xy, y)] \<notin> P}"

fun output_complete_sequences :: "'a FSM \<Rightarrow> (Input \<times> Output) list set \<Rightarrow> bool" where
  "output_complete_sequences M P = (\<forall> io \<in> P . io = [] \<or> (\<forall> y \<in> set (outputs M) . (butlast io)@[(fst (last io), y)] \<in> P))"

value "output_complete_sequences M_ex {}"
value "output_complete_sequences M_ex {[]}"
value "output_complete_sequences M_ex {[],[(1,10)]}"
value "output_complete_sequences M_ex {[],[(1,10)],[(1,20)]}"
value "output_complete_sequences M_ex {[],[(1,10)],[(1,20)],[(1,30)]}"
value "output_complete_sequences M_ex {[],[(1,10),(1,10)],[(1,20)],[(1,30)]}"
value "output_complete_sequences M_ex {[],[(1,10),(1,10)],[(1,10),(1,20)],[(1,10),(1,30)]}"

fun acyclic_sequences :: "'a FSM \<Rightarrow> 'a \<Rightarrow> (Input \<times> Output) list set \<Rightarrow> bool" where
  "acyclic_sequences M q P = (\<forall> p . (path M q p \<and> p_io p \<in> P) \<longrightarrow> distinct (visited_states q p))"

fun acyclic_sequences' :: "'a FSM \<Rightarrow> 'a \<Rightarrow> (Input \<times> Output) list set \<Rightarrow> bool" where
  "acyclic_sequences' M q P = (\<forall> io \<in> P . \<forall> p \<in> set (paths_of_length M q (length io)) . (p_io p = io) \<longrightarrow> distinct (visited_states q p))"

lemma acyclic_sequences_alt_def[code] : "acyclic_sequences M P = acyclic_sequences' M P"
  unfolding acyclic_sequences'.simps acyclic_sequences.simps
  by (metis (no_types, lifting) length_map paths_of_length_containment paths_of_length_is_path(1))

value "acyclic_sequences M_ex (initial M_ex) {}"
value "acyclic_sequences M_ex (initial M_ex) {[]}"
value "acyclic_sequences M_ex (initial M_ex) {[(1,30)]}"
value "acyclic_sequences M_ex (initial M_ex) {[(1,30),(2,20)]}"

fun single_input_sequences :: "'a FSM \<Rightarrow> (Input \<times> Output) list set \<Rightarrow> bool" where
  "single_input_sequences M P = (\<forall> xys1 xys2 xy1 xy2 . (xys1@[xy1] \<in> P \<and> xys2@[xy2] \<in> P \<and> io_target M xys1 (initial M) = io_target M xys2 (initial M)) \<longrightarrow> fst xy1 = fst xy2)"

fun single_input_sequences' :: "'a FSM \<Rightarrow> (Input \<times> Output) list set \<Rightarrow> bool" where
  "single_input_sequences' M P = (\<forall> io1 \<in> P . \<forall> io2 \<in> P . io1 = [] \<or> io2 = [] \<or> ((io_target M (butlast io1) (initial M) = io_target M (butlast io2) (initial M)) \<longrightarrow> fst (last io1) = fst (last io2)))"

lemma single_input_sequences_alt_def[code] : "single_input_sequences M P = single_input_sequences' M P"
  unfolding single_input_sequences.simps single_input_sequences'.simps
  by (metis append_butlast_last_id append_is_Nil_conv butlast_snoc last_snoc not_Cons_self)

value "single_input_sequences M_ex {}"
value "single_input_sequences M_ex {[]}"
value "single_input_sequences M_ex {[(1,30)]}"
value "single_input_sequences M_ex {[(1,30)],[(2,30)]}"
value "single_input_sequences M_ex {[(1,30)],[(1,20)]}"
value "single_input_sequences M_ex {[(1,30)],[(1,30),(1,30)]}"
value "single_input_sequences M_ex {[(1,30)],[(1,30),(2,30)]}"
value "single_input_sequences M_ex {[(1,30)],[(1,30),(1,30)],[(1,30),(2,30)]}"

fun output_complete_for_FSM_sequences_from_state :: "'a FSM \<Rightarrow> 'a \<Rightarrow> (Input \<times> Output) list set \<Rightarrow> bool" where
  "output_complete_for_FSM_sequences_from_state M q P = (\<forall> io xy t . io@[xy] \<in> P \<and> t \<in> h M \<and> t_source t = io_target M io q \<and> t_input t = fst xy \<longrightarrow> io@[(fst xy, t_output t)] \<in> P)"

lemma output_complete_for_FSM_sequences_from_state_alt_def :
  shows "output_complete_for_FSM_sequences_from_state M q P = (\<forall> xys xy y . (xys@[xy] \<in> P \<and> [(fst xy,y)] \<in> LS M (io_target M xys q)) \<longrightarrow> xys@[(fst xy,y)] \<in> P)"
proof -
  have "\<And> xys (xy :: (Input \<times> Output)) y .[(fst xy,y)] \<in> LS M (io_target M xys q) \<Longrightarrow> \<exists> t . t \<in> h M \<and> t_source t = io_target M xys q \<and> t_input t = fst xy \<and> t_output t = y"
  proof -
    fix xys y
    fix xy :: "(Input \<times> Output)"
    assume "[(fst xy,y)] \<in> LS M (io_target M xys q)"
    then obtain p where "path M (io_target M xys q) p" and "p_io p = [(fst xy,y)]"
      unfolding LS.simps mem_Collect_eq by (metis (no_types, lifting))
    let ?t = "hd p"
    have "?t \<in> h M \<and> t_source ?t = io_target M xys q \<and> t_input ?t = fst xy \<and> t_output ?t = y"
      using \<open>p_io p = [(fst xy, y)]\<close> \<open>path M (io_target M xys q) p\<close> by auto

    then show "\<exists> t . t \<in> h M \<and> t_source t = io_target M xys q \<and> t_input t = fst xy \<and> t_output t = y"
      by blast
  qed
  have "\<And> xys (xy :: (Input \<times> Output)) y . \<exists> t . t \<in> h M \<and> t_source t = io_target M xys q \<and> t_input t = fst xy \<and> t_output t = y \<Longrightarrow> [(fst xy,y)] \<in> LS M (io_target M xys q)"
  proof -
    fix xys y
    fix xy :: "(Input \<times> Output)"
    assume "\<exists> t . t \<in> h M \<and> t_source t = io_target M xys q \<and> t_input t = fst xy \<and> t_output t = y"
    then obtain t where "t \<in> h M \<and> t_source t = io_target M xys q \<and> t_input t = fst xy \<and> t_output t = y"
      by blast
    then have "path M (io_target M xys q) [t] \<and> p_io [t] = [(fst xy, y)]"
      by (metis (no_types, lifting) list.simps(8) list.simps(9) single_transition_path)

    then show "[(fst xy,y)] \<in> LS M (io_target M xys q)"
      unfolding LS.simps by (metis (mono_tags, lifting) mem_Collect_eq)
  qed

  show ?thesis
  proof -
    have *: "\<forall>f q P. output_complete_for_FSM_sequences_from_state f q P = (\<forall>ps p pa. (ps @ [p] \<notin> P \<or> pa \<notin> h f \<or> (t_source pa::'a) \<noteq> io_target f ps q \<or> t_input pa \<noteq> fst p) \<or> ps @ [(fst p, t_output pa)] \<in> P)"
      by (meson output_complete_for_FSM_sequences_from_state.simps)
  then have "(\<not> output_complete_for_FSM_sequences_from_state M q P) \<noteq> (\<forall>ps p n. (ps @ [p] \<notin> P \<or> [(fst p, n)] \<notin> LS M (io_target M ps q)) \<or> ps @ [(fst p, n)] \<in> P)"
  by (metis (full_types) \<open>\<And>y xys xy. [(fst xy, y)] \<in> LS M (io_target M xys q) \<Longrightarrow> \<exists>t. t \<in> h M \<and> t_source t = io_target M xys q \<and> t_input t = fst xy \<and> t_output t = y\<close> \<open>\<And>y xys xy. \<exists>t. t \<in> h M \<and> t_source t = io_target M xys q \<and> t_input t = fst xy \<and> t_output t = y \<Longrightarrow> [(fst xy, y)] \<in> LS M (io_target M xys q)\<close>)
    then show ?thesis
      by blast
  qed
qed

fun output_complete_for_FSM_sequences_from_state' :: "'a FSM \<Rightarrow> 'a \<Rightarrow> (Input \<times> Output) list set \<Rightarrow> bool" where
  "output_complete_for_FSM_sequences_from_state' M q P = (\<forall> io\<in>P . \<forall> t \<in> h M . io = [] \<or> (t_source t = io_target M (butlast io) q \<and> t_input t = fst (last io) \<longrightarrow> (butlast io)@[(fst (last io), t_output t)] \<in> P))"

lemma output_complete_for_FSM_sequences_alt_def'[code] : "output_complete_for_FSM_sequences_from_state M q P = output_complete_for_FSM_sequences_from_state' M q P"
  unfolding output_complete_for_FSM_sequences_from_state.simps output_complete_for_FSM_sequences_from_state'.simps
  by (metis last_snoc snoc_eq_iff_butlast)

value "output_complete_for_FSM_sequences_from_state M_ex (initial M_ex) {}"
value "output_complete_for_FSM_sequences_from_state M_ex (initial M_ex) {[]}"
value "output_complete_for_FSM_sequences_from_state M_ex (initial M_ex) {[(1,20)]}"
value "output_complete_for_FSM_sequences_from_state M_ex (initial M_ex) {[(1,10)],[(1,20)]}"
value "output_complete_for_FSM_sequences_from_state M_ex (initial M_ex) {[(1,20)],[(1,30)]}"

fun deadlock_states_sequences :: "'a FSM \<Rightarrow> 'a set \<Rightarrow> (Input \<times> Output) list set \<Rightarrow> bool" where
  "deadlock_states_sequences M Q P = (\<forall> xys \<in> P .
                                        ((io_target M xys (initial M) \<in> Q
                                          \<and> \<not> (\<exists> xys' \<in> P . length xys < length xys' \<and> take (length xys) xys' = xys)))
                                      \<or> (\<not> io_target M xys (initial M) \<in> Q
                                          \<and> (\<exists> xys' \<in> P . length xys < length xys' \<and> take (length xys) xys' = xys)))"

value "deadlock_states_sequences M_ex {} {}"
value "deadlock_states_sequences M_ex {} {[]}"
value "deadlock_states_sequences M_ex {2} {[]}"
value "deadlock_states_sequences M_ex {3} {[]}"
value "deadlock_states_sequences M_ex {3} {[(1,20)]}"
value "deadlock_states_sequences M_ex {2,3} {[(1,20)]}"
value "deadlock_states_sequences M_ex {2,3} {[(1,30)]}"
value "deadlock_states_sequences M_ex {2,4} {[],[(1,30)]}"
value "deadlock_states_sequences M_ex {2,4} {[(1,20)],[(1,30)]}"
value "deadlock_states_sequences M_ex {3,4} {[(1,20)],[(1,30)]}"

fun reachable_states_sequences :: "'a FSM \<Rightarrow> 'a set \<Rightarrow> (Input \<times> Output) list set \<Rightarrow> bool" where
  "reachable_states_sequences M Q P = (\<forall> q \<in> Q . \<exists> xys \<in> P . io_target M xys (initial M) = q)"

value "reachable_states_sequences M_ex {} {}"
value "reachable_states_sequences M_ex {} {[]}"
value "reachable_states_sequences M_ex {2} {}"
value "reachable_states_sequences M_ex {2} {[]}"
value "reachable_states_sequences M_ex {3,4} {[(1,20)],[(1,30),(2,20)]}"
value "reachable_states_sequences M_ex {3,4} {[(1,20)],[(1,30)]}"
value "reachable_states_sequences M_ex {3,4,5} {[(1,20)],[(1,30)]}"

fun prefix_closed_sequences :: "(Input \<times> Output) list set \<Rightarrow> bool" where
  "prefix_closed_sequences P = (\<forall> xys1 xys2 . xys1@xys2 \<in> P \<longrightarrow> xys1 \<in> P)"

fun prefix_closed_sequences' :: "(Input \<times> Output) list set \<Rightarrow> bool" where
  "prefix_closed_sequences' P = (\<forall> io \<in> P . io = [] \<or> (butlast io) \<in> P)"

lemma prefix_closed_sequences_alt_def[code] : "prefix_closed_sequences P = prefix_closed_sequences' P"
proof
  show "prefix_closed_sequences P \<Longrightarrow> prefix_closed_sequences' P"
    unfolding prefix_closed_sequences.simps prefix_closed_sequences'.simps
    by (metis append_butlast_last_id)

  have "\<And>xys1 xys2. \<forall>io\<in>P. io = [] \<or> butlast io \<in> P \<Longrightarrow> xys1 @ xys2 \<in> P \<Longrightarrow> xys1 \<in> P"
  proof -
    fix xys1 xys2 assume "\<forall>io\<in>P. io = [] \<or> butlast io \<in> P" and "xys1 @ xys2 \<in> P"
    then show "xys1 \<in> P"
    proof (induction xys2 rule: rev_induct)
      case Nil
      then show ?case by auto
    next
      case (snoc a xys2)
      then show ?case
        by (metis append.assoc snoc_eq_iff_butlast)
    qed
  qed

  then show "prefix_closed_sequences' P \<Longrightarrow> prefix_closed_sequences P"
    unfolding prefix_closed_sequences.simps prefix_closed_sequences'.simps by blast
qed

value "prefix_closed_sequences {}"
value "prefix_closed_sequences {[]}"
value "prefix_closed_sequences {[(1,20)]}"
value "prefix_closed_sequences {[],[(1,20)]}"

subsection \<open>Completions\<close>

definition prefix_completion :: "'a list set \<Rightarrow> 'a list set" where
  "prefix_completion P = {xs . \<exists> ys . xs@ys \<in> P}"

lemma prefix_completion_closed :
  "prefix_closed_sequences (prefix_completion P)"
  unfolding prefix_closed_sequences.simps prefix_completion_def
  by auto

lemma prefix_completion_source_subset :
  "P \<subseteq> prefix_completion P"
  unfolding prefix_completion_def
  by (metis (no_types, lifting) append_Nil2 mem_Collect_eq subsetI)

definition output_completion_for_FSM :: "('a,'b) FSM_scheme \<Rightarrow> (Input \<times> Output) list set \<Rightarrow> (Input \<times> Output) list set" where
  "output_completion_for_FSM M P = P \<union> { io@[(x,y')] | io x y' . (y' \<in> set (outputs M)) \<and> (\<exists> y . io@[(x,y)] \<in> P)}"

lemma output_completion_for_FSM_complete :
  shows "output_complete_sequences M (output_completion_for_FSM M P)"
  unfolding output_completion_for_FSM_def output_complete_sequences.simps
proof
  fix io assume *: "io \<in> P \<union> {io @ [(x, y')] |io x y'. y' \<in> set (outputs M) \<and> (\<exists>y. io @ [(x, y)] \<in> P)}"
  show   "io = [] \<or>
          (\<forall>y\<in>set (outputs M).
              butlast io @ [(fst (last io), y)]
              \<in> P \<union> {io @ [(x, y')] |io x y'. y' \<in> set (outputs M) \<and> (\<exists>y. io @ [(x, y)] \<in> P)})"
  proof (cases io rule: rev_cases)
    case Nil
    then show ?thesis by blast
  next
    case (snoc ys y)
    then show ?thesis proof (cases "io \<in> P")
      case True
      then have "butlast io @ [(fst (last io), (snd (last io)))] \<in> P" using snoc by auto
      then show ?thesis using snoc by blast
    next
      case False
      then show ?thesis
        using "*" by auto
    qed
  qed
qed

lemma output_completion_for_FSM_length :
  assumes "\<forall> io \<in> P . length io \<le> k"
  shows   "\<forall> io \<in> output_completion_for_FSM M P. length io \<le> k"
  using assms unfolding output_completion_for_FSM_def
  by auto

fun output_completion_for_FSM_list :: "('a,'b) FSM_scheme \<Rightarrow> (Input \<times> Output) list list \<Rightarrow> (Input \<times> Output) list list" where
  "output_completion_for_FSM_list M [] = []" |
  "output_completion_for_FSM_list M (io#ios) = (case length io of
    0 \<Rightarrow> [] # (output_completion_for_FSM_list M ios) |
    Suc k \<Rightarrow> io # (map (\<lambda>y . (butlast io @ [(fst (last io), y)])) (outputs M))) @ (output_completion_for_FSM_list M ios)"

lemma output_completion_for_FSM_code[code] :
  "output_completion_for_FSM M (set xs) = set (remdups (output_completion_for_FSM_list M xs))"
proof (induction xs)
  case Nil
  then show ?case unfolding output_completion_for_FSM_def by auto
next
  case (Cons x xs)

  have *: "output_completion_for_FSM M (set (x # xs)) = output_completion_for_FSM M {x} \<union> output_completion_for_FSM M (set xs)"
    unfolding output_completion_for_FSM_def by force

  show ?case proof (cases "length x")
    case 0
    then have "set (output_completion_for_FSM_list M (x#xs)) = {[]} \<union> set (output_completion_for_FSM_list M xs)"
      by auto
    moreover have "output_completion_for_FSM M {x} = {[]}"
      using 0 unfolding output_completion_for_FSM_def by auto
    ultimately show ?thesis using * Cons.IH by force
  next
    case (Suc nat)
    then have **: "set (output_completion_for_FSM_list M (x#xs)) = (set (x # map (\<lambda>y . (butlast x @ [(fst (last x), y)])) (outputs M))) \<union> set (output_completion_for_FSM_list M xs)"
      by auto

    have "{(butlast x @ [(fst (last x), snd (last x))])} = {x}"
      using Suc snoc_eq_iff_butlast by fastforce
    then have "set (map (\<lambda>y. butlast x @ [(fst (last x), y)]) (outputs M)) = {butlast x @[(fst (last x),y)] | y . y \<in> set (outputs M)}"
      by auto
    moreover have "{io @ [(xa, y')] |io xa y'. y' \<in> set (outputs M) \<and> (\<exists>y. io @ [(xa, y)] \<in> {x})} = {butlast x @[(fst (last x),y)] | y . y \<in> set (outputs M)}"
      using \<open>{(butlast x @ [(fst (last x), snd (last x))])} = {x}\<close>
      by (metis (no_types, lifting) butlast_snoc fst_conv insertI1 last_snoc singletonD)
    ultimately have "(set (map (\<lambda>y . (butlast x @ [(fst (last x), y)])) (outputs M))) = {io @ [(xa, y')] |io xa y'. y' \<in> set (outputs M) \<and> (\<exists>y. io @ [(xa, y)] \<in> {x})}"
      by auto
    then have "(set (x # map (\<lambda>y . (butlast x @ [(fst (last x), y)])) (outputs M))) = output_completion_for_FSM M {x}"
      unfolding output_completion_for_FSM_def by auto
    then show ?thesis
      using * ** Cons.IH by auto
  qed
qed

value "output_completion_for_FSM_list M_ex_H [[(0,0)],[(0,0),(1,1)]]"
value "output_completion_for_FSM M_ex_H {[(0,0)],[(0,0),(1,1)]}"

end


(*
    $Id: ex.thy,v 1.3 2008/07/04 15:37:43 nipkow Exp $
    Author: Farhad Mehta, Tobias Nipkow
*)

header {* Tree Traversal *}

(*<*) theory ex imports Main begin (*>*)

text {* Define a datatype @{text"'a tree"} for binary trees. Both leaf and
internal nodes store information. *}

datatype 'a tree (*<*)= Tip "'a" | Node "'a" "'a tree" "'a tree"(*>*)

text {* Define the functions @{term preOrder}, @{term postOrder}, and @{term
inOrder} that traverse an @{text"'a tree"} in the respective order. *}

(*<*) consts (*>*)
  preOrder :: "'a tree \<Rightarrow> 'a list"
  postOrder :: "'a tree \<Rightarrow> 'a list"
  inOrder :: "'a tree \<Rightarrow> 'a list"

text {* Define a function @{term mirror} that returns the mirror image of an
@{text "'a tree"}. *}

(*<*) consts (*>*)
  mirror :: "'a tree \<Rightarrow> 'a tree"

text {* Suppose that @{term xOrder} and @{term yOrder} are tree traversal
functions chosen from @{term preOrder}, @{term postOrder}, and @{term inOrder}.
Formulate and prove all valid properties of the form \mbox{@{text "xOrder
(mirror xt) = rev (yOrder xt)"}}. *}

text {* Define the functions @{term root}, @{term leftmost} and @{term
rightmost}, that return the root, leftmost, and rightmost element respectively.
*}

(*<*) consts (*>*)
  root :: "'a tree \<Rightarrow> 'a"
  leftmost :: "'a tree \<Rightarrow> 'a"
  rightmost :: "'a tree \<Rightarrow> 'a"

text {* Prove (or let Isabelle disprove) the theorems that follow.  You
may have to prove some lemmas first. *}

theorem "last (inOrder xt) = rightmost xt"
(*<*) oops (*>*)

theorem "hd (inOrder xt) = leftmost xt"
(*<*) oops (*>*)

theorem "hd (preOrder xt) = last (postOrder xt)"
(*<*) oops (*>*)

theorem "hd (preOrder xt) = root xt"
(*<*) oops (*>*)

theorem "hd (inOrder xt) = root xt"
(*<*) oops (*>*)

theorem "last (postOrder xt) = root xt"
(*<*) oops (*>*)

(*<*) end (*>*)


(* Author: Nan Jiang *)

section \<open>A semilattice of reversed-ordered list\<close>

theory Dom_Semi_List
imports Main  "Jinja.Semilat" Sorted_List_Operations2 Sorted_Less2 Cfg
begin

type_synonym node = nat

context cfg_doms
begin

definition nodes :: "nat list"
  where "nodes \<equiv> (g_V G)"

definition nodes_le :: "node list \<Rightarrow> node list \<Rightarrow> bool" where
"nodes_le xs ys \<equiv> (sorted (rev ys) \<and> sorted (rev xs) \<and> (set ys) \<subseteq> (set xs)) \<or> xs = ys"

definition nodes_sup ::"node list  \<Rightarrow> node list   \<Rightarrow>node list " where
"nodes_sup = (\<lambda>x y. inter_sorted_rev x y)"

definition nodes_semi :: "node list sl" where
"nodes_semi  \<equiv> ((rev \<circ> sorted_list_of_set) ` (Pow (set (nodes))), nodes_le, nodes_sup )"

lemma subset_nodes_inpow:
  assumes "sorted (rev xs)"
      and "set xs \<subseteq> set nodes"
    shows "xs \<in> (rev \<circ> sorted_list_of_set) ` (Pow (set nodes))"
proof -
  from assms(1) have "(sorted_list_of_set (set xs)) = rev xs" by (auto intro:sorted_less_rev_set_eq)
  then have "rev (rev xs) = rev (sorted_list_of_set (set xs))" by simp
  with assms(2) show ?thesis by auto
qed

lemma nil_in_A: "[] \<in> (rev \<circ> sorted_list_of_set) ` (Pow (set nodes))"
proof(simp add: Pow_def image_def)
  have "sorted_list_of_set {} = []" by auto
  then show "\<exists>x\<subseteq>set nodes. sorted_list_of_set x = []" by blast
qed

lemma single_n_in_A: "p < length nodes \<Longrightarrow> [p] \<in> (rev \<circ> sorted_list_of_set) ` (Pow (set nodes))"
proof (unfold nodes_def)
  let ?S = "(rev \<circ> sorted_list_of_set) ` (Pow (set (g_V G)))"
  assume "p < length (g_V G)"
  then have p: "{p} \<in> Pow (set (g_V G))" by (auto simp add:Pow_def verts_set)
  then have "[p] \<in>?S" by (unfold image_def) force
  then show "[p] \<in> ?S" by auto
qed

lemma inpow_subset_nodes:
  assumes "xs \<in> (rev \<circ> sorted_list_of_set) ` (Pow (set nodes))"
    shows "set xs \<subseteq> set nodes"
proof -
  from assms obtain x where x: "x \<in> Pow (set nodes)" and "xs = (rev \<circ> sorted_list_of_set) x" by auto
  then have eq: "set xs = set (sorted_list_of_set x)" by auto
  have "\<forall>x \<in> Pow (set nodes). finite x"  by (auto intro: rev_finite_subset)
  with x eq show "set xs \<subseteq> set nodes" by auto
qed

lemma inter_in_pow_nodes:
  assumes "xs \<in> (rev \<circ> sorted_list_of_set) ` (Pow (set nodes))"
    shows "(rev \<circ> sorted_list_of_set)(set xs \<inter> set ys) \<in> (rev \<circ> (sorted_list_of_set)) ` (Pow (set nodes))"
  using assms
proof -
  let ?res = "set xs \<inter> set ys"
  from assms have "set xs \<subseteq> set nodes" using inpow_subset_nodes by auto
  then have "?res \<subseteq> set nodes" by auto
  then show ?thesis using subset_nodes_inpow by auto
qed

lemma nodes_le_order: "order nodes_le ((rev \<circ> sorted_list_of_set) ` (Pow (set nodes)))"
proof -
  let ?A = "(rev \<circ> sorted_list_of_set) ` (Pow (set nodes))"

  have "\<forall>x \<in> ?A. sorted (rev x)" by (auto intro: sorted_less_sorted_list_of_set)
  then have "\<forall>x\<in>?A. nodes_le x x" by (auto simp add:nodes_le_def)

  moreover have "\<forall>x\<in>?A. \<forall>y\<in>?A. (nodes_le x y \<and> nodes_le y x \<longrightarrow> x = y)"
  proof (intro strip)
    fix x y
    assume "x \<in> ?A" and "y \<in> ?A" and "nodes_le x y \<and> nodes_le y x"
    then have "sorted (rev x) \<and> sorted (rev (y::nat list)) \<and>  set x = set y \<or> x = y"
      by (auto simp add: nodes_le_def intro:subset_antisym sorted_less_sorted_list_of_set)
   then show "x = y" by (auto dest: sorted_less_rev_set_unique)
 qed

  moreover have "\<forall>x\<in> ?A.   \<forall>y\<in> ?A. \<forall>z\<in> ?A . nodes_le x y \<and> nodes_le y  z \<longrightarrow> nodes_le x z"
    by (auto simp add: nodes_le_def)

  ultimately show ?thesis by (unfold order_def lesub_def lesssub_def) fastforce
qed

lemma nodes_semi_auxi:
  "let A = (rev \<circ> sorted_list_of_set) ` (Pow (set (nodes)));
       r = nodes_le;
       f = (\<lambda>x y.  (inter_sorted_rev x y))
    in semilat(A, r, f)"
proof -
  let ?A = "(rev \<circ> sorted_list_of_set) ` (Pow (set (nodes)))"
  let ?r = "nodes_le"
  let ?f = "(\<lambda>x y. (inter_sorted_rev x y))"

  have "order ?r ?A" by (rule nodes_le_order)

  moreover have "closed ?A ?f"
  proof (unfold closed_def, intro strip)
    fix xs ys assume xs_in: "xs \<in> ?A" and ys_in: "ys \<in> ?A"
    then have sorted_xs: "sorted (rev xs)"
          and sorted_ys: "sorted (rev ys)"
      by (auto intro: sorted_less_sorted_list_of_set)
    then have inter_xs_ys: "set (?f xs ys) = set xs \<inter> set ys" and
              sorted_res: "sorted (rev (?f xs ys))"
      using inter_sorted_correct by auto

    from xs_in have "set xs \<subseteq> set nodes" using inpow_subset_nodes by auto
    with inter_xs_ys have "set (?f xs ys) \<subseteq> set nodes" by auto
    with sorted_res show "xs \<squnion>\<^bsub>?f\<^esub> ys\<in> ?A" using subset_nodes_inpow by (auto simp add:plussub_def)
  qed

  moreover have "(\<forall>x\<in>?A. \<forall>y\<in>?A. x \<sqsubseteq>\<^bsub>?r\<^esub> x \<squnion>\<^bsub>?f\<^esub> y) \<and> (\<forall>x\<in>?A. \<forall>y\<in>?A. y \<sqsubseteq>\<^bsub>?r\<^esub> x \<squnion>\<^bsub>?f\<^esub> y)"
  proof(rule conjI, intro strip)
    fix xs ys
    assume xs_in: "xs \<in> ?A" and ys_in: "ys \<in> ?A"
    then have sorted_xs: "sorted (rev xs)" and sorted_ys: "sorted (rev ys)"
      by (auto intro: sorted_less_sorted_list_of_set)
    then have "set (?f xs ys) \<subseteq> set xs" and sorted_f_xs_ys: "sorted (rev (?f xs ys))"
      by (auto simp add: inter_sorted_correct)
    then show "xs \<sqsubseteq>\<^bsub>?r\<^esub> xs \<squnion>\<^bsub>?f\<^esub> ys"  by (simp add: lesub_def sorted_xs sorted_ys sorted_f_xs_ys nodes_le_def plussub_def)
  next
    show "\<forall>x\<in>?A. \<forall>y\<in>?A. y \<sqsubseteq>\<^bsub>?r\<^esub> x \<squnion>\<^bsub>?f\<^esub> y"
    proof (intro strip)
      fix xs ys
      assume xs_in: "xs \<in> ?A" and ys_in: "ys \<in> ?A"
      then have sorted_xs: "sorted (rev xs)" and sorted_ys: "sorted (rev ys)"
        by (auto intro: sorted_less_sorted_list_of_set)
      then have "set (?f xs ys) \<subseteq> set ys" and sorted_f_xs_ys: "sorted (rev (?f xs ys))" by (auto simp add: inter_sorted_correct)
      then show "ys \<sqsubseteq>\<^bsub>?r\<^esub> xs \<squnion>\<^bsub>?f\<^esub> ys" by (simp add: lesub_def sorted_ys sorted_xs sorted_f_xs_ys nodes_le_def plussub_def)
    qed
  qed

  moreover have "\<forall>x\<in>?A. \<forall>y\<in>?A. \<forall>z\<in>?A. x \<sqsubseteq>\<^bsub>?r\<^esub> z \<and> y  \<sqsubseteq>\<^bsub>?r\<^esub> z \<longrightarrow> x \<squnion>\<^bsub>?f\<^esub> y \<sqsubseteq>\<^bsub>?r\<^esub>z"
  proof (intro strip)
    fix xs ys zs
    assume xin: "xs \<in> ?A" and yin: "ys \<in> ?A" and zin: "zs \<in> ?A" and "xs \<sqsubseteq>\<^bsub>?r\<^esub> zs \<and> ys \<sqsubseteq>\<^bsub>?r\<^esub> zs"
    then have xs_zs: "xs \<sqsubseteq>\<^bsub>?r\<^esub> zs" and ys_zs: "ys \<sqsubseteq>\<^bsub>?r\<^esub> zs" and sorted_xs: "sorted (rev xs)" and sorted_ys: "sorted (rev ys)" by (auto simp add: sorted_less_sorted_list_of_set)
    then have inter_xs_ys: "set (?f xs ys) = (set xs \<inter> set ys)" and sorted_f_xs_ys: "sorted (rev (?f xs ys))"
      by (auto simp add: inter_sorted_correct)

    from xs_zs ys_zs sorted_xs have sorted_zs: "sorted (rev zs)"
                                and "set zs \<subseteq> set xs"
                                and "set zs \<subseteq> set ys" by (auto simp add: lesub_def nodes_le_def)
    then have zs: "set zs \<subseteq> set xs \<inter> set ys" by auto
    with inter_xs_ys sorted_zs sorted_f_xs_ys show "xs \<squnion>\<^bsub>?f\<^esub> ys \<sqsubseteq>\<^bsub>?r\<^esub> zs"
      by (auto simp add:plussub_def lesub_def  sorted_xs sorted_ys sorted_f_xs_ys sorted_zs nodes_le_def)
  qed
  ultimately show ?thesis  by (unfold semilat_def) simp
qed

lemma nodes_semi_is_semilat: "semilat (nodes_semi)"
  using nodes_semi_auxi
  by (auto simp add: nodes_sup_def nodes_semi_def)

lemma sorted_rev_subset_len_lt:
  assumes "sorted (rev a)"
      and "sorted (rev b)"
      and "set a \<subset> set b"
    shows "length a < length b"
  using assms
proof-
  from assms(1) assms(2) have dist_a: "distinct a" and dist_b: "distinct b" by (auto dest: distinct_sorted_rev)
  from assms(3)  have "card (set a) < card (set b)" by (auto intro: psubset_card_mono)
  with dist_a dist_b show ?thesis by (auto simp add: distinct_card)
qed

lemma wf_nodes_le_auxi: "wf {(y, x). (sorted (rev y) \<and> sorted (rev x) \<and> set y \<subset> set x) \<and> x \<noteq> y}"
  apply(rule wf_measure [THEN wf_subset])
  apply(simp only: measure_def inv_image_def)
  apply clarify
  apply(frule sorted_rev_subset_len_lt)
    defer
    defer
    apply fastforce
  by (auto intro:sorted_less_rev_set_unique)

lemma wf_nodes_le_auxi2:
  "wf {(y, x). sorted (rev y) \<and> sorted (rev x) \<and> set y \<subset> set x \<and> rev x \<noteq> rev y}"
  using wf_nodes_le_auxi by auto

lemma  wf_nodes_le: "wf {(y, x). nodes_le x y \<and> x \<noteq> y}"
proof -
  have eq_set: "{(y, x). (sorted (rev y) \<and> sorted (rev x) \<and> set y \<subseteq> set x) \<and> x \<noteq> y} =
                {(y, x). nodes_le x y \<and> x \<noteq> y}" by (unfold nodes_le_def) auto
  have "{(y, x). (sorted (rev y) \<and> sorted (rev x) \<and> set y \<subset> set x) \<and> x \<noteq> y} =
        {(y, x). (sorted (rev y) \<and> sorted (rev x) \<and> set y \<subseteq> set x) \<and> x \<noteq> y}"
    by (auto simp add:sorted_less_rev_set_unique)
  from this wf_nodes_le_auxi have "wf {(y, x). (sorted (rev y) \<and> sorted (rev x) \<and> set y \<subseteq> set x) \<and> x \<noteq> y}" by (rule subst)
  with eq_set show ?thesis by (rule subst)
qed

lemma acc_nodes_le: "acc nodes_le"
  apply (unfold acc_def lesssub_def lesub_def)
  apply (rule wf_nodes_le)
  done

lemma acc_nodes_le2: "acc (fst (snd nodes_semi))"
  apply (unfold nodes_semi_def)
  apply (auto simp add: lesssub_def lesub_def intro: acc_nodes_le)
  done

lemma nodes_le_refl [iff] : "nodes_le s s"
  apply (unfold nodes_le_def lesssub_def lesub_def)
  apply (auto)
  done

end

end


theory T122
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=10,timeout=86400]
oops
end


theory T184
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=10,timeout=86400]
oops
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_TSortPermutes
imports "../../Test_Base"
begin

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

datatype Tree = TNode "Tree" "int" "Tree" | TNil

fun flatten :: "Tree => int list => int list" where
"flatten (TNode p z q) y = flatten p (cons2 z (flatten q y))"
| "flatten (TNil) y = y"

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

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
"deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
"isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

fun add :: "int => Tree => Tree" where
"add x (TNode p z q) =
   (if x <= z then TNode (add x p) z q else TNode p z (add x q))"
| "add x (TNil) = TNode TNil x TNil"

fun toTree :: "int list => Tree" where
"toTree (nil2) = TNil"
| "toTree (cons2 y xs) = add y (toTree xs)"

fun tsort :: "int list => int list" where
"tsort x = flatten (toTree x) (nil2)"

theorem property0 :
  "isPermutation (tsort xs) xs"
  oops

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               November 2004               |
            |                   June 2005  (modified)   |
            |                   July 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                  April 2016  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2020         |
            |                  April 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Infra_real
imports Infra_common
begin

(*****************************************************
                    Real number
 *****************************************************)

(* this lemma real_mult_less_mono
   was given in Isabelle 2005, but is removed in Isabelle 2007 *)

lemma real_mult_less_mono:
     "[| u<v;  x<y;  (0::real) < v;  0 < x |] ==> u*x < v* y"
by (simp add: Rings.mult_strict_mono order_less_imp_le)
(* by (simp add: Ring_and_Field.mult_strict_mono order_less_imp_le)     isabelle2009-1 *)

(* mult_commute for Isabelle 2016 *)
lemma mult_commute: "(x::real) * y = y * x"
apply (simp)
done

lemma real_mult_add_distrib: "(x::real) * (y + z) = x * y + x * z"
apply (subgoal_tac "x * (y + z) = (y + z) * x")
 (* apply (simp add: real_add_mult_distrib)   isabelle 2011 *)
(* apply (simp add: distrib)  Isabelle 2013 *)
apply (simp add: distrib_left)
apply (simp add: mult_commute)
done

lemma real_mult_order_eq : "[| 0 <= x; 0 <= y |] ==> (0::real) <= x * y"
apply (case_tac "x = 0", simp)
apply (case_tac "y = 0", simp)
apply (subgoal_tac "0 < x * y")
apply (simp)
(* apply (simp add: real_mult_order)  isabelle 2011 *)
apply (simp add: zero_less_mult_iff)
done

lemma real_div_le_eq:
   "0 < (z::real) ==> (x <= y / z) = (x * z <= y)"
apply (rule iffI)
apply (insert mult_right_mono[of x "y/z" z], simp)
apply (insert real_mult_le_cancel_iff1[of z x "y/z"], simp)
done

lemma real_div_less_eq:
   "0 < (z::real) ==> (x < y / z) = (x * z < y)"
apply (rule iffI)
apply (insert real_mult_less_iff1[of z x "y/z"], simp)
apply (insert mult_less_cancel_right[of x "y/z" z], simp)
done

lemma real_less_div_eq:
   "0 < (z::real) ==> (x / z < y) = (x < y * z)"
apply (rule iffI)
apply (insert real_mult_less_iff1[of z "x/z" y], simp)
apply (insert mult_less_cancel_right[of "x/z" y z], simp)
done

lemma real_mult_div_commute:
     "[| (0::real) <= x ; 0 < y ; 0 < z ; 0 < r |]
        ==> (x < y * z / r) = (r * x / z < y)"
apply (simp add: real_div_less_eq)
apply (simp add: real_less_div_eq)
apply (simp add: mult_commute)
done

lemma real_mult_div_commuteI:
     "[| (0::real) <= x ; 0 < y ; 0 < z ; 0 < r ; x < y * z / r |]
        ==> (r * x / z < y)"
apply (simp add: real_mult_div_commute)
done

lemma real_mult_less_iff2: "(0::real) < z ==> (z*x < z*y) = (x < y)"
by (simp add: mult_commute)

lemma real_mult_less_if2: "[| (0::real) < z ; (x::real) < y |] ==> z*x < z*y"
by (simp add: real_mult_less_iff2)

lemma real_mult_less_if1: "[| (0::real) < z ; (x::real) < y |] ==> x*z < y*z"
by (simp)

(*** rev_power_decreasing ***)

lemma rev_power_decreasing:
  "[| (0::real) < r ; r < 1 ; r ^ n <= r ^ m |] ==> m <= n"

apply (case_tac "m <= n")
 apply (simp)

(* else n < m --> contradiction *)
apply (insert power_decreasing[of "Suc n" m r])
  apply (simp)
(*
not necessary for isabelle 2020:
apply (subgoal_tac "r * r ^ n <  1 * r ^ n")
apply (simp)
apply (rule real_mult_less_if1)
by (simp_all)
*)
  done

(*** rev_power_decreasing_strict ***)

lemma rev_power_decreasing_strict :
  "[| (0::real) < r ; r < 1 ; r ^ n < r ^ m |] ==> m < n"
apply (case_tac "m < n")
 apply (simp)

(* else n <= m --> contradiction *)
apply (insert power_decreasing[of n m r])
by (simp)

end


(*  Title:      HOL/ex/Unification.thy
    Author:     Martin Coen, Cambridge University Computer Laboratory
    Author:     Konrad Slind, TUM & Cambridge University Computer Laboratory
    Author:     Alexander Krauss, TUM
*)

section \<open>Substitution and Unification\<close>

theory Unification
imports Main
begin

text \<open>
  Implements Manna \& Waldinger's formalization, with Paulson's
  simplifications, and some new simplifications by Slind and Krauss.

  Z Manna \& R Waldinger, Deductive Synthesis of the Unification
  Algorithm.  SCP 1 (1981), 5-48

  L C Paulson, Verifying the Unification Algorithm in LCF. SCP 5
  (1985), 143-170

  K Slind, Reasoning about Terminating Functional Programs,
  Ph.D. thesis, TUM, 1999, Sect. 5.8

  A Krauss, Partial and Nested Recursive Function Definitions in
  Higher-Order Logic, JAR 44(4):303-336, 2010. Sect. 6.3
\<close>

subsection \<open>Terms\<close>

text \<open>Binary trees with leaves that are constants or variables.\<close>

datatype 'a trm =
  Var 'a
  | Const 'a
  | Comb "'a trm" "'a trm" (infix "\<cdot>" 60)

primrec vars_of :: "'a trm \<Rightarrow> 'a set"
where
  "vars_of (Var v) = {v}"
| "vars_of (Const c) = {}"
| "vars_of (M \<cdot> N) = vars_of M \<union> vars_of N"

fun occs :: "'a trm \<Rightarrow> 'a trm \<Rightarrow> bool" (infixl "\<prec>" 54)
where
  "u \<prec> Var v \<longleftrightarrow> False"
| "u \<prec> Const c \<longleftrightarrow> False"
| "u \<prec> M \<cdot> N \<longleftrightarrow> u = M \<or> u = N \<or> u \<prec> M \<or> u \<prec> N"

lemma finite_vars_of[intro]: "finite (vars_of t)"
  by (induct t) simp_all

lemma vars_iff_occseq: "x \<in> vars_of t \<longleftrightarrow> Var x \<prec> t \<or> Var x = t"
  by (induct t) auto

lemma occs_vars_subset: "M \<prec> N \<Longrightarrow> vars_of M \<subseteq> vars_of N"
  by (induct N) auto

subsection \<open>Substitutions\<close>

type_synonym 'a subst = "('a \<times> 'a trm) list"

fun assoc :: "'a \<Rightarrow> 'b \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> 'b"
where
  "assoc x d [] = d"
| "assoc x d ((p,q)#t) = (if x = p then q else assoc x d t)"

primrec subst :: "'a trm \<Rightarrow> 'a subst \<Rightarrow> 'a trm" (infixl "\<lhd>" 55)
where
  "(Var v) \<lhd> s = assoc v (Var v) s"
| "(Const c) \<lhd> s = (Const c)"
| "(M \<cdot> N) \<lhd> s = (M \<lhd> s) \<cdot> (N \<lhd> s)"

definition subst_eq (infixr "\<doteq>" 52)
where
  "s1 \<doteq> s2 \<longleftrightarrow> (\<forall>t. t \<lhd> s1 = t \<lhd> s2)"

fun comp :: "'a subst \<Rightarrow> 'a subst \<Rightarrow> 'a subst" (infixl "\<lozenge>" 56)
where
  "[] \<lozenge> bl = bl"
| "((a,b) # al) \<lozenge> bl = (a, b \<lhd> bl) # (al \<lozenge> bl)"

lemma subst_Nil[simp]: "t \<lhd> [] = t"
by (induct t) auto

lemma subst_mono: "t \<prec> u \<Longrightarrow> t \<lhd> s \<prec> u \<lhd> s"
by (induct u) auto

lemma agreement: "(t \<lhd> r = t \<lhd> s) \<longleftrightarrow> (\<forall>v \<in> vars_of t. Var v \<lhd> r = Var v \<lhd> s)"
by (induct t) auto

lemma repl_invariance: "v \<notin> vars_of t \<Longrightarrow> t \<lhd> (v,u) # s = t \<lhd> s"
by (simp add: agreement)

lemma remove_var: "v \<notin> vars_of s \<Longrightarrow> v \<notin> vars_of (t \<lhd> [(v, s)])"
by (induct t) simp_all

lemma subst_refl[iff]: "s \<doteq> s"
  by (auto simp:subst_eq_def)

lemma subst_sym[sym]: "\<lbrakk>s1 \<doteq> s2\<rbrakk> \<Longrightarrow> s2 \<doteq> s1"
  by (auto simp:subst_eq_def)

lemma subst_trans[trans]: "\<lbrakk>s1 \<doteq> s2; s2 \<doteq> s3\<rbrakk> \<Longrightarrow> s1 \<doteq> s3"
  by (auto simp:subst_eq_def)

lemma subst_no_occs: "\<not> Var v \<prec> t \<Longrightarrow> Var v \<noteq> t
  \<Longrightarrow> t \<lhd> [(v,s)] = t"
by (induct t) auto

lemma comp_Nil[simp]: "\<sigma> \<lozenge> [] = \<sigma>"
by (induct \<sigma>) auto

lemma subst_comp[simp]: "t \<lhd> (r \<lozenge> s) = t \<lhd> r \<lhd> s"
proof (induct t)
  case (Var v) thus ?case
    by (induct r) auto
qed auto

lemma subst_eq_intro[intro]: "(\<And>t. t \<lhd> \<sigma> = t \<lhd> \<theta>) \<Longrightarrow> \<sigma> \<doteq> \<theta>"
  by (auto simp:subst_eq_def)

lemma subst_eq_dest[dest]: "s1 \<doteq> s2 \<Longrightarrow> t \<lhd> s1 = t \<lhd> s2"
  by (auto simp:subst_eq_def)

lemma comp_assoc: "(a \<lozenge> b) \<lozenge> c \<doteq> a \<lozenge> (b \<lozenge> c)"
  by auto

lemma subst_cong: "\<lbrakk>\<sigma> \<doteq> \<sigma>'; \<theta> \<doteq> \<theta>'\<rbrakk> \<Longrightarrow> (\<sigma> \<lozenge> \<theta>) \<doteq> (\<sigma>' \<lozenge> \<theta>')"
  by (auto simp: subst_eq_def)

lemma var_self: "[(v, Var v)] \<doteq> []"
proof
  fix t show "t \<lhd> [(v, Var v)] = t \<lhd> []"
    by (induct t) simp_all
qed

lemma var_same[simp]: "[(v, t)] \<doteq> [] \<longleftrightarrow> t = Var v"
by (metis assoc.simps(2) subst.simps(1) subst_eq_def var_self)

lemma vars_of_subst_conv_Union: "vars_of (t \<lhd> \<eta>) = \<Union>(vars_of ` (\<lambda>x. Var x \<lhd> \<eta>) ` vars_of t)"
  by (induction t) simp_all

lemma domain_comp: "fst ` set (\<sigma> \<lozenge> \<theta>) = fst ` (set \<sigma> \<union> set \<theta>)"
  by (induction \<sigma> \<theta> rule: comp.induct) auto

subsection \<open>Unifiers and Most General Unifiers\<close>

definition Unifier :: "'a subst \<Rightarrow> 'a trm \<Rightarrow> 'a trm \<Rightarrow> bool"
where "Unifier \<sigma> t u \<longleftrightarrow> (t \<lhd> \<sigma> = u \<lhd> \<sigma>)"

definition MGU :: "'a subst \<Rightarrow> 'a trm \<Rightarrow> 'a trm \<Rightarrow> bool" where
  "MGU \<sigma> t u \<longleftrightarrow>
   Unifier \<sigma> t u \<and> (\<forall>\<theta>. Unifier \<theta> t u \<longrightarrow> (\<exists>\<gamma>. \<theta> \<doteq> \<sigma> \<lozenge> \<gamma>))"

lemma MGUI[intro]:
  "\<lbrakk>t \<lhd> \<sigma> = u \<lhd> \<sigma>; \<And>\<theta>. t \<lhd> \<theta> = u \<lhd> \<theta> \<Longrightarrow> \<exists>\<gamma>. \<theta> \<doteq> \<sigma> \<lozenge> \<gamma>\<rbrakk>
  \<Longrightarrow> MGU \<sigma> t u"
  by (simp only:Unifier_def MGU_def, auto)

lemma MGU_sym[sym]:
  "MGU \<sigma> s t \<Longrightarrow> MGU \<sigma> t s"
  by (auto simp:MGU_def Unifier_def)

lemma MGU_is_Unifier: "MGU \<sigma> t u \<Longrightarrow> Unifier \<sigma> t u"
unfolding MGU_def by (rule conjunct1)

lemma MGU_Var:
  assumes "\<not> Var v \<prec> t"
  shows "MGU [(v,t)] (Var v) t"
proof (intro MGUI exI)
  show "Var v \<lhd> [(v,t)] = t \<lhd> [(v,t)]" using assms
    by (metis assoc.simps(2) repl_invariance subst.simps(1) subst_Nil vars_iff_occseq)
next
  fix \<theta> assume th: "Var v \<lhd> \<theta> = t \<lhd> \<theta>"
  show "\<theta> \<doteq> [(v,t)] \<lozenge> \<theta>"
  proof
    fix s show "s \<lhd> \<theta> = s \<lhd> [(v,t)] \<lozenge> \<theta>" using th
      by (induct s) auto
  qed
qed

lemma MGU_Const: "MGU [] (Const c) (Const d) \<longleftrightarrow> c = d"
  by (auto simp: MGU_def Unifier_def)

subsection \<open>The unification algorithm\<close>

function unify :: "'a trm \<Rightarrow> 'a trm \<Rightarrow> 'a subst option"
where
  "unify (Const c) (M \<cdot> N)   = None"
| "unify (M \<cdot> N)   (Const c) = None"
| "unify (Const c) (Var v)   = Some [(v, Const c)]"
| "unify (M \<cdot> N)   (Var v)   = (if Var v \<prec> M \<cdot> N
                                        then None
                                        else Some [(v, M \<cdot> N)])"
| "unify (Var v)   M         = (if Var v \<prec> M
                                        then None
                                        else Some [(v, M)])"
| "unify (Const c) (Const d) = (if c=d then Some [] else None)"
| "unify (M \<cdot> N) (M' \<cdot> N') = (case unify M M' of
                                    None \<Rightarrow> None |
                                    Some \<theta> \<Rightarrow> (case unify (N \<lhd> \<theta>) (N' \<lhd> \<theta>)
                                      of None \<Rightarrow> None |
                                         Some \<sigma> \<Rightarrow> Some (\<theta> \<lozenge> \<sigma>)))"
  by pat_completeness auto

subsection \<open>Properties used in termination proof\<close>

text \<open>Elimination of variables by a substitution:\<close>

definition
  "elim \<sigma> v \<equiv> \<forall>t. v \<notin> vars_of (t \<lhd> \<sigma>)"

lemma elim_intro[intro]: "(\<And>t. v \<notin> vars_of (t \<lhd> \<sigma>)) \<Longrightarrow> elim \<sigma> v"
  by (auto simp:elim_def)

lemma elim_dest[dest]: "elim \<sigma> v \<Longrightarrow> v \<notin> vars_of (t \<lhd> \<sigma>)"
  by (auto simp:elim_def)

lemma elim_eq: "\<sigma> \<doteq> \<theta> \<Longrightarrow> elim \<sigma> x = elim \<theta> x"
  by (auto simp:elim_def subst_eq_def)

lemma occs_elim: "\<not> Var v \<prec> t
  \<Longrightarrow> elim [(v,t)] v \<or> [(v,t)] \<doteq> []"
by (metis elim_intro remove_var var_same vars_iff_occseq)

text \<open>The result of a unification never introduces new variables:\<close>

declare unify.psimps[simp]

lemma unify_vars:
  assumes "unify_dom (M, N)"
  assumes "unify M N = Some \<sigma>"
  shows "vars_of (t \<lhd> \<sigma>) \<subseteq> vars_of M \<union> vars_of N \<union> vars_of t"
  (is "?P M N \<sigma> t")
using assms
proof (induct M N arbitrary:\<sigma> t)
  case (3 c v)
  hence "\<sigma> = [(v, Const c)]" by simp
  thus ?case by (induct t) auto
next
  case (4 M N v)
  hence "\<not> Var v \<prec> M \<cdot> N" by auto
  with 4 have "\<sigma> = [(v, M\<cdot>N)]" by simp
  thus ?case by (induct t) auto
next
  case (5 v M)
  hence "\<not> Var v \<prec> M" by auto
  with 5 have "\<sigma> = [(v, M)]" by simp
  thus ?case by (induct t) auto
next
  case (7 M N M' N' \<sigma>)
  then obtain \<theta>1 \<theta>2
    where "unify M M' = Some \<theta>1"
    and "unify (N \<lhd> \<theta>1) (N' \<lhd> \<theta>1) = Some \<theta>2"
    and \<sigma>: "\<sigma> = \<theta>1 \<lozenge> \<theta>2"
    and ih1: "\<And>t. ?P M M' \<theta>1 t"
    and ih2: "\<And>t. ?P (N\<lhd>\<theta>1) (N'\<lhd>\<theta>1) \<theta>2 t"
    by (auto split:option.split_asm)

  show ?case
  proof
    fix v assume a: "v \<in> vars_of (t \<lhd> \<sigma>)"

    show "v \<in> vars_of (M \<cdot> N) \<union> vars_of (M' \<cdot> N') \<union> vars_of t"
    proof (cases "v \<notin> vars_of M \<and> v \<notin> vars_of M'
        \<and> v \<notin> vars_of N \<and> v \<notin> vars_of N'")
      case True
      with ih1 have l:"\<And>t. v \<in> vars_of (t \<lhd> \<theta>1) \<Longrightarrow> v \<in> vars_of t"
        by auto

      from a and ih2[where t="t \<lhd> \<theta>1"]
      have "v \<in> vars_of (N \<lhd> \<theta>1) \<union> vars_of (N' \<lhd> \<theta>1)
        \<or> v \<in> vars_of (t \<lhd> \<theta>1)" unfolding \<sigma>
        by auto
      hence "v \<in> vars_of t"
      proof
        assume "v \<in> vars_of (N \<lhd> \<theta>1) \<union> vars_of (N' \<lhd> \<theta>1)"
        with True show ?thesis by (auto dest:l)
      next
        assume "v \<in> vars_of (t \<lhd> \<theta>1)"
        thus ?thesis by (rule l)
      qed

      thus ?thesis by auto
    qed auto
  qed
qed (auto split: if_split_asm)

text \<open>The result of a unification is either the identity
substitution or it eliminates a variable from one of the terms:\<close>

lemma unify_eliminates:
  assumes "unify_dom (M, N)"
  assumes "unify M N = Some \<sigma>"
  shows "(\<exists>v\<in>vars_of M \<union> vars_of N. elim \<sigma> v) \<or> \<sigma> \<doteq> []"
  (is "?P M N \<sigma>")
using assms
proof (induct M N arbitrary:\<sigma>)
  case 1 thus ?case by simp
next
  case 2 thus ?case by simp
next
  case (3 c v)
  have no_occs: "\<not> Var v \<prec> Const c" by simp
  with 3 have "\<sigma> = [(v, Const c)]" by simp
  with occs_elim[OF no_occs]
  show ?case by auto
next
  case (4 M N v)
  hence no_occs: "\<not> Var v \<prec> M \<cdot> N" by auto
  with 4 have "\<sigma> = [(v, M\<cdot>N)]" by simp
  with occs_elim[OF no_occs]
  show ?case by auto
next
  case (5 v M)
  hence no_occs: "\<not> Var v \<prec> M" by auto
  with 5 have "\<sigma> = [(v, M)]" by simp
  with occs_elim[OF no_occs]
  show ?case by auto
next
  case (6 c d) thus ?case
    by (cases "c = d") auto
next
  case (7 M N M' N' \<sigma>)
  then obtain \<theta>1 \<theta>2
    where "unify M M' = Some \<theta>1"
    and "unify (N \<lhd> \<theta>1) (N' \<lhd> \<theta>1) = Some \<theta>2"
    and \<sigma>: "\<sigma> = \<theta>1 \<lozenge> \<theta>2"
    and ih1: "?P M M' \<theta>1"
    and ih2: "?P (N\<lhd>\<theta>1) (N'\<lhd>\<theta>1) \<theta>2"
    by (auto split:option.split_asm)

  from \<open>unify_dom (M \<cdot> N, M' \<cdot> N')\<close>
  have "unify_dom (M, M')"
    by (rule accp_downward) (rule unify_rel.intros)
  hence no_new_vars:
    "\<And>t. vars_of (t \<lhd> \<theta>1) \<subseteq> vars_of M \<union> vars_of M' \<union> vars_of t"
    by (rule unify_vars) (rule \<open>unify M M' = Some \<theta>1\<close>)

  from ih2 show ?case
  proof
    assume "\<exists>v\<in>vars_of (N \<lhd> \<theta>1) \<union> vars_of (N' \<lhd> \<theta>1). elim \<theta>2 v"
    then obtain v
      where "v\<in>vars_of (N \<lhd> \<theta>1) \<union> vars_of (N' \<lhd> \<theta>1)"
      and el: "elim \<theta>2 v" by auto
    with no_new_vars show ?thesis unfolding \<sigma>
      by (auto simp:elim_def)
  next
    assume empty[simp]: "\<theta>2 \<doteq> []"

    have "\<sigma> \<doteq> (\<theta>1 \<lozenge> [])" unfolding \<sigma>
      by (rule subst_cong) auto
    also have "\<dots> \<doteq> \<theta>1" by auto
    finally have "\<sigma> \<doteq> \<theta>1" .

    from ih1 show ?thesis
    proof
      assume "\<exists>v\<in>vars_of M \<union> vars_of M'. elim \<theta>1 v"
      with elim_eq[OF \<open>\<sigma> \<doteq> \<theta>1\<close>]
      show ?thesis by auto
    next
      note \<open>\<sigma> \<doteq> \<theta>1\<close>
      also assume "\<theta>1 \<doteq> []"
      finally show ?thesis ..
    qed
  qed
qed

declare unify.psimps[simp del]

subsection \<open>Termination proof\<close>

termination unify
proof
  let ?R = "measures [\<lambda>(M,N). card (vars_of M \<union> vars_of N),
                           \<lambda>(M, N). size M]"
  show "wf ?R" by simp

  fix M N M' N' :: "'a trm"
  show "((M, M'), (M \<cdot> N, M' \<cdot> N')) \<in> ?R" \<comment> \<open>Inner call\<close>
    by (rule measures_lesseq) (auto intro: card_mono)

  fix \<theta>                                   \<comment> \<open>Outer call\<close>
  assume inner: "unify_dom (M, M')"
    "unify M M' = Some \<theta>"

  from unify_eliminates[OF inner]
  show "((N \<lhd> \<theta>, N' \<lhd> \<theta>), (M \<cdot> N, M' \<cdot> N')) \<in>?R"
  proof
    \<comment> \<open>Either a variable is eliminated \ldots\<close>
    assume "(\<exists>v\<in>vars_of M \<union> vars_of M'. elim \<theta> v)"
    then obtain v
      where "elim \<theta> v"
      and "v\<in>vars_of M \<union> vars_of M'" by auto
    with unify_vars[OF inner]
    have "vars_of (N\<lhd>\<theta>) \<union> vars_of (N'\<lhd>\<theta>)
      \<subset> vars_of (M\<cdot>N) \<union> vars_of (M'\<cdot>N')"
      by auto

    thus ?thesis
      by (auto intro!: measures_less intro: psubset_card_mono)
  next
    \<comment> \<open>Or the substitution is empty\<close>
    assume "\<theta> \<doteq> []"
    hence "N \<lhd> \<theta> = N"
      and "N' \<lhd> \<theta> = N'" by auto
    thus ?thesis
       by (auto intro!: measures_less intro: psubset_card_mono)
  qed
qed

subsection \<open>Unification returns a Most General Unifier\<close>

lemma unify_computes_MGU:
  "unify M N = Some \<sigma> \<Longrightarrow> MGU \<sigma> M N"
proof (induct M N arbitrary: \<sigma> rule: unify.induct)
  case (7 M N M' N' \<sigma>) \<comment> \<open>The interesting case\<close>

  then obtain \<theta>1 \<theta>2
    where "unify M M' = Some \<theta>1"
    and "unify (N \<lhd> \<theta>1) (N' \<lhd> \<theta>1) = Some \<theta>2"
    and \<sigma>: "\<sigma> = \<theta>1 \<lozenge> \<theta>2"
    and MGU_inner: "MGU \<theta>1 M M'"
    and MGU_outer: "MGU \<theta>2 (N \<lhd> \<theta>1) (N' \<lhd> \<theta>1)"
    by (auto split:option.split_asm)

  show ?case
  proof
    from MGU_inner and MGU_outer
    have "M \<lhd> \<theta>1 = M' \<lhd> \<theta>1"
      and "N \<lhd> \<theta>1 \<lhd> \<theta>2 = N' \<lhd> \<theta>1 \<lhd> \<theta>2"
      unfolding MGU_def Unifier_def
      by auto
    thus "M \<cdot> N \<lhd> \<sigma> = M' \<cdot> N' \<lhd> \<sigma>" unfolding \<sigma>
      by simp
  next
    fix \<sigma>' assume "M \<cdot> N \<lhd> \<sigma>' = M' \<cdot> N' \<lhd> \<sigma>'"
    hence "M \<lhd> \<sigma>' = M' \<lhd> \<sigma>'"
      and Ns: "N \<lhd> \<sigma>' = N' \<lhd> \<sigma>'" by auto

    with MGU_inner obtain \<delta>
      where eqv: "\<sigma>' \<doteq> \<theta>1 \<lozenge> \<delta>"
      unfolding MGU_def Unifier_def
      by auto

    from Ns have "N \<lhd> \<theta>1 \<lhd> \<delta> = N' \<lhd> \<theta>1 \<lhd> \<delta>"
      by (simp add:subst_eq_dest[OF eqv])

    with MGU_outer obtain \<rho>
      where eqv2: "\<delta> \<doteq> \<theta>2 \<lozenge> \<rho>"
      unfolding MGU_def Unifier_def
      by auto

    have "\<sigma>' \<doteq> \<sigma> \<lozenge> \<rho>" unfolding \<sigma>
      by (rule subst_eq_intro, auto simp:subst_eq_dest[OF eqv] subst_eq_dest[OF eqv2])
    thus "\<exists>\<gamma>. \<sigma>' \<doteq> \<sigma> \<lozenge> \<gamma>" ..
  qed
qed (auto simp: MGU_Const intro: MGU_Var MGU_Var[symmetric] split: if_split_asm)

subsection \<open>Unification returns Idempotent Substitution\<close>

definition Idem :: "'a subst \<Rightarrow> bool"
where "Idem s \<longleftrightarrow> (s \<lozenge> s) \<doteq> s"

lemma Idem_Nil [iff]: "Idem []"
  by (simp add: Idem_def)

lemma Var_Idem:
  assumes "~ (Var v \<prec> t)" shows "Idem [(v,t)]"
  unfolding Idem_def
proof
  from assms have [simp]: "t \<lhd> [(v, t)] = t"
    by (metis assoc.simps(2) subst.simps(1) subst_no_occs)

  fix s show "s \<lhd> [(v, t)] \<lozenge> [(v, t)] = s \<lhd> [(v, t)]"
    by (induct s) auto
qed

lemma Unifier_Idem_subst:
  "Idem(r) \<Longrightarrow> Unifier s (t \<lhd> r) (u \<lhd> r) \<Longrightarrow>
    Unifier (r \<lozenge> s) (t \<lhd> r) (u \<lhd> r)"
by (simp add: Idem_def Unifier_def subst_eq_def)

lemma Idem_comp:
  "Idem r \<Longrightarrow> Unifier s (t \<lhd> r) (u \<lhd> r) \<Longrightarrow>
      (!!q. Unifier q (t \<lhd> r) (u \<lhd> r) \<Longrightarrow> s \<lozenge> q \<doteq> q) \<Longrightarrow>
    Idem (r \<lozenge> s)"
  apply (frule Unifier_Idem_subst, blast)
  apply (force simp add: Idem_def subst_eq_def)
  done

theorem unify_gives_Idem:
  "unify M N  = Some \<sigma> \<Longrightarrow> Idem \<sigma>"
proof (induct M N arbitrary: \<sigma> rule: unify.induct)
  case (7 M M' N N' \<sigma>)

  then obtain \<theta>1 \<theta>2
    where "unify M N = Some \<theta>1"
    and \<theta>2: "unify (M' \<lhd> \<theta>1) (N' \<lhd> \<theta>1) = Some \<theta>2"
    and \<sigma>: "\<sigma> = \<theta>1 \<lozenge> \<theta>2"
    and "Idem \<theta>1"
    and "Idem \<theta>2"
    by (auto split: option.split_asm)

  from \<theta>2 have "Unifier \<theta>2 (M' \<lhd> \<theta>1) (N' \<lhd> \<theta>1)"
    by (rule unify_computes_MGU[THEN MGU_is_Unifier])

  with \<open>Idem \<theta>1\<close>
  show "Idem \<sigma>" unfolding \<sigma>
  proof (rule Idem_comp)
    fix \<sigma> assume "Unifier \<sigma> (M' \<lhd> \<theta>1) (N' \<lhd> \<theta>1)"
    with \<theta>2 obtain \<gamma> where \<sigma>: "\<sigma> \<doteq> \<theta>2 \<lozenge> \<gamma>"
      using unify_computes_MGU MGU_def by blast

    have "\<theta>2 \<lozenge> \<sigma> \<doteq> \<theta>2 \<lozenge> (\<theta>2 \<lozenge> \<gamma>)" by (rule subst_cong) (auto simp: \<sigma>)
    also have "... \<doteq> (\<theta>2 \<lozenge> \<theta>2) \<lozenge> \<gamma>" by (rule comp_assoc[symmetric])
    also have "... \<doteq> \<theta>2 \<lozenge> \<gamma>" by (rule subst_cong) (auto simp: \<open>Idem \<theta>2\<close>[unfolded Idem_def])
    also have "... \<doteq> \<sigma>" by (rule \<sigma>[symmetric])
    finally show "\<theta>2 \<lozenge> \<sigma> \<doteq> \<sigma>" .
  qed
qed (auto intro!: Var_Idem split: option.splits if_splits)

subsection \<open>Unification Returns Substitution With Minimal Domain And Range\<close>

definition range_vars where
  "range_vars \<sigma> = \<Union> {vars_of (Var x \<lhd> \<sigma>) |x. Var x \<lhd> \<sigma> \<noteq> Var x}"

lemma vars_of_subst_subset: "vars_of (N \<lhd> \<sigma>) \<subseteq> vars_of N \<union> range_vars \<sigma>"
proof (rule subsetI)
  fix x assume "x \<in> vars_of (N \<lhd> \<sigma>)"
  thus "x \<in> vars_of N \<union> range_vars \<sigma>"
  proof (induction N)
    case (Var y)
    thus ?case
      unfolding range_vars_def vars_of.simps by force
  next
    case (Const y)
    thus ?case
      by simp
  next
    case (Comb N1 N2)
    thus ?case
      by auto
  qed
qed

lemma range_vars_comp_subset: "range_vars (\<sigma>\<^sub>1 \<lozenge> \<sigma>\<^sub>2) \<subseteq> range_vars \<sigma>\<^sub>1 \<union> range_vars \<sigma>\<^sub>2"
proof (rule subsetI)
  fix x assume "x \<in> range_vars (\<sigma>\<^sub>1 \<lozenge> \<sigma>\<^sub>2)"
  then obtain x' where
    x'_\<sigma>\<^sub>1_\<sigma>\<^sub>2: "Var x' \<lhd> \<sigma>\<^sub>1 \<lhd> \<sigma>\<^sub>2 \<noteq> Var x'" and x_in: "x \<in> vars_of (Var x' \<lhd> \<sigma>\<^sub>1 \<lhd> \<sigma>\<^sub>2)"
    unfolding range_vars_def by auto

  show "x \<in> range_vars \<sigma>\<^sub>1 \<union> range_vars \<sigma>\<^sub>2"
  proof (cases "Var x' \<lhd> \<sigma>\<^sub>1 = Var x'")
    case True
    with x'_\<sigma>\<^sub>1_\<sigma>\<^sub>2 x_in show ?thesis
      unfolding range_vars_def by auto
  next
    case x'_\<sigma>\<^sub>1_neq: False
    show ?thesis
    proof (cases "Var x' \<lhd> \<sigma>\<^sub>1 \<lhd> \<sigma>\<^sub>2 = Var x' \<lhd> \<sigma>\<^sub>1")
      case True
      with x'_\<sigma>\<^sub>1_\<sigma>\<^sub>2 x_in x'_\<sigma>\<^sub>1_neq show ?thesis
        unfolding range_vars_def by auto
    next
      case False
      with x_in obtain y where "y \<in> vars_of (Var x' \<lhd> \<sigma>\<^sub>1)" and "x \<in> vars_of (Var y \<lhd> \<sigma>\<^sub>2)"
        by (smt (verit, best) UN_iff image_iff vars_of_subst_conv_Union)
      with x'_\<sigma>\<^sub>1_neq show ?thesis
        unfolding range_vars_def by force
    qed
  qed
qed

theorem unify_gives_minimal_range:
  "unify M N  = Some \<sigma> \<Longrightarrow> range_vars \<sigma> \<subseteq> vars_of M \<union> vars_of N"
proof (induct M N arbitrary: \<sigma> rule: unify.induct)
  case (1 c M N)
  thus ?case by simp
next
  case (2 M N c)
  thus ?case by simp
next
  case (3 c v)
  hence "\<sigma> = [(v, Const c)]"
    by simp
  thus ?case
    by (simp add: range_vars_def)
next
  case (4 M N v)
  hence "\<sigma> = [(v, M \<cdot> N)]"
    by (metis option.discI option.sel unify.simps(4))
  thus ?case
    by (auto simp: range_vars_def)
next
  case (5 v M)
  hence "\<sigma> = [(v, M)]"
    by (metis option.discI option.inject unify.simps(5))
  thus ?case
    by (auto simp: range_vars_def)
next
  case (6 c d)
  hence "\<sigma> = []"
    by (metis option.distinct(1) option.sel unify.simps(6))
  thus ?case
    by (simp add: range_vars_def)
next
  case (7 M N M' N')
  from "7.prems" obtain \<theta>\<^sub>1 \<theta>\<^sub>2 where
    "unify M M' = Some \<theta>\<^sub>1" and "unify (N \<lhd> \<theta>\<^sub>1) (N' \<lhd> \<theta>\<^sub>1) = Some \<theta>\<^sub>2" and "\<sigma> = \<theta>\<^sub>1 \<lozenge> \<theta>\<^sub>2"
    apply simp
    by (metis (no_types, lifting) option.case_eq_if option.collapse option.discI option.sel)

  from "7.hyps"(1) have range_\<theta>\<^sub>1: "range_vars \<theta>\<^sub>1 \<subseteq> vars_of M \<union> vars_of M'"
    using \<open>unify M M' = Some \<theta>\<^sub>1\<close> by simp

  from "7.hyps"(2) have "range_vars \<theta>\<^sub>2 \<subseteq> vars_of (N \<lhd> \<theta>\<^sub>1) \<union> vars_of (N' \<lhd> \<theta>\<^sub>1)"
    using \<open>unify M M' = Some \<theta>\<^sub>1\<close> \<open>unify (N \<lhd> \<theta>\<^sub>1) (N' \<lhd> \<theta>\<^sub>1) = Some \<theta>\<^sub>2\<close> by simp
  hence range_\<theta>\<^sub>2: "range_vars \<theta>\<^sub>2 \<subseteq> vars_of N \<union> vars_of N' \<union> range_vars \<theta>\<^sub>1"
    using vars_of_subst_subset[of _ \<theta>\<^sub>1] by auto

  have "range_vars \<sigma> = range_vars (\<theta>\<^sub>1 \<lozenge> \<theta>\<^sub>2)"
    unfolding \<open>\<sigma> = \<theta>\<^sub>1 \<lozenge> \<theta>\<^sub>2\<close> by simp
  also have "... \<subseteq> range_vars \<theta>\<^sub>1 \<union> range_vars \<theta>\<^sub>2"
    by (rule range_vars_comp_subset)
  also have "... \<subseteq> range_vars \<theta>\<^sub>1 \<union> vars_of N \<union> vars_of N'"
    using range_\<theta>\<^sub>2 by auto
  also have "... \<subseteq> vars_of M \<union> vars_of M' \<union> vars_of N \<union> vars_of N'"
    using range_\<theta>\<^sub>1 by auto
  finally show ?case
    by auto
qed

theorem unify_gives_minimal_domain:
  "unify M N  = Some \<sigma> \<Longrightarrow> fst ` set \<sigma> \<subseteq> vars_of M \<union> vars_of N"
proof (induct M N arbitrary: \<sigma> rule: unify.induct)
  case (1 c M N)
  thus ?case
    by simp
next
  case (2 M N c)
  thus ?case
    by simp
next
  case (3 c v)
  hence "\<sigma> = [(v, Const c)]"
    by simp
  thus ?case
    by (simp add: dom_def)
next
  case (4 M N v)
  hence "\<sigma> = [(v, M \<cdot> N)]"
    by (metis option.distinct(1) option.inject unify.simps(4))
  thus ?case
    by (simp add: dom_def)
next
  case (5 v M)
  hence "\<sigma> = [(v, M)]"
    by (metis option.distinct(1) option.inject unify.simps(5))
  thus ?case
    by (simp add: dom_def)
next
  case (6 c d)
  hence "\<sigma> = []"
    by (metis option.distinct(1) option.sel unify.simps(6))
  thus ?case
    by simp
next
  case (7 M N M' N')
  from "7.prems" obtain \<theta>\<^sub>1 \<theta>\<^sub>2 where
    "unify M M' = Some \<theta>\<^sub>1" and "unify (N \<lhd> \<theta>\<^sub>1) (N' \<lhd> \<theta>\<^sub>1) = Some \<theta>\<^sub>2" and "\<sigma> = \<theta>\<^sub>1 \<lozenge> \<theta>\<^sub>2"
    apply simp
    by (metis (no_types, lifting) option.case_eq_if option.collapse option.discI option.sel)

  from "7.hyps"(1) have dom_\<theta>\<^sub>1: "fst ` set \<theta>\<^sub>1 \<subseteq> vars_of M \<union> vars_of M'"
    using \<open>unify M M' = Some \<theta>\<^sub>1\<close> by simp

  from "7.hyps"(2) have "fst ` set \<theta>\<^sub>2 \<subseteq> vars_of (N \<lhd> \<theta>\<^sub>1) \<union> vars_of (N' \<lhd> \<theta>\<^sub>1)"
    using \<open>unify M M' = Some \<theta>\<^sub>1\<close> \<open>unify (N \<lhd> \<theta>\<^sub>1) (N' \<lhd> \<theta>\<^sub>1) = Some \<theta>\<^sub>2\<close> by simp
  hence dom_\<theta>\<^sub>2: "fst ` set \<theta>\<^sub>2 \<subseteq> vars_of N \<union> vars_of N' \<union> range_vars \<theta>\<^sub>1"
    using vars_of_subst_subset[of _ \<theta>\<^sub>1] by auto

  have "fst ` set \<sigma> = fst ` set (\<theta>\<^sub>1 \<lozenge> \<theta>\<^sub>2)"
    unfolding \<open>\<sigma> = \<theta>\<^sub>1 \<lozenge> \<theta>\<^sub>2\<close> by simp
  also have "... = fst ` set \<theta>\<^sub>1 \<union> fst ` set \<theta>\<^sub>2"
    by (auto simp: domain_comp)
  also have "... \<subseteq> vars_of M \<union> vars_of M' \<union> fst ` set \<theta>\<^sub>2"
    using dom_\<theta>\<^sub>1 by auto
  also have "... \<subseteq> vars_of M \<union> vars_of M' \<union> vars_of N \<union> vars_of N' \<union> range_vars \<theta>\<^sub>1"
    using dom_\<theta>\<^sub>2 by auto
  also have "... \<subseteq> vars_of M \<union> vars_of M' \<union> vars_of N \<union> vars_of N'"
    using unify_gives_minimal_range[OF \<open>unify M M' = Some \<theta>\<^sub>1\<close>] by auto
  finally show ?case
    by auto
qed

subsection \<open>Idempotent Most General Unifier\<close>

definition IMGU :: "'a subst \<Rightarrow> 'a trm \<Rightarrow> 'a trm \<Rightarrow> bool" where
  "IMGU \<mu> t u \<longleftrightarrow> Unifier \<mu> t u \<and> (\<forall>\<theta>. Unifier \<theta> t u \<longrightarrow> \<theta> \<doteq> \<mu> \<lozenge> \<theta>)"

lemma IMGU_iff_Idem_and_MGU: "IMGU \<mu> t u \<longleftrightarrow> Idem \<mu> \<and> MGU \<mu> t u"
  unfolding IMGU_def Idem_def MGU_def
  by (smt (verit, best) subst_comp subst_eq_def)

lemma unify_computes_IMGU:
  "unify M N = Some \<sigma> \<Longrightarrow> IMGU \<sigma> M N"
  by (simp add: IMGU_iff_Idem_and_MGU unify_computes_MGU unify_gives_Idem)

end


(*  Title:      ZF/Zorn.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section{*Zorn's Lemma*}

theory Zorn imports OrderArith AC Inductive_ZF begin

text{*Based upon the unpublished article ``Towards the Mechanization of the
Proofs of Some Classical Theorems of Set Theory,'' by Abrial and Laffitte.*}

definition
  Subset_rel :: "i=>i"  where
   "Subset_rel(A) == {z \<in> A*A . \<exists>x y. z=<x,y> & x<=y & x\<noteq>y}"

definition
  chain      :: "i=>i"  where
   "chain(A)      == {F \<in> Pow(A). \<forall>X\<in>F. \<forall>Y\<in>F. X<=Y | Y<=X}"

definition
  super      :: "[i,i]=>i"  where
   "super(A,c)    == {d \<in> chain(A). c<=d & c\<noteq>d}"

definition
  maxchain   :: "i=>i"  where
   "maxchain(A)   == {c \<in> chain(A). super(A,c)=0}"

definition
  increasing :: "i=>i"  where
    "increasing(A) == {f \<in> Pow(A)->Pow(A). \<forall>x. x<=A \<longrightarrow> x<=f`x}"

text{*Lemma for the inductive definition below*}
lemma Union_in_Pow: "Y \<in> Pow(Pow(A)) ==> \<Union>(Y) \<in> Pow(A)"
by blast

text{*We could make the inductive definition conditional on
    @{term "next \<in> increasing(S)"}
    but instead we make this a side-condition of an introduction rule.  Thus
    the induction rule lets us assume that condition!  Many inductive proofs
    are therefore unconditional.*}
consts
  "TFin" :: "[i,i]=>i"

inductive
  domains       "TFin(S,next)" \<subseteq> "Pow(S)"
  intros
    nextI:       "[| x \<in> TFin(S,next);  next \<in> increasing(S) |]
                  ==> next`x \<in> TFin(S,next)"

    Pow_UnionI: "Y \<in> Pow(TFin(S,next)) ==> \<Union>(Y) \<in> TFin(S,next)"

  monos         Pow_mono
  con_defs      increasing_def
  type_intros   CollectD1 [THEN apply_funtype] Union_in_Pow

subsection{*Mathematical Preamble *}

lemma Union_lemma0: "(\<forall>x\<in>C. x<=A | B<=x) ==> \<Union>(C)<=A | B<=\<Union>(C)"
by blast

lemma Inter_lemma0:
     "[| c \<in> C; \<forall>x\<in>C. A<=x | x<=B |] ==> A \<subseteq> \<Inter>(C) | \<Inter>(C) \<subseteq> B"
by blast

subsection{*The Transfinite Construction *}

lemma increasingD1: "f \<in> increasing(A) ==> f \<in> Pow(A)->Pow(A)"
apply (unfold increasing_def)
apply (erule CollectD1)
done

lemma increasingD2: "[| f \<in> increasing(A); x<=A |] ==> x \<subseteq> f`x"
by (unfold increasing_def, blast)

lemmas TFin_UnionI = PowI [THEN TFin.Pow_UnionI]

lemmas TFin_is_subset = TFin.dom_subset [THEN subsetD, THEN PowD]

text{*Structural induction on @{term "TFin(S,next)"} *}
lemma TFin_induct:
  "[| n \<in> TFin(S,next);
      !!x. [| x \<in> TFin(S,next);  P(x);  next \<in> increasing(S) |] ==> P(next`x);
      !!Y. [| Y \<subseteq> TFin(S,next);  \<forall>y\<in>Y. P(y) |] ==> P(\<Union>(Y))
   |] ==> P(n)"
by (erule TFin.induct, blast+)

subsection{*Some Properties of the Transfinite Construction *}

lemmas increasing_trans = subset_trans [OF _ increasingD2,
                                        OF _ _ TFin_is_subset]

text{*Lemma 1 of section 3.1*}
lemma TFin_linear_lemma1:
     "[| n \<in> TFin(S,next);  m \<in> TFin(S,next);
         \<forall>x \<in> TFin(S,next) . x<=m \<longrightarrow> x=m | next`x<=m |]
      ==> n<=m | next`m<=n"
apply (erule TFin_induct)
apply (erule_tac [2] Union_lemma0) (*or just Blast_tac*)
(*downgrade subsetI from intro! to intro*)
apply (blast dest: increasing_trans)
done

text{*Lemma 2 of section 3.2.  Interesting in its own right!
  Requires @{term "next \<in> increasing(S)"} in the second induction step.*}
lemma TFin_linear_lemma2:
    "[| m \<in> TFin(S,next);  next \<in> increasing(S) |]
     ==> \<forall>n \<in> TFin(S,next). n<=m \<longrightarrow> n=m | next`n \<subseteq> m"
apply (erule TFin_induct)
apply (rule impI [THEN ballI])
txt{*case split using @{text TFin_linear_lemma1}*}
apply (rule_tac n1 = n and m1 = x in TFin_linear_lemma1 [THEN disjE],
       assumption+)
apply (blast del: subsetI
             intro: increasing_trans subsetI, blast)
txt{*second induction step*}
apply (rule impI [THEN ballI])
apply (rule Union_lemma0 [THEN disjE])
apply (erule_tac [3] disjI2)
prefer 2 apply blast
apply (rule ballI)
apply (drule bspec, assumption)
apply (drule subsetD, assumption)
apply (rule_tac n1 = n and m1 = x in TFin_linear_lemma1 [THEN disjE],
       assumption+, blast)
apply (erule increasingD2 [THEN subset_trans, THEN disjI1])
apply (blast dest: TFin_is_subset)+
done

text{*a more convenient form for Lemma 2*}
lemma TFin_subsetD:
     "[| n<=m;  m \<in> TFin(S,next);  n \<in> TFin(S,next);  next \<in> increasing(S) |]
      ==> n=m | next`n \<subseteq> m"
by (blast dest: TFin_linear_lemma2 [rule_format])

text{*Consequences from section 3.3 -- Property 3.2, the ordering is total*}
lemma TFin_subset_linear:
     "[| m \<in> TFin(S,next);  n \<in> TFin(S,next);  next \<in> increasing(S) |]
      ==> n \<subseteq> m | m<=n"
apply (rule disjE)
apply (rule TFin_linear_lemma1 [OF _ _TFin_linear_lemma2])
apply (assumption+, erule disjI2)
apply (blast del: subsetI
             intro: subsetI increasingD2 [THEN subset_trans] TFin_is_subset)
done

text{*Lemma 3 of section 3.3*}
lemma equal_next_upper:
     "[| n \<in> TFin(S,next);  m \<in> TFin(S,next);  m = next`m |] ==> n \<subseteq> m"
apply (erule TFin_induct)
apply (drule TFin_subsetD)
apply (assumption+, force, blast)
done

text{*Property 3.3 of section 3.3*}
lemma equal_next_Union:
     "[| m \<in> TFin(S,next);  next \<in> increasing(S) |]
      ==> m = next`m <-> m = \<Union>(TFin(S,next))"
apply (rule iffI)
apply (rule Union_upper [THEN equalityI])
apply (rule_tac [2] equal_next_upper [THEN Union_least])
apply (assumption+)
apply (erule ssubst)
apply (rule increasingD2 [THEN equalityI], assumption)
apply (blast del: subsetI
             intro: subsetI TFin_UnionI TFin.nextI TFin_is_subset)+
done

subsection{*Hausdorff's Theorem: Every Set Contains a Maximal Chain*}

text{*NOTE: We assume the partial ordering is @{text "\<subseteq>"}, the subset
relation!*}

text{** Defining the "next" operation for Hausdorff's Theorem **}

lemma chain_subset_Pow: "chain(A) \<subseteq> Pow(A)"
apply (unfold chain_def)
apply (rule Collect_subset)
done

lemma super_subset_chain: "super(A,c) \<subseteq> chain(A)"
apply (unfold super_def)
apply (rule Collect_subset)
done

lemma maxchain_subset_chain: "maxchain(A) \<subseteq> chain(A)"
apply (unfold maxchain_def)
apply (rule Collect_subset)
done

lemma choice_super:
     "[| ch \<in> (\<Pi> X \<in> Pow(chain(S)) - {0}. X); X \<in> chain(S);  X \<notin> maxchain(S) |]
      ==> ch ` super(S,X) \<in> super(S,X)"
apply (erule apply_type)
apply (unfold super_def maxchain_def, blast)
done

lemma choice_not_equals:
     "[| ch \<in> (\<Pi> X \<in> Pow(chain(S)) - {0}. X); X \<in> chain(S);  X \<notin> maxchain(S) |]
      ==> ch ` super(S,X) \<noteq> X"
apply (rule notI)
apply (drule choice_super, assumption, assumption)
apply (simp add: super_def)
done

text{*This justifies Definition 4.4*}
lemma Hausdorff_next_exists:
     "ch \<in> (\<Pi> X \<in> Pow(chain(S))-{0}. X) ==>
      \<exists>next \<in> increasing(S). \<forall>X \<in> Pow(S).
                   next`X = if(X \<in> chain(S)-maxchain(S), ch`super(S,X), X)"
apply (rule_tac x="\<lambda>X\<in>Pow(S).
                   if X \<in> chain(S) - maxchain(S) then ch ` super(S, X) else X"
       in bexI)
apply force
apply (unfold increasing_def)
apply (rule CollectI)
apply (rule lam_type)
apply (simp (no_asm_simp))
apply (blast dest: super_subset_chain [THEN subsetD]
                   chain_subset_Pow [THEN subsetD] choice_super)
txt{*Now, verify that it increases*}
apply (simp (no_asm_simp) add: Pow_iff subset_refl)
apply safe
apply (drule choice_super)
apply (assumption+)
apply (simp add: super_def, blast)
done

text{*Lemma 4*}
lemma TFin_chain_lemma4:
     "[| c \<in> TFin(S,next);
         ch \<in> (\<Pi> X \<in> Pow(chain(S))-{0}. X);
         next \<in> increasing(S);
         \<forall>X \<in> Pow(S). next`X =
                          if(X \<in> chain(S)-maxchain(S), ch`super(S,X), X) |]
     ==> c \<in> chain(S)"
apply (erule TFin_induct)
apply (simp (no_asm_simp) add: chain_subset_Pow [THEN subsetD, THEN PowD]
            choice_super [THEN super_subset_chain [THEN subsetD]])
apply (unfold chain_def)
apply (rule CollectI, blast, safe)
apply (rule_tac m1=B and n1=Ba in TFin_subset_linear [THEN disjE], fast+)
      txt{*@{text "Blast_tac's"} slow*}
done

theorem Hausdorff: "\<exists>c. c \<in> maxchain(S)"
apply (rule AC_Pi_Pow [THEN exE])
apply (rule Hausdorff_next_exists [THEN bexE], assumption)
apply (rename_tac ch "next")
apply (subgoal_tac "\<Union>(TFin (S,next)) \<in> chain (S) ")
prefer 2
 apply (blast intro!: TFin_chain_lemma4 subset_refl [THEN TFin_UnionI])
apply (rule_tac x = "\<Union>(TFin (S,next))" in exI)
apply (rule classical)
apply (subgoal_tac "next ` Union(TFin (S,next)) = \<Union>(TFin (S,next))")
apply (rule_tac [2] equal_next_Union [THEN iffD2, symmetric])
apply (rule_tac [2] subset_refl [THEN TFin_UnionI])
prefer 2 apply assumption
apply (rule_tac [2] refl)
apply (simp add: subset_refl [THEN TFin_UnionI,
                              THEN TFin.dom_subset [THEN subsetD, THEN PowD]])
apply (erule choice_not_equals [THEN notE])
apply (assumption+)
done

subsection{*Zorn's Lemma: If All Chains in S Have Upper Bounds In S,
       then S contains a Maximal Element*}

text{*Used in the proof of Zorn's Lemma*}
lemma chain_extend:
    "[| c \<in> chain(A);  z \<in> A;  \<forall>x \<in> c. x<=z |] ==> cons(z,c) \<in> chain(A)"
by (unfold chain_def, blast)

lemma Zorn: "\<forall>c \<in> chain(S). \<Union>(c) \<in> S ==> \<exists>y \<in> S. \<forall>z \<in> S. y<=z \<longrightarrow> y=z"
apply (rule Hausdorff [THEN exE])
apply (simp add: maxchain_def)
apply (rename_tac c)
apply (rule_tac x = "\<Union>(c)" in bexI)
prefer 2 apply blast
apply safe
apply (rename_tac z)
apply (rule classical)
apply (subgoal_tac "cons (z,c) \<in> super (S,c) ")
apply (blast elim: equalityE)
apply (unfold super_def, safe)
apply (fast elim: chain_extend)
apply (fast elim: equalityE)
done

text {* Alternative version of Zorn's Lemma *}

theorem Zorn2:
  "\<forall>c \<in> chain(S). \<exists>y \<in> S. \<forall>x \<in> c. x \<subseteq> y ==> \<exists>y \<in> S. \<forall>z \<in> S. y<=z \<longrightarrow> y=z"
apply (cut_tac Hausdorff maxchain_subset_chain)
apply (erule exE)
apply (drule subsetD, assumption)
apply (drule bspec, assumption, erule bexE)
apply (rule_tac x = y in bexI)
  prefer 2 apply assumption
apply clarify
apply rule apply assumption
apply rule
apply (rule ccontr)
apply (frule_tac z=z in chain_extend)
  apply (assumption, blast)
apply (unfold maxchain_def super_def)
apply (blast elim!: equalityCE)
done

subsection{*Zermelo's Theorem: Every Set can be Well-Ordered*}

text{*Lemma 5*}
lemma TFin_well_lemma5:
     "[| n \<in> TFin(S,next);  Z \<subseteq> TFin(S,next);  z:Z;  ~ \<Inter>(Z) \<in> Z |]
      ==> \<forall>m \<in> Z. n \<subseteq> m"
apply (erule TFin_induct)
prefer 2 apply blast txt{*second induction step is easy*}
apply (rule ballI)
apply (rule bspec [THEN TFin_subsetD, THEN disjE], auto)
apply (subgoal_tac "m = \<Inter>(Z) ")
apply blast+
done

text{*Well-ordering of @{term "TFin(S,next)"} *}
lemma well_ord_TFin_lemma: "[| Z \<subseteq> TFin(S,next);  z \<in> Z |] ==> \<Inter>(Z) \<in> Z"
apply (rule classical)
apply (subgoal_tac "Z = {\<Union>(TFin (S,next))}")
apply (simp (no_asm_simp) add: Inter_singleton)
apply (erule equal_singleton)
apply (rule Union_upper [THEN equalityI])
apply (rule_tac [2] subset_refl [THEN TFin_UnionI, THEN TFin_well_lemma5, THEN bspec], blast+)
done

text{*This theorem just packages the previous result*}
lemma well_ord_TFin:
     "next \<in> increasing(S)
      ==> well_ord(TFin(S,next), Subset_rel(TFin(S,next)))"
apply (rule well_ordI)
apply (unfold Subset_rel_def linear_def)
txt{*Prove the well-foundedness goal*}
apply (rule wf_onI)
apply (frule well_ord_TFin_lemma, assumption)
apply (drule_tac x = "\<Inter>(Z) " in bspec, assumption)
apply blast
txt{*Now prove the linearity goal*}
apply (intro ballI)
apply (case_tac "x=y")
 apply blast
txt{*The @{term "x\<noteq>y"} case remains*}
apply (rule_tac n1=x and m1=y in TFin_subset_linear [THEN disjE],
       assumption+, blast+)
done

text{** Defining the "next" operation for Zermelo's Theorem **}

lemma choice_Diff:
     "[| ch \<in> (\<Pi> X \<in> Pow(S) - {0}. X);  X \<subseteq> S;  X\<noteq>S |] ==> ch ` (S-X) \<in> S-X"
apply (erule apply_type)
apply (blast elim!: equalityE)
done

text{*This justifies Definition 6.1*}
lemma Zermelo_next_exists:
     "ch \<in> (\<Pi> X \<in> Pow(S)-{0}. X) ==>
           \<exists>next \<in> increasing(S). \<forall>X \<in> Pow(S).
                      next`X = (if X=S then S else cons(ch`(S-X), X))"
apply (rule_tac x="\<lambda>X\<in>Pow(S). if X=S then S else cons(ch`(S-X), X)"
       in bexI)
apply force
apply (unfold increasing_def)
apply (rule CollectI)
apply (rule lam_type)
txt{*Type checking is surprisingly hard!*}
apply (simp (no_asm_simp) add: Pow_iff cons_subset_iff subset_refl)
apply (blast intro!: choice_Diff [THEN DiffD1])
txt{*Verify that it increases*}
apply (intro allI impI)
apply (simp add: Pow_iff subset_consI subset_refl)
done

text{*The construction of the injection*}
lemma choice_imp_injection:
     "[| ch \<in> (\<Pi> X \<in> Pow(S)-{0}. X);
         next \<in> increasing(S);
         \<forall>X \<in> Pow(S). next`X = if(X=S, S, cons(ch`(S-X), X)) |]
      ==> (\<lambda> x \<in> S. \<Union>({y \<in> TFin(S,next). x \<notin> y}))
               \<in> inj(S, TFin(S,next) - {S})"
apply (rule_tac d = "%y. ch` (S-y) " in lam_injective)
apply (rule DiffI)
apply (rule Collect_subset [THEN TFin_UnionI])
apply (blast intro!: Collect_subset [THEN TFin_UnionI] elim: equalityE)
apply (subgoal_tac "x \<notin> \<Union>({y \<in> TFin (S,next) . x \<notin> y}) ")
prefer 2 apply (blast elim: equalityE)
apply (subgoal_tac "\<Union>({y \<in> TFin (S,next) . x \<notin> y}) \<noteq> S")
prefer 2 apply (blast elim: equalityE)
txt{*For proving @{text "x \<in> next`\<Union>(...)"}.
  Abrial and Laffitte's justification appears to be faulty.*}
apply (subgoal_tac "~ next ` Union({y \<in> TFin (S,next) . x \<notin> y})
                    \<subseteq> \<Union>({y \<in> TFin (S,next) . x \<notin> y}) ")
 prefer 2
 apply (simp del: Union_iff
             add: Collect_subset [THEN TFin_UnionI, THEN TFin_is_subset]
             Pow_iff cons_subset_iff subset_refl choice_Diff [THEN DiffD2])
apply (subgoal_tac "x \<in> next ` Union({y \<in> TFin (S,next) . x \<notin> y}) ")
 prefer 2
 apply (blast intro!: Collect_subset [THEN TFin_UnionI] TFin.nextI)
txt{*End of the lemmas!*}
apply (simp add: Collect_subset [THEN TFin_UnionI, THEN TFin_is_subset])
done

text{*The wellordering theorem*}
theorem AC_well_ord: "\<exists>r. well_ord(S,r)"
apply (rule AC_Pi_Pow [THEN exE])
apply (rule Zermelo_next_exists [THEN bexE], assumption)
apply (rule exI)
apply (rule well_ord_rvimage)
apply (erule_tac [2] well_ord_TFin)
apply (rule choice_imp_injection [THEN inj_weaken_type], blast+)
done

subsection {* Zorn's Lemma for Partial Orders *}

text {* Reimported from HOL by Clemens Ballarin. *}

definition Chain :: "i => i" where
  "Chain(r) = {A \<in> Pow(field(r)). \<forall>a\<in>A. \<forall>b\<in>A. <a, b> \<in> r | <b, a> \<in> r}"

lemma mono_Chain:
  "r \<subseteq> s ==> Chain(r) \<subseteq> Chain(s)"
  unfolding Chain_def
  by blast

theorem Zorn_po:
  assumes po: "Partial_order(r)"
    and u: "\<forall>C\<in>Chain(r). \<exists>u\<in>field(r). \<forall>a\<in>C. <a, u> \<in> r"
  shows "\<exists>m\<in>field(r). \<forall>a\<in>field(r). <m, a> \<in> r \<longrightarrow> a = m"
proof -
  have "Preorder(r)" using po by (simp add: partial_order_on_def)
  --{* Mirror r in the set of subsets below (wrt r) elements of A (?). *}
  let ?B = "\<lambda>x\<in>field(r). r -`` {x}" let ?S = "?B `` field(r)"
  have "\<forall>C\<in>chain(?S). \<exists>U\<in>?S. \<forall>A\<in>C. A \<subseteq> U"
  proof (clarsimp simp: chain_def Subset_rel_def bex_image_simp)
    fix C
    assume 1: "C \<subseteq> ?S" and 2: "\<forall>A\<in>C. \<forall>B\<in>C. A \<subseteq> B | B \<subseteq> A"
    let ?A = "{x \<in> field(r). \<exists>M\<in>C. M = ?B`x}"
    have "C = ?B `` ?A" using 1
      apply (auto simp: image_def)
      apply rule
      apply rule
      apply (drule subsetD) apply assumption
      apply (erule CollectE)
      apply rule apply assumption
      apply (erule bexE)
      apply rule prefer 2 apply assumption
      apply rule
      apply (erule lamE) apply simp
      apply assumption

      apply (thin_tac "C \<subseteq> ?X")
      apply (fast elim: lamE)
      done
    have "?A \<in> Chain(r)"
    proof (simp add: Chain_def subsetI, intro conjI ballI impI)
      fix a b
      assume "a \<in> field(r)" "r -`` {a} \<in> C" "b \<in> field(r)" "r -`` {b} \<in> C"
      hence "r -`` {a} \<subseteq> r -`` {b} | r -`` {b} \<subseteq> r -`` {a}" using 2 by auto
      then show "<a, b> \<in> r | <b, a> \<in> r"
        using `Preorder(r)` `a \<in> field(r)` `b \<in> field(r)`
        by (simp add: subset_vimage1_vimage1_iff)
    qed
    then obtain u where uA: "u \<in> field(r)" "\<forall>a\<in>?A. <a, u> \<in> r"
      using u
      apply auto
      apply (drule bspec) apply assumption
      apply auto
      done
    have "\<forall>A\<in>C. A \<subseteq> r -`` {u}"
    proof (auto intro!: vimageI)
      fix a B
      assume aB: "B \<in> C" "a \<in> B"
      with 1 obtain x where "x \<in> field(r)" "B = r -`` {x}"
        apply -
        apply (drule subsetD) apply assumption
        apply (erule imageE)
        apply (erule lamE)
        apply simp
        done
      then show "<a, u> \<in> r" using uA aB `Preorder(r)`
        by (auto simp: preorder_on_def refl_def) (blast dest: trans_onD)+
    qed
    then show "\<exists>U\<in>field(r). \<forall>A\<in>C. A \<subseteq> r -`` {U}"
      using `u \<in> field(r)` ..
  qed
  from Zorn2 [OF this]
  obtain m B where "m \<in> field(r)" "B = r -`` {m}"
    "\<forall>x\<in>field(r). B \<subseteq> r -`` {x} \<longrightarrow> B = r -`` {x}"
    by (auto elim!: lamE simp: ball_image_simp)
  then have "\<forall>a\<in>field(r). <m, a> \<in> r \<longrightarrow> a = m"
    using po `Preorder(r)` `m \<in> field(r)`
    by (auto simp: subset_vimage1_vimage1_iff Partial_order_eq_vimage1_vimage1_iff)
  then show ?thesis using `m \<in> field(r)` by blast
qed

end