(* 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_sort_nat_QSortCount
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

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

fun lt :: "Nat => Nat => bool" where
  "lt y (Z) = False"
| "lt (Z) (S z2) = True"
| "lt (S n) (S z2) = lt n z2"

fun le :: "Nat => Nat => bool" where
  "le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun gt :: "Nat => Nat => bool" where
  "gt y z = lt z y"

fun filter :: "('a => bool) => 'a list => 'a list" where
  "filter q (nil2) = nil2"
| "filter q (cons2 z xs) =
     (if q z then cons2 z (filter q xs) else filter q xs)"

(*fun did not finish the proof*)
function qsort :: "Nat list => Nat list" where
  "qsort (nil2) = nil2"
| "qsort (cons2 z xs) =
     x (qsort (filter (% (z2 :: Nat) => le z2 z) xs))
       (x (cons2 z (nil2))
          (qsort (filter (% (x2 :: Nat) => gt x2 z) xs)))"
  by pat_completeness auto

fun count :: "'a => 'a list => Nat" where
  "count y (nil2) = Z"
| "count y (cons2 z2 ys) =
     (if (y = z2) then plus (S Z) (count y ys) else count y ys)"

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

end


(*  Title:      HOL/Proofs/Extraction/Higman.thy
    Author:     Stefan Berghofer, TU Muenchen
    Author:     Monika Seisenberger, LMU Muenchen
*)

section \<open>Higman's lemma\<close>

theory Higman
imports MainRLT
begin

text \<open>
  Formalization by Stefan Berghofer and Monika Seisenberger,
  based on Coquand and Fridlender @{cite Coquand93}.
\<close>

datatype letter = A | B

inductive emb :: "letter list \<Rightarrow> letter list \<Rightarrow> bool"
where
  emb0 [Pure.intro]: "emb [] bs"
| emb1 [Pure.intro]: "emb as bs \<Longrightarrow> emb as (b # bs)"
| emb2 [Pure.intro]: "emb as bs \<Longrightarrow> emb (a # as) (a # bs)"

inductive L :: "letter list \<Rightarrow> letter list list \<Rightarrow> bool"
  for v :: "letter list"
where
  L0 [Pure.intro]: "emb w v \<Longrightarrow> L v (w # ws)"
| L1 [Pure.intro]: "L v ws \<Longrightarrow> L v (w # ws)"

inductive good :: "letter list list \<Rightarrow> bool"
where
  good0 [Pure.intro]: "L w ws \<Longrightarrow> good (w # ws)"
| good1 [Pure.intro]: "good ws \<Longrightarrow> good (w # ws)"

inductive R :: "letter \<Rightarrow> letter list list \<Rightarrow> letter list list \<Rightarrow> bool"
  for a :: letter
where
  R0 [Pure.intro]: "R a [] []"
| R1 [Pure.intro]: "R a vs ws \<Longrightarrow> R a (w # vs) ((a # w) # ws)"

inductive T :: "letter \<Rightarrow> letter list list \<Rightarrow> letter list list \<Rightarrow> bool"
  for a :: letter
where
  T0 [Pure.intro]: "a \<noteq> b \<Longrightarrow> R b ws zs \<Longrightarrow> T a (w # zs) ((a # w) # zs)"
| T1 [Pure.intro]: "T a ws zs \<Longrightarrow> T a (w # ws) ((a # w) # zs)"
| T2 [Pure.intro]: "a \<noteq> b \<Longrightarrow> T a ws zs \<Longrightarrow> T a ws ((b # w) # zs)"

inductive bar :: "letter list list \<Rightarrow> bool"
where
  bar1 [Pure.intro]: "good ws \<Longrightarrow> bar ws"
| bar2 [Pure.intro]: "(\<And>w. bar (w # ws)) \<Longrightarrow> bar ws"

theorem prop1: "bar ([] # ws)"
  by iprover

theorem lemma1: "L as ws \<Longrightarrow> L (a # as) ws"
  by (erule L.induct) iprover+

lemma lemma2': "R a vs ws \<Longrightarrow> L as vs \<Longrightarrow> L (a # as) ws"
  supply [[simproc del: defined_all]]
  apply (induct set: R)
  apply (erule L.cases)
  apply simp+
  apply (erule L.cases)
  apply simp_all
  apply (rule L0)
  apply (erule emb2)
  apply (erule L1)
  done

lemma lemma2: "R a vs ws \<Longrightarrow> good vs \<Longrightarrow> good ws"
  supply [[simproc del: defined_all]]
  apply (induct set: R)
  apply iprover
  apply (erule good.cases)
  apply simp_all
  apply (rule good0)
  apply (erule lemma2')
   apply assumption
  apply (erule good1)
  done

lemma lemma3': "T a vs ws \<Longrightarrow> L as vs \<Longrightarrow> L (a # as) ws"
  supply [[simproc del: defined_all]]
  apply (induct set: T)
  apply (erule L.cases)
  apply simp_all
  apply (rule L0)
  apply (erule emb2)
  apply (rule L1)
  apply (erule lemma1)
  apply (erule L.cases)
  apply simp_all
  apply iprover+
  done

lemma lemma3: "T a ws zs \<Longrightarrow> good ws \<Longrightarrow> good zs"
  supply [[simproc del: defined_all]]
  apply (induct set: T)
  apply (erule good.cases)
  apply simp_all
  apply (rule good0)
  apply (erule lemma1)
  apply (erule good1)
  apply (erule good.cases)
  apply simp_all
  apply (rule good0)
  apply (erule lemma3')
  apply iprover+
  done

lemma lemma4: "R a ws zs \<Longrightarrow> ws \<noteq> [] \<Longrightarrow> T a ws zs"
  supply [[simproc del: defined_all]]
  apply (induct set: R)
  apply iprover
  apply (case_tac vs)
  apply (erule R.cases)
  apply simp
  apply (case_tac a)
  apply (rule_tac b=B in T0)
  apply simp
  apply (rule R0)
  apply (rule_tac b=A in T0)
  apply simp
  apply (rule R0)
  apply simp
  apply (rule T1)
  apply simp
  done

lemma letter_neq: "a \<noteq> b \<Longrightarrow> c \<noteq> a \<Longrightarrow> c = b" for a b c :: letter
  apply (case_tac a)
  apply (case_tac b)
  apply (case_tac c, simp, simp)
  apply (case_tac c, simp, simp)
  apply (case_tac b)
  apply (case_tac c, simp, simp)
  apply (case_tac c, simp, simp)
  done

lemma letter_eq_dec: "a = b \<or> a \<noteq> b" for a b :: letter
  apply (case_tac a)
  apply (case_tac b)
  apply simp
  apply simp
  apply (case_tac b)
  apply simp
  apply simp
  done

theorem prop2:
  assumes ab: "a \<noteq> b" and bar: "bar xs"
  shows "\<And>ys zs. bar ys \<Longrightarrow> T a xs zs \<Longrightarrow> T b ys zs \<Longrightarrow> bar zs"
  using bar
proof induct
  fix xs zs
  assume "T a xs zs" and "good xs"
  then have "good zs" by (rule lemma3)
  then show "bar zs" by (rule bar1)
next
  fix xs ys
  assume I: "\<And>w ys zs. bar ys \<Longrightarrow> T a (w # xs) zs \<Longrightarrow> T b ys zs \<Longrightarrow> bar zs"
  assume "bar ys"
  then show "\<And>zs. T a xs zs \<Longrightarrow> T b ys zs \<Longrightarrow> bar zs"
  proof induct
    fix ys zs
    assume "T b ys zs" and "good ys"
    then have "good zs" by (rule lemma3)
    then show "bar zs" by (rule bar1)
  next
    fix ys zs
    assume I': "\<And>w zs. T a xs zs \<Longrightarrow> T b (w # ys) zs \<Longrightarrow> bar zs"
      and ys: "\<And>w. bar (w # ys)" and Ta: "T a xs zs" and Tb: "T b ys zs"
    show "bar zs"
    proof (rule bar2)
      fix w
      show "bar (w # zs)"
      proof (cases w)
        case Nil
        then show ?thesis by simp (rule prop1)
      next
        case (Cons c cs)
        from letter_eq_dec show ?thesis
        proof
          assume ca: "c = a"
          from ab have "bar ((a # cs) # zs)" by (iprover intro: I ys Ta Tb)
          then show ?thesis by (simp add: Cons ca)
        next
          assume "c \<noteq> a"
          with ab have cb: "c = b" by (rule letter_neq)
          from ab have "bar ((b # cs) # zs)" by (iprover intro: I' Ta Tb)
          then show ?thesis by (simp add: Cons cb)
        qed
      qed
    qed
  qed
qed

theorem prop3:
  assumes bar: "bar xs"
  shows "\<And>zs. xs \<noteq> [] \<Longrightarrow> R a xs zs \<Longrightarrow> bar zs"
  using bar
proof induct
  fix xs zs
  assume "R a xs zs" and "good xs"
  then have "good zs" by (rule lemma2)
  then show "bar zs" by (rule bar1)
next
  fix xs zs
  assume I: "\<And>w zs. w # xs \<noteq> [] \<Longrightarrow> R a (w # xs) zs \<Longrightarrow> bar zs"
    and xsb: "\<And>w. bar (w # xs)" and xsn: "xs \<noteq> []" and R: "R a xs zs"
  show "bar zs"
  proof (rule bar2)
    fix w
    show "bar (w # zs)"
    proof (induct w)
      case Nil
      show ?case by (rule prop1)
    next
      case (Cons c cs)
      from letter_eq_dec show ?case
      proof
        assume "c = a"
        then show ?thesis by (iprover intro: I [simplified] R)
      next
        from R xsn have T: "T a xs zs" by (rule lemma4)
        assume "c \<noteq> a"
        then show ?thesis by (iprover intro: prop2 Cons xsb xsn R T)
      qed
    qed
  qed
qed

theorem higman: "bar []"
proof (rule bar2)
  fix w
  show "bar [w]"
  proof (induct w)
    show "bar [[]]" by (rule prop1)
  next
    fix c cs assume "bar [cs]"
    then show "bar [c # cs]" by (rule prop3) (simp, iprover)
  qed
qed

primrec is_prefix :: "'a list \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool"
where
  "is_prefix [] f = True"
| "is_prefix (x # xs) f = (x = f (length xs) \<and> is_prefix xs f)"

theorem L_idx:
  assumes L: "L w ws"
  shows "is_prefix ws f \<Longrightarrow> \<exists>i. emb (f i) w \<and> i < length ws"
  using L
proof induct
  case (L0 v ws)
  then have "emb (f (length ws)) w" by simp
  moreover have "length ws < length (v # ws)" by simp
  ultimately show ?case by iprover
next
  case (L1 ws v)
  then obtain i where emb: "emb (f i) w" and "i < length ws"
    by simp iprover
  then have "i < length (v # ws)" by simp
  with emb show ?case by iprover
qed

theorem good_idx:
  assumes good: "good ws"
  shows "is_prefix ws f \<Longrightarrow> \<exists>i j. emb (f i) (f j) \<and> i < j"
  using good
proof induct
  case (good0 w ws)
  then have "w = f (length ws)" and "is_prefix ws f" by simp_all
  with good0 show ?case by (iprover dest: L_idx)
next
  case (good1 ws w)
  then show ?case by simp
qed

theorem bar_idx:
  assumes bar: "bar ws"
  shows "is_prefix ws f \<Longrightarrow> \<exists>i j. emb (f i) (f j) \<and> i < j"
  using bar
proof induct
  case (bar1 ws)
  then show ?case by (rule good_idx)
next
  case (bar2 ws)
  then have "is_prefix (f (length ws) # ws) f" by simp
  then show ?case by (rule bar2)
qed

text \<open>
  Strong version: yields indices of words that can be embedded into each other.
\<close>

theorem higman_idx: "\<exists>(i::nat) j. emb (f i) (f j) \<and> i < j"
proof (rule bar_idx)
  show "bar []" by (rule higman)
  show "is_prefix [] f" by simp
qed

text \<open>
  Weak version: only yield sequence containing words
  that can be embedded into each other.
\<close>

theorem good_prefix_lemma:
  assumes bar: "bar ws"
  shows "is_prefix ws f \<Longrightarrow> \<exists>vs. is_prefix vs f \<and> good vs"
  using bar
proof induct
  case bar1
  then show ?case by iprover
next
  case (bar2 ws)
  from bar2.prems have "is_prefix (f (length ws) # ws) f" by simp
  then show ?case by (iprover intro: bar2)
qed

theorem good_prefix: "\<exists>vs. is_prefix vs f \<and> good vs"
  using higman
  by (rule good_prefix_lemma) simp+

end


(* Author: Tobias Nipkow *)

subsection "Computable State"

theory Abs_State
imports Abs_Int0
begin

type_synonym 'a st_rep = "(vname * 'a) list"

fun fun_rep :: "('a::top) st_rep \<Rightarrow> vname \<Rightarrow> 'a" where
"fun_rep [] = (\<lambda>x. \<top>)" |
"fun_rep ((x,a)#ps) = (fun_rep ps) (x := a)"

lemma fun_rep_map_of[code]: \<comment> \<open>original def is too slow\<close>
  "fun_rep ps = (%x. case map_of ps x of None \<Rightarrow> \<top> | Some a \<Rightarrow> a)"
by(induction ps rule: fun_rep.induct) auto

definition eq_st :: "('a::top) st_rep \<Rightarrow> 'a st_rep \<Rightarrow> bool" where
"eq_st S1 S2 = (fun_rep S1 = fun_rep S2)"

hide_type st  \<comment> \<open>hide previous def to avoid long names\<close>
declare [[typedef_overloaded]] \<comment> \<open>allow quotient types to depend on classes\<close>

quotient_type 'a st = "('a::top) st_rep" / eq_st
morphisms rep_st St
by (metis eq_st_def equivpI reflpI sympI transpI)

lift_definition update :: "('a::top) st \<Rightarrow> vname \<Rightarrow> 'a \<Rightarrow> 'a st"
  is "\<lambda>ps x a. (x,a)#ps"
by(auto simp: eq_st_def)

lift_definition "fun" :: "('a::top) st \<Rightarrow> vname \<Rightarrow> 'a" is fun_rep
by(simp add: eq_st_def)

definition show_st :: "vname set \<Rightarrow> ('a::top) st \<Rightarrow> (vname * 'a)set" where
"show_st X S = (\<lambda>x. (x, fun S x)) ` X"

definition "show_acom C = map_acom (map_option (show_st (vars(strip C)))) C"
definition "show_acom_opt = map_option show_acom"

lemma fun_update[simp]: "fun (update S x y) = (fun S)(x:=y)"
by transfer auto

definition \<gamma>_st :: "(('a::top) \<Rightarrow> 'b set) \<Rightarrow> 'a st \<Rightarrow> (vname \<Rightarrow> 'b) set" where
"\<gamma>_st \<gamma> F = {f. \<forall>x. f x \<in> \<gamma>(fun F x)}"

instantiation st :: (order_top) order
begin

definition less_eq_st_rep :: "'a st_rep \<Rightarrow> 'a st_rep \<Rightarrow> bool" where
"less_eq_st_rep ps1 ps2 =
  ((\<forall>x \<in> set(map fst ps1) \<union> set(map fst ps2). fun_rep ps1 x \<le> fun_rep ps2 x))"

lemma less_eq_st_rep_iff:
  "less_eq_st_rep r1 r2 = (\<forall>x. fun_rep r1 x \<le> fun_rep r2 x)"
apply(auto simp: less_eq_st_rep_def fun_rep_map_of split: option.split)
apply (metis Un_iff map_of_eq_None_iff option.distinct(1))
apply (metis Un_iff map_of_eq_None_iff option.distinct(1))
done

corollary less_eq_st_rep_iff_fun:
  "less_eq_st_rep r1 r2 = (fun_rep r1 \<le> fun_rep r2)"
by (metis less_eq_st_rep_iff le_fun_def)

lift_definition less_eq_st :: "'a st \<Rightarrow> 'a st \<Rightarrow> bool" is less_eq_st_rep
by(auto simp add: eq_st_def less_eq_st_rep_iff)

definition less_st where "F < (G::'a st) = (F \<le> G \<and> \<not> G \<le> F)"

instance
proof (standard, goal_cases)
  case 1 show ?case by(rule less_st_def)
next
  case 2 show ?case by transfer (auto simp: less_eq_st_rep_def)
next
  case 3 thus ?case by transfer (metis less_eq_st_rep_iff order_trans)
next
  case 4 thus ?case
    by transfer (metis less_eq_st_rep_iff eq_st_def fun_eq_iff antisym)
qed

end

lemma le_st_iff: "(F \<le> G) = (\<forall>x. fun F x \<le> fun G x)"
by transfer (rule less_eq_st_rep_iff)

fun map2_st_rep :: "('a::top \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a st_rep \<Rightarrow> 'a st_rep \<Rightarrow> 'a st_rep" where
"map2_st_rep f [] ps2 = map (%(x,y). (x, f \<top> y)) ps2" |
"map2_st_rep f ((x,y)#ps1) ps2 =
  (let y2 = fun_rep ps2 x
   in (x,f y y2) # map2_st_rep f ps1 ps2)"

lemma fun_rep_map2_rep[simp]: "f \<top> \<top> = \<top> \<Longrightarrow>
  fun_rep (map2_st_rep f ps1 ps2) = (\<lambda>x. f (fun_rep ps1 x) (fun_rep ps2 x))"
apply(induction f ps1 ps2 rule: map2_st_rep.induct)
apply(simp add: fun_rep_map_of map_of_map fun_eq_iff split: option.split)
apply(fastforce simp: fun_rep_map_of fun_eq_iff split:option.splits)
done

instantiation st :: (semilattice_sup_top) semilattice_sup_top
begin

lift_definition sup_st :: "'a st \<Rightarrow> 'a st \<Rightarrow> 'a st" is "map2_st_rep (\<squnion>)"
by (simp add: eq_st_def)

lift_definition top_st :: "'a st" is "[]" .

instance
proof (standard, goal_cases)
  case 1 show ?case by transfer (simp add:less_eq_st_rep_iff)
next
  case 2 show ?case by transfer (simp add:less_eq_st_rep_iff)
next
  case 3 thus ?case by transfer (simp add:less_eq_st_rep_iff)
next
  case 4 show ?case by transfer (simp add:less_eq_st_rep_iff fun_rep_map_of)
qed

end

lemma fun_top: "fun \<top> = (\<lambda>x. \<top>)"
by transfer simp

lemma mono_update[simp]:
  "a1 \<le> a2 \<Longrightarrow> S1 \<le> S2 \<Longrightarrow> update S1 x a1 \<le> update S2 x a2"
by transfer (auto simp add: less_eq_st_rep_def)

lemma mono_fun: "S1 \<le> S2 \<Longrightarrow> fun S1 x \<le> fun S2 x"
by transfer (simp add: less_eq_st_rep_iff)

locale Gamma_semilattice = Val_semilattice where \<gamma>=\<gamma>
  for \<gamma> :: "'av::semilattice_sup_top \<Rightarrow> val set"
begin

abbreviation \<gamma>\<^sub>s :: "'av st \<Rightarrow> state set"
where "\<gamma>\<^sub>s == \<gamma>_st \<gamma>"

abbreviation \<gamma>\<^sub>o :: "'av st option \<Rightarrow> state set"
where "\<gamma>\<^sub>o == \<gamma>_option \<gamma>\<^sub>s"

abbreviation \<gamma>\<^sub>c :: "'av st option acom \<Rightarrow> state set acom"
where "\<gamma>\<^sub>c == map_acom \<gamma>\<^sub>o"

lemma gamma_s_top[simp]: "\<gamma>\<^sub>s \<top> = UNIV"
by(auto simp: \<gamma>_st_def fun_top)

lemma gamma_o_Top[simp]: "\<gamma>\<^sub>o \<top> = UNIV"
by (simp add: top_option_def)

lemma mono_gamma_s: "f \<le> g \<Longrightarrow> \<gamma>\<^sub>s f \<subseteq> \<gamma>\<^sub>s g"
by(simp add:\<gamma>_st_def le_st_iff subset_iff) (metis mono_gamma subsetD)

lemma mono_gamma_o:
  "S1 \<le> S2 \<Longrightarrow> \<gamma>\<^sub>o S1 \<subseteq> \<gamma>\<^sub>o S2"
by(induction S1 S2 rule: less_eq_option.induct)(simp_all add: mono_gamma_s)

lemma mono_gamma_c: "C1 \<le> C2 \<Longrightarrow> \<gamma>\<^sub>c C1 \<le> \<gamma>\<^sub>c C2"
by (simp add: less_eq_acom_def mono_gamma_o size_annos anno_map_acom size_annos_same[of C1 C2])

lemma in_gamma_option_iff:
  "x \<in> \<gamma>_option r u \<longleftrightarrow> (\<exists>u'. u = Some u' \<and> x \<in> r u')"
by (cases u) auto

end

end


(*  Title:      HOL/Cardinals/Wellorder_Relation.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Well-order relations.
*)

section {* Well-Order Relations *}

theory Wellorder_Relation
imports BNF_Wellorder_Relation Wellfounded_More
begin

context wo_rel
begin

subsection {* Auxiliaries *}

lemma PREORD: "Preorder r"
using WELL order_on_defs[of _ r] by auto

lemma PARORD: "Partial_order r"
using WELL order_on_defs[of _ r] by auto

lemma cases_Total2:
"\<And> phi a b. \<lbrakk>{a,b} \<le> Field r; ((a,b) \<in> r - Id \<Longrightarrow> phi a b);
              ((b,a) \<in> r - Id \<Longrightarrow> phi a b); (a = b \<Longrightarrow> phi a b)\<rbrakk>
             \<Longrightarrow> phi a b"
using TOTALS by auto

subsection {* Well-founded induction and recursion adapted to non-strict well-order relations *}

lemma worec_unique_fixpoint:
assumes ADM: "adm_wo H" and fp: "f = H f"
shows "f = worec H"
proof-
  have "adm_wf (r - Id) H"
  unfolding adm_wf_def
  using ADM adm_wo_def[of H] underS_def[of r] by auto
  hence "f = wfrec (r - Id) H"
  using fp WF wfrec_unique_fixpoint[of "r - Id" H] by simp
  thus ?thesis unfolding worec_def .
qed

subsubsection {* Properties of max2 *}

lemma max2_iff:
assumes "a \<in> Field r" and "b \<in> Field r"
shows "((max2 a b, c) \<in> r) = ((a,c) \<in> r \<and> (b,c) \<in> r)"
proof
  assume "(max2 a b, c) \<in> r"
  thus "(a,c) \<in> r \<and> (b,c) \<in> r"
  using assms max2_greater[of a b] TRANS trans_def[of r] by blast
next
  assume "(a,c) \<in> r \<and> (b,c) \<in> r"
  thus "(max2 a b, c) \<in> r"
  using assms max2_among[of a b] by auto
qed

subsubsection {* Properties of minim *}

lemma minim_Under:
"\<lbrakk>B \<le> Field r; B \<noteq> {}\<rbrakk> \<Longrightarrow> minim B \<in> Under B"
by(auto simp add: Under_def minim_inField minim_least)

lemma equals_minim_Under:
"\<lbrakk>B \<le> Field r; a \<in> B; a \<in> Under B\<rbrakk>
 \<Longrightarrow> a = minim B"
by(auto simp add: Under_def equals_minim)

lemma minim_iff_In_Under:
assumes SUB: "B \<le> Field r" and NE: "B \<noteq> {}"
shows "(a = minim B) = (a \<in> B \<and> a \<in> Under B)"
proof
  assume "a = minim B"
  thus "a \<in> B \<and> a \<in> Under B"
  using assms minim_in minim_Under by simp
next
  assume "a \<in> B \<and> a \<in> Under B"
  thus "a = minim B"
  using assms equals_minim_Under by simp
qed

lemma minim_Under_under:
assumes NE: "A \<noteq> {}" and SUB: "A \<le> Field r"
shows "Under A = under (minim A)"
proof-
  (* Preliminary facts *)
  have 1: "minim A \<in> A"
  using assms minim_in by auto
  have 2: "\<forall>x \<in> A. (minim A, x) \<in> r"
  using assms minim_least by auto
  (* Main proof *)
  have "Under A \<le> under (minim A)"
  proof
    fix x assume "x \<in> Under A"
    with 1 Under_def[of r] have "(x,minim A) \<in> r" by auto
    thus "x \<in> under(minim A)" unfolding under_def by simp
  qed
  (*  *)
  moreover
  (*  *)
  have "under (minim A) \<le> Under A"
  proof
    fix x assume "x \<in> under(minim A)"
    hence 11: "(x,minim A) \<in> r" unfolding under_def by simp
    hence "x \<in> Field r" unfolding Field_def by auto
    moreover
    {fix a assume "a \<in> A"
     with 2 have "(minim A, a) \<in> r" by simp
     with 11 have "(x,a) \<in> r"
     using TRANS trans_def[of r] by blast
    }
    ultimately show "x \<in> Under A" by (unfold Under_def, auto)
  qed
  (*  *)
  ultimately show ?thesis by blast
qed

lemma minim_UnderS_underS:
assumes NE: "A \<noteq> {}" and SUB: "A \<le> Field r"
shows "UnderS A = underS (minim A)"
proof-
  (* Preliminary facts *)
  have 1: "minim A \<in> A"
  using assms minim_in by auto
  have 2: "\<forall>x \<in> A. (minim A, x) \<in> r"
  using assms minim_least by auto
  (* Main proof *)
  have "UnderS A \<le> underS (minim A)"
  proof
    fix x assume "x \<in> UnderS A"
    with 1 UnderS_def[of r] have "x \<noteq> minim A \<and> (x,minim A) \<in> r" by auto
    thus "x \<in> underS(minim A)" unfolding underS_def by simp
  qed
  (*  *)
  moreover
  (*  *)
  have "underS (minim A) \<le> UnderS A"
  proof
    fix x assume "x \<in> underS(minim A)"
    hence 11: "x \<noteq> minim A \<and> (x,minim A) \<in> r" unfolding underS_def by simp
    hence "x \<in> Field r" unfolding Field_def by auto
    moreover
    {fix a assume "a \<in> A"
     with 2 have 3: "(minim A, a) \<in> r" by simp
     with 11 have "(x,a) \<in> r"
     using TRANS trans_def[of r] by blast
     moreover
     have "x \<noteq> a"
     proof
       assume "x = a"
       with 11 3 ANTISYM antisym_def[of r]
       show False by auto
     qed
     ultimately
     have "x \<noteq> a \<and> (x,a) \<in> r" by simp
    }
    ultimately show "x \<in> UnderS A" by (unfold UnderS_def, auto)
  qed
  (*  *)
  ultimately show ?thesis by blast
qed

subsubsection {* Properties of supr *}

lemma supr_Above:
assumes SUB: "B \<le> Field r" and ABOVE: "Above B \<noteq> {}"
shows "supr B \<in> Above B"
proof(unfold supr_def)
  have "Above B \<le> Field r"
  using Above_Field[of r] by auto
  thus "minim (Above B) \<in> Above B"
  using assms by (simp add: minim_in)
qed

lemma supr_greater:
assumes SUB: "B \<le> Field r" and ABOVE: "Above B \<noteq> {}" and
        IN: "b \<in> B"
shows "(b, supr B) \<in> r"
proof-
  from assms supr_Above
  have "supr B \<in> Above B" by simp
  with IN Above_def[of r] show ?thesis by simp
qed

lemma supr_least_Above:
assumes SUB: "B \<le> Field r" and
        ABOVE: "a \<in> Above B"
shows "(supr B, a) \<in> r"
proof(unfold supr_def)
  have "Above B \<le> Field r"
  using Above_Field[of r] by auto
  thus "(minim (Above B), a) \<in> r"
  using assms minim_least
  by simp
qed

lemma supr_least:
"\<lbrakk>B \<le> Field r; a \<in> Field r; (\<And> b. b \<in> B \<Longrightarrow> (b,a) \<in> r)\<rbrakk>
 \<Longrightarrow> (supr B, a) \<in> r"
by(auto simp add: supr_least_Above Above_def)

lemma equals_supr_Above:
assumes SUB: "B \<le> Field r" and ABV: "a \<in> Above B" and
        MINIM: "\<And> a'. a' \<in> Above B \<Longrightarrow> (a,a') \<in> r"
shows "a = supr B"
proof(unfold supr_def)
  have "Above B \<le> Field r"
  using Above_Field[of r] by auto
  thus "a = minim (Above B)"
  using assms equals_minim by simp
qed

lemma equals_supr:
assumes SUB: "B \<le> Field r" and IN: "a \<in> Field r" and
        ABV: "\<And> b. b \<in> B \<Longrightarrow> (b,a) \<in> r" and
        MINIM: "\<And> a'. \<lbrakk> a' \<in> Field r; \<And> b. b \<in> B \<Longrightarrow> (b,a') \<in> r\<rbrakk> \<Longrightarrow> (a,a') \<in> r"
shows "a = supr B"
proof-
  have "a \<in> Above B"
  unfolding Above_def using ABV IN by simp
  moreover
  have "\<And> a'. a' \<in> Above B \<Longrightarrow> (a,a') \<in> r"
  unfolding Above_def using MINIM by simp
  ultimately show ?thesis
  using equals_supr_Above SUB by auto
qed

lemma supr_inField:
assumes "B \<le> Field r" and  "Above B \<noteq> {}"
shows "supr B \<in> Field r"
proof-
  have "supr B \<in> Above B" using supr_Above assms by simp
  thus ?thesis using assms Above_Field[of r] by auto
qed

lemma supr_above_Above:
assumes SUB: "B \<le> Field r" and  ABOVE: "Above B \<noteq> {}"
shows "Above B = above (supr B)"
proof(unfold Above_def above_def, auto)
  fix a assume "a \<in> Field r" "\<forall>b \<in> B. (b,a) \<in> r"
  with supr_least assms
  show "(supr B, a) \<in> r" by auto
next
  fix b assume "(supr B, b) \<in> r"
  thus "b \<in> Field r"
  using REFL refl_on_def[of _ r] by auto
next
  fix a b
  assume 1: "(supr B, b) \<in> r" and 2: "a \<in> B"
  with assms supr_greater
  have "(a,supr B) \<in> r" by auto
  thus "(a,b) \<in> r"
  using 1 TRANS trans_def[of r] by blast
qed

lemma supr_under:
assumes IN: "a \<in> Field r"
shows "a = supr (under a)"
proof-
  have "under a \<le> Field r"
  using under_Field[of r] by auto
  moreover
  have "under a \<noteq> {}"
  using IN Refl_under_in[of r] REFL by auto
  moreover
  have "a \<in> Above (under a)"
  using in_Above_under[of _ r] IN by auto
  moreover
  have "\<forall>a' \<in> Above (under a). (a,a') \<in> r"
  proof(unfold Above_def under_def, auto)
    fix a'
    assume "\<forall>aa. (aa, a) \<in> r \<longrightarrow> (aa, a') \<in> r"
    hence "(a,a) \<in> r \<longrightarrow> (a,a') \<in> r" by blast
    moreover have "(a,a) \<in> r"
    using REFL IN by (auto simp add: refl_on_def)
    ultimately
    show  "(a, a') \<in> r" by (rule mp)
  qed
  ultimately show ?thesis
  using equals_supr_Above by auto
qed

subsubsection {* Properties of successor *}

lemma suc_least:
"\<lbrakk>B \<le> Field r; a \<in> Field r; (\<And> b. b \<in> B \<Longrightarrow> a \<noteq> b \<and> (b,a) \<in> r)\<rbrakk>
 \<Longrightarrow> (suc B, a) \<in> r"
by(auto simp add: suc_least_AboveS AboveS_def)

lemma equals_suc:
assumes SUB: "B \<le> Field r" and IN: "a \<in> Field r" and
 ABVS: "\<And> b. b \<in> B \<Longrightarrow> a \<noteq> b \<and> (b,a) \<in> r" and
 MINIM: "\<And> a'. \<lbrakk>a' \<in> Field r; \<And> b. b \<in> B \<Longrightarrow> a' \<noteq> b \<and> (b,a') \<in> r\<rbrakk> \<Longrightarrow> (a,a') \<in> r"
shows "a = suc B"
proof-
  have "a \<in> AboveS B"
  unfolding AboveS_def using ABVS IN by simp
  moreover
  have "\<And> a'. a' \<in> AboveS B \<Longrightarrow> (a,a') \<in> r"
  unfolding AboveS_def using MINIM by simp
  ultimately show ?thesis
  using equals_suc_AboveS SUB by auto
qed

lemma suc_above_AboveS:
assumes SUB: "B \<le> Field r" and
        ABOVE: "AboveS B \<noteq> {}"
shows "AboveS B = above (suc B)"
proof(unfold AboveS_def above_def, auto)
  fix a assume "a \<in> Field r" "\<forall>b \<in> B. a \<noteq> b \<and> (b,a) \<in> r"
  with suc_least assms
  show "(suc B,a) \<in> r" by auto
next
  fix b assume "(suc B, b) \<in> r"
  thus "b \<in> Field r"
  using REFL refl_on_def[of _ r] by auto
next
  fix a b
  assume 1: "(suc B, b) \<in> r" and 2: "a \<in> B"
  with assms suc_greater[of B a]
  have "(a,suc B) \<in> r" by auto
  thus "(a,b) \<in> r"
  using 1 TRANS trans_def[of r] by blast
next
  fix a
  assume 1: "(suc B, a) \<in> r" and 2: "a \<in> B"
  with assms suc_greater[of B a]
  have "(a,suc B) \<in> r" by auto
  moreover have "suc B \<in> Field r"
  using assms suc_inField by simp
  ultimately have "a = suc B"
  using 1 2 SUB ANTISYM antisym_def[of r] by auto
  thus False
  using assms suc_greater[of B a] 2 by auto
qed

lemma suc_singl_pred:
assumes IN: "a \<in> Field r" and ABOVE_NE: "aboveS a \<noteq> {}" and
        REL: "(a',suc {a}) \<in> r" and DIFF: "a' \<noteq> suc {a}"
shows "a' = a \<or> (a',a) \<in> r"
proof-
  have *: "suc {a} \<in> Field r \<and> a' \<in> Field r"
  using WELL REL well_order_on_domain by metis
  {assume **: "a' \<noteq> a"
   hence "(a,a') \<in> r \<or> (a',a) \<in> r"
   using TOTAL IN * by (auto simp add: total_on_def)
   moreover
   {assume "(a,a') \<in> r"
    with ** * assms WELL suc_least[of "{a}" a']
    have "(suc {a},a') \<in> r" by auto
    with REL DIFF * ANTISYM antisym_def[of r]
    have False by simp
   }
   ultimately have "(a',a) \<in> r"
   by blast
  }
  thus ?thesis by blast
qed

lemma under_underS_suc:
assumes IN: "a \<in> Field r" and ABV: "aboveS a \<noteq> {}"
shows "underS (suc {a}) = under a"
proof-
  have 1: "AboveS {a} \<noteq> {}"
  using ABV aboveS_AboveS_singl[of r] by auto
  have 2: "a \<noteq> suc {a} \<and> (a,suc {a}) \<in> r"
  using suc_greater[of "{a}" a] IN 1 by auto
  (*   *)
  have "underS (suc {a}) \<le> under a"
  proof(unfold underS_def under_def, auto)
    fix x assume *: "x \<noteq> suc {a}" and **: "(x,suc {a}) \<in> r"
    with suc_singl_pred[of a x] IN ABV
    have "x = a \<or> (x,a) \<in> r" by auto
    with REFL refl_on_def[of _ r] IN
    show "(x,a) \<in> r" by auto
  qed
  (*  *)
  moreover
  (*   *)
  have "under a \<le> underS (suc {a})"
  proof(unfold underS_def under_def, auto)
    assume "(suc {a}, a) \<in> r"
    with 2 ANTISYM antisym_def[of r]
    show False by auto
  next
    fix x assume *: "(x,a) \<in> r"
    with 2 TRANS trans_def[of r]
    show "(x,suc {a}) \<in> r" by blast
  (*  blast is often better than auto/auto for transitivity-like properties *)
  qed
  (*  *)
  ultimately show ?thesis by blast
qed

subsubsection {* Properties of order filters *}

lemma ofilter_Under[simp]:
assumes "A \<le> Field r"
shows "ofilter(Under A)"
proof(unfold ofilter_def, auto)
  fix x assume "x \<in> Under A"
  thus "x \<in> Field r"
  using Under_Field[of r] assms by auto
next
  fix a x
  assume "a \<in> Under A" and "x \<in> under a"
  thus "x \<in> Under A"
  using TRANS under_Under_trans[of r] by auto
qed

lemma ofilter_UnderS[simp]:
assumes "A \<le> Field r"
shows "ofilter(UnderS A)"
proof(unfold ofilter_def, auto)
  fix x assume "x \<in> UnderS A"
  thus "x \<in> Field r"
  using UnderS_Field[of r] assms by auto
next
  fix a x
  assume "a \<in> UnderS A" and "x \<in> under a"
  thus "x \<in> UnderS A"
  using TRANS ANTISYM under_UnderS_trans[of r] by auto
qed

lemma ofilter_Int[simp]: "\<lbrakk>ofilter A; ofilter B\<rbrakk> \<Longrightarrow> ofilter(A Int B)"
unfolding ofilter_def by blast

lemma ofilter_Un[simp]: "\<lbrakk>ofilter A; ofilter B\<rbrakk> \<Longrightarrow> ofilter(A \<union> B)"
unfolding ofilter_def by blast

lemma ofilter_INTER:
"\<lbrakk>I \<noteq> {}; \<And> i. i \<in> I \<Longrightarrow> ofilter(A i)\<rbrakk> \<Longrightarrow> ofilter (\<Inter> i \<in> I. A i)"
unfolding ofilter_def by blast

lemma ofilter_Inter:
"\<lbrakk>S \<noteq> {}; \<And> A. A \<in> S \<Longrightarrow> ofilter A\<rbrakk> \<Longrightarrow> ofilter (Inter S)"
unfolding ofilter_def by blast

lemma ofilter_Union:
"(\<And> A. A \<in> S \<Longrightarrow> ofilter A) \<Longrightarrow> ofilter (Union S)"
unfolding ofilter_def by blast

lemma ofilter_under_Union:
"ofilter A \<Longrightarrow> A = Union {under a| a. a \<in> A}"
using ofilter_under_UNION[of A]
by(unfold Union_eq, auto)

subsubsection {* Other properties *}

lemma Trans_Under_regressive:
assumes NE: "A \<noteq> {}" and SUB: "A \<le> Field r"
shows "Under(Under A) \<le> Under A"
proof
  let ?a = "minim A"
  (*  Preliminary facts *)
  have 1: "minim A \<in> Under A"
  using assms minim_Under by auto
  have 2: "\<forall>y \<in> A. (minim A, y) \<in> r"
  using assms minim_least by auto
  (* Main proof *)
  fix x assume "x \<in> Under(Under A)"
  with 1 have 1: "(x,minim A) \<in> r"
  using Under_def[of r] by auto
  with Field_def have "x \<in> Field r" by fastforce
  moreover
  {fix y assume *: "y \<in> A"
   hence "(x,y) \<in> r"
   using 1 2 TRANS trans_def[of r] by blast
   with Field_def have "(x,y) \<in> r" by auto
  }
  ultimately
  show "x \<in> Under A" unfolding Under_def by auto
qed

lemma ofilter_suc_Field:
assumes OF: "ofilter A" and NE: "A \<noteq> Field r"
shows "ofilter (A \<union> {suc A})"
proof-
  (* Preliminary facts *)
  have 1: "A \<le> Field r" using OF ofilter_def by auto
  hence 2: "AboveS A \<noteq> {}"
  using ofilter_AboveS_Field NE OF by blast
  from 1 2 suc_inField
  have 3: "suc A \<in> Field r" by auto
  (* Main proof *)
  show ?thesis
  proof(unfold ofilter_def, auto simp add: 1 3)
    fix a x
    assume "a \<in> A" "x \<in> under a" "x \<notin> A"
    with OF ofilter_def have False by auto
    thus "x = suc A" by simp
  next
    fix x assume *: "x \<in> under (suc A)" and **: "x \<notin> A"
    hence "x \<in> Field r" using under_def Field_def by fastforce
    with ** have "x \<in> AboveS A"
    using ofilter_AboveS_Field[of A] OF by auto
    hence "(suc A,x) \<in> r"
    using suc_least_AboveS by auto
    moreover
    have "(x,suc A) \<in> r" using * under_def[of r] by auto
    ultimately show "x = suc A"
    using ANTISYM antisym_def[of r] by auto
  qed
qed

(* FIXME: needed? *)
declare
  minim_in[simp]
  minim_inField[simp]
  minim_least[simp]
  under_ofilter[simp]
  underS_ofilter[simp]
  Field_ofilter[simp]

end

abbreviation "worec \<equiv> wo_rel.worec"
abbreviation "adm_wo \<equiv> wo_rel.adm_wo"
abbreviation "isMinim \<equiv> wo_rel.isMinim"
abbreviation "minim \<equiv> wo_rel.minim"
abbreviation "max2 \<equiv> wo_rel.max2"
abbreviation "supr \<equiv> wo_rel.supr"
abbreviation "suc \<equiv> wo_rel.suc"

end


(*  Title:      SmallStep.thy
    Author:     Peter Gammie
*)

section \<open>A small-step (reduction) operational semantics for PCF\<close>
(*<*)

theory SmallStep
imports
  OpSem
begin

(*>*)
text\<open>

A small-step semantics allows us to express more things, like the
progress of well-typed programs.

FIXME adjust: This relation is non-deterministic, but only \<open>\<beta>\<close>-reduces terms where the argument is a value. Moreover if we
start with a closed term then our values are also closed. So while in
general (i.e., for open terms) our substitution operation is wrong and
this relation is too big, we show that things work out if we start
reducing from a closed term (i.e., a program).

FIXME following Tolmach @{url
"https://www.cis.upenn.edu/~bcpierce/sf/current/Norm.html"} we make
this relation deterministic. Eases the normalization proof.

\<close>

inductive
  reduction :: "db \<Rightarrow> db \<Rightarrow> bool" ("_ \<rightarrow>\<^sub>v _" [50, 50] 50)
where
  betaN: "DBApp (DBAbsN u) v \<rightarrow>\<^sub>v u<v/0>"
| betaV: "val v \<Longrightarrow> DBApp (DBAbsV u) v \<rightarrow>\<^sub>v u<v/0>"
| "f \<rightarrow>\<^sub>v f' \<Longrightarrow> DBApp f x \<rightarrow>\<^sub>v DBApp f' x"
| "\<lbrakk>f = DBAbsV u; x \<rightarrow>\<^sub>v x'\<rbrakk> \<Longrightarrow> DBApp f x \<rightarrow>\<^sub>v DBApp f x'"
| "DBFix f \<rightarrow>\<^sub>v f<DBFix f/0>"
| "DBCond DBtt t e \<rightarrow>\<^sub>v t"
| "DBCond DBff t e \<rightarrow>\<^sub>v e"
| "DBSucc (DBNum n) \<rightarrow>\<^sub>v DBNum (Suc n)"
| "DBPred (DBNum (Suc n)) \<rightarrow>\<^sub>v DBNum n"
| "DBIsZero (DBNum 0) \<rightarrow>\<^sub>v DBtt"
| "0 < n \<Longrightarrow> DBIsZero (DBNum n) \<rightarrow>\<^sub>v DBff"

abbreviation \<comment> \<open>The transitive, reflexive closure of the reduction relation.\<close>
  reduction_trc :: "db \<Rightarrow> db \<Rightarrow> bool" ("_ \<rightarrow>\<^sub>v\<^sup>* _" [100, 100] 100)
where
  "reduction_trc \<equiv> rtranclp reduction"

declare reduction.intros[intro!]

inductive_cases reduction_inv:
  "DBVar v \<rightarrow>\<^sub>v t'"
  "DBApp f x \<rightarrow>\<^sub>v t'"
  "DBAbsN u \<rightarrow>\<^sub>v t'"
  "DBAbsV u \<rightarrow>\<^sub>v t'"
  "DBFix f \<rightarrow>\<^sub>v t'"
  "DBCond i t e \<rightarrow>\<^sub>v t'"
  "DBff \<rightarrow>\<^sub>v t'"
  "DBtt \<rightarrow>\<^sub>v t'"
  "DBNum n \<rightarrow>\<^sub>v t'"
  "DBSucc n \<rightarrow>\<^sub>v t'"
  "DBPred n \<rightarrow>\<^sub>v t'"
  "DBIsZero n \<rightarrow>\<^sub>v t'"

lemma reduction_val:
  assumes "val v"
  assumes "v \<rightarrow>\<^sub>v v'"
  shows False
using assms by (auto elim: val.cases reduction_inv)

lemma reduction_deterministic:
  assumes "t \<rightarrow>\<^sub>v t'"
  assumes "t \<rightarrow>\<^sub>v t''"
  shows "t'' = t'"
using assms by (induct arbitrary: t'') (blast dest: reduction_val elim: reduction_inv)+

subsubsection\<open> Reduction is consistent with evaluation \<close>

lemma reduction_eval:
  assumes "t \<rightarrow>\<^sub>v t'"
  assumes "t' \<Down> v"
  shows "t \<Down> v"
using assms by (induct arbitrary: v) (auto elim!: evalOP_inv val.cases intro: eval_val)

lemma reduction_trc_eval:
  assumes "t \<rightarrow>\<^sub>v\<^sup>* t'"
  assumes "t' \<Down> v"
  shows "t \<Down> v"
using assms by induct (auto simp: reduction_eval)

theorem reduction_trc_val_eval:
  assumes "t \<rightarrow>\<^sub>v\<^sup>* v"
  assumes "val v"
  shows "t \<Down> v"
using assms by (induct rule: converse_rtranclp_induct) (auto intro: eval_val reduction_trc_eval)

text\<open>

We show the converse (of sorts) using the frame stack machinery of the
next section.

\<close>

(*<*)

end
(*>*)


(*  Title:      HOL/ex/Tarski.thy
    Author:     Florian Kammüller, Cambridge University Computer Laboratory
*)

section {* The Full Theorem of Tarski *}

theory Tarski
imports Main "~~/src/HOL/Library/FuncSet"
begin

text {*
  Minimal version of lattice theory plus the full theorem of Tarski:
  The fixedpoints of a complete lattice themselves form a complete
  lattice.

  Illustrates first-class theories, using the Sigma representation of
  structures.  Tidied and converted to Isar by lcp.
*}

record 'a potype =
  pset  :: "'a set"
  order :: "('a * 'a) set"

definition
  monotone :: "['a => 'a, 'a set, ('a *'a)set] => bool" where
  "monotone f A r = (\<forall>x\<in>A. \<forall>y\<in>A. (x, y): r --> ((f x), (f y)) : r)"

definition
  least :: "['a => bool, 'a potype] => 'a" where
  "least P po = (SOME x. x: pset po & P x &
                       (\<forall>y \<in> pset po. P y --> (x,y): order po))"

definition
  greatest :: "['a => bool, 'a potype] => 'a" where
  "greatest P po = (SOME x. x: pset po & P x &
                          (\<forall>y \<in> pset po. P y --> (y,x): order po))"

definition
  lub  :: "['a set, 'a potype] => 'a" where
  "lub S po = least (%x. \<forall>y\<in>S. (y,x): order po) po"

definition
  glb  :: "['a set, 'a potype] => 'a" where
  "glb S po = greatest (%x. \<forall>y\<in>S. (x,y): order po) po"

definition
  isLub :: "['a set, 'a potype, 'a] => bool" where
  "isLub S po = (%L. (L: pset po & (\<forall>y\<in>S. (y,L): order po) &
                   (\<forall>z\<in>pset po. (\<forall>y\<in>S. (y,z): order po) --> (L,z): order po)))"

definition
  isGlb :: "['a set, 'a potype, 'a] => bool" where
  "isGlb S po = (%G. (G: pset po & (\<forall>y\<in>S. (G,y): order po) &
                 (\<forall>z \<in> pset po. (\<forall>y\<in>S. (z,y): order po) --> (z,G): order po)))"

definition
  "fix"    :: "[('a => 'a), 'a set] => 'a set" where
  "fix f A  = {x. x: A & f x = x}"

definition
  interval :: "[('a*'a) set,'a, 'a ] => 'a set" where
  "interval r a b = {x. (a,x): r & (x,b): r}"

definition
  Bot :: "'a potype => 'a" where
  "Bot po = least (%x. True) po"

definition
  Top :: "'a potype => 'a" where
  "Top po = greatest (%x. True) po"

definition
  PartialOrder :: "('a potype) set" where
  "PartialOrder = {P. refl_on (pset P) (order P) & antisym (order P) &
                       trans (order P)}"

definition
  CompleteLattice :: "('a potype) set" where
  "CompleteLattice = {cl. cl: PartialOrder &
                        (\<forall>S. S \<subseteq> pset cl --> (\<exists>L. isLub S cl L)) &
                        (\<forall>S. S \<subseteq> pset cl --> (\<exists>G. isGlb S cl G))}"

definition
  CLF_set :: "('a potype * ('a => 'a)) set" where
  "CLF_set = (SIGMA cl: CompleteLattice.
            {f. f: pset cl -> pset cl & monotone f (pset cl) (order cl)})"

definition
  induced :: "['a set, ('a * 'a) set] => ('a *'a)set" where
  "induced A r = {(a,b). a : A & b: A & (a,b): r}"

definition
  sublattice :: "('a potype * 'a set)set" where
  "sublattice =
      (SIGMA cl: CompleteLattice.
          {S. S \<subseteq> pset cl &
           (| pset = S, order = induced S (order cl) |): CompleteLattice})"

abbreviation
  sublat :: "['a set, 'a potype] => bool"  ("_ <<= _" [51,50]50) where
  "S <<= cl == S : sublattice `` {cl}"

definition
  dual :: "'a potype => 'a potype" where
  "dual po = (| pset = pset po, order = converse (order po) |)"

locale S =
  fixes cl :: "'a potype"
    and A  :: "'a set"
    and r  :: "('a * 'a) set"
  defines A_def: "A == pset cl"
     and  r_def: "r == order cl"

locale PO = S +
  assumes cl_po:  "cl : PartialOrder"

locale CL = S +
  assumes cl_co:  "cl : CompleteLattice"

sublocale CL < po: PO
apply (simp_all add: A_def r_def)
apply unfold_locales
using cl_co unfolding CompleteLattice_def by auto

locale CLF = S +
  fixes f :: "'a => 'a"
    and P :: "'a set"
  assumes f_cl:  "(cl,f) : CLF_set" (*was the equivalent "f : CLF_set``{cl}"*)
  defines P_def: "P == fix f A"

sublocale CLF < cl: CL
apply (simp_all add: A_def r_def)
apply unfold_locales
using f_cl unfolding CLF_set_def by auto

locale Tarski = CLF +
  fixes Y     :: "'a set"
    and intY1 :: "'a set"
    and v     :: "'a"
  assumes
    Y_ss: "Y \<subseteq> P"
  defines
    intY1_def: "intY1 == interval r (lub Y cl) (Top cl)"
    and v_def: "v == glb {x. ((%x: intY1. f x) x, x): induced intY1 r &
                             x: intY1}
                      (| pset=intY1, order=induced intY1 r|)"

subsection {* Partial Order *}

lemma (in PO) dual:
  "PO (dual cl)"
apply unfold_locales
using cl_po
unfolding PartialOrder_def dual_def
by auto

lemma (in PO) PO_imp_refl_on [simp]: "refl_on A r"
apply (insert cl_po)
apply (simp add: PartialOrder_def A_def r_def)
done

lemma (in PO) PO_imp_sym [simp]: "antisym r"
apply (insert cl_po)
apply (simp add: PartialOrder_def r_def)
done

lemma (in PO) PO_imp_trans [simp]: "trans r"
apply (insert cl_po)
apply (simp add: PartialOrder_def r_def)
done

lemma (in PO) reflE: "x \<in> A ==> (x, x) \<in> r"
apply (insert cl_po)
apply (simp add: PartialOrder_def refl_on_def A_def r_def)
done

lemma (in PO) antisymE: "[| (a, b) \<in> r; (b, a) \<in> r |] ==> a = b"
apply (insert cl_po)
apply (simp add: PartialOrder_def antisym_def r_def)
done

lemma (in PO) transE: "[| (a, b) \<in> r; (b, c) \<in> r|] ==> (a,c) \<in> r"
apply (insert cl_po)
apply (simp add: PartialOrder_def r_def)
apply (unfold trans_def, fast)
done

lemma (in PO) monotoneE:
     "[| monotone f A r;  x \<in> A; y \<in> A; (x, y) \<in> r |] ==> (f x, f y) \<in> r"
by (simp add: monotone_def)

lemma (in PO) po_subset_po:
     "S \<subseteq> A ==> (| pset = S, order = induced S r |) \<in> PartialOrder"
apply (simp (no_asm) add: PartialOrder_def)
apply auto
-- {* refl *}
apply (simp add: refl_on_def induced_def)
apply (blast intro: reflE)
-- {* antisym *}
apply (simp add: antisym_def induced_def)
apply (blast intro: antisymE)
-- {* trans *}
apply (simp add: trans_def induced_def)
apply (blast intro: transE)
done

lemma (in PO) indE: "[| (x, y) \<in> induced S r; S \<subseteq> A |] ==> (x, y) \<in> r"
by (simp add: add: induced_def)

lemma (in PO) indI: "[| (x, y) \<in> r; x \<in> S; y \<in> S |] ==> (x, y) \<in> induced S r"
by (simp add: add: induced_def)

lemma (in CL) CL_imp_ex_isLub: "S \<subseteq> A ==> \<exists>L. isLub S cl L"
apply (insert cl_co)
apply (simp add: CompleteLattice_def A_def)
done

declare (in CL) cl_co [simp]

lemma isLub_lub: "(\<exists>L. isLub S cl L) = isLub S cl (lub S cl)"
by (simp add: lub_def least_def isLub_def some_eq_ex [symmetric])

lemma isGlb_glb: "(\<exists>G. isGlb S cl G) = isGlb S cl (glb S cl)"
by (simp add: glb_def greatest_def isGlb_def some_eq_ex [symmetric])

lemma isGlb_dual_isLub: "isGlb S cl = isLub S (dual cl)"
by (simp add: isLub_def isGlb_def dual_def converse_unfold)

lemma isLub_dual_isGlb: "isLub S cl = isGlb S (dual cl)"
by (simp add: isLub_def isGlb_def dual_def converse_unfold)

lemma (in PO) dualPO: "dual cl \<in> PartialOrder"
apply (insert cl_po)
apply (simp add: PartialOrder_def dual_def refl_on_converse
                 trans_converse antisym_converse)
done

lemma Rdual:
     "\<forall>S. (S \<subseteq> A -->( \<exists>L. isLub S (| pset = A, order = r|) L))
      ==> \<forall>S. (S \<subseteq> A --> (\<exists>G. isGlb S (| pset = A, order = r|) G))"
apply safe
apply (rule_tac x = "lub {y. y \<in> A & (\<forall>k \<in> S. (y, k) \<in> r)}
                      (|pset = A, order = r|) " in exI)
apply (drule_tac x = "{y. y \<in> A & (\<forall>k \<in> S. (y,k) \<in> r) }" in spec)
apply (drule mp, fast)
apply (simp add: isLub_lub isGlb_def)
apply (simp add: isLub_def, blast)
done

lemma lub_dual_glb: "lub S cl = glb S (dual cl)"
by (simp add: lub_def glb_def least_def greatest_def dual_def converse_unfold)

lemma glb_dual_lub: "glb S cl = lub S (dual cl)"
by (simp add: lub_def glb_def least_def greatest_def dual_def converse_unfold)

lemma CL_subset_PO: "CompleteLattice \<subseteq> PartialOrder"
by (simp add: PartialOrder_def CompleteLattice_def, fast)

lemmas CL_imp_PO = CL_subset_PO [THEN subsetD]

(*declare CL_imp_PO [THEN PO.PO_imp_refl, simp]
declare CL_imp_PO [THEN PO.PO_imp_sym, simp]
declare CL_imp_PO [THEN PO.PO_imp_trans, simp]*)

lemma (in CL) CO_refl_on: "refl_on A r"
by (rule PO_imp_refl_on)

lemma (in CL) CO_antisym: "antisym r"
by (rule PO_imp_sym)

lemma (in CL) CO_trans: "trans r"
by (rule PO_imp_trans)

lemma CompleteLatticeI:
     "[| po \<in> PartialOrder; (\<forall>S. S \<subseteq> pset po --> (\<exists>L. isLub S po L));
         (\<forall>S. S \<subseteq> pset po --> (\<exists>G. isGlb S po G))|]
      ==> po \<in> CompleteLattice"
apply (unfold CompleteLattice_def, blast)
done

lemma (in CL) CL_dualCL: "dual cl \<in> CompleteLattice"
apply (insert cl_co)
apply (simp add: CompleteLattice_def dual_def)
apply (fold dual_def)
apply (simp add: isLub_dual_isGlb [symmetric] isGlb_dual_isLub [symmetric]
                 dualPO)
done

lemma (in PO) dualA_iff: "pset (dual cl) = pset cl"
by (simp add: dual_def)

lemma (in PO) dualr_iff: "((x, y) \<in> (order(dual cl))) = ((y, x) \<in> order cl)"
by (simp add: dual_def)

lemma (in PO) monotone_dual:
     "monotone f (pset cl) (order cl)
     ==> monotone f (pset (dual cl)) (order(dual cl))"
by (simp add: monotone_def dualA_iff dualr_iff)

lemma (in PO) interval_dual:
     "[| x \<in> A; y \<in> A|] ==> interval r x y = interval (order(dual cl)) y x"
apply (simp add: interval_def dualr_iff)
apply (fold r_def, fast)
done

lemma (in PO) trans:
  "(x, y) \<in> r \<Longrightarrow> (y, z) \<in> r \<Longrightarrow> (x, z) \<in> r"
using cl_po apply (auto simp add: PartialOrder_def r_def)
unfolding trans_def by blast

lemma (in PO) interval_not_empty:
  "interval r a b \<noteq> {} ==> (a, b) \<in> r"
apply (simp add: interval_def)
using trans by blast

lemma (in PO) interval_imp_mem: "x \<in> interval r a b ==> (a, x) \<in> r"
by (simp add: interval_def)

lemma (in PO) left_in_interval:
     "[| a \<in> A; b \<in> A; interval r a b \<noteq> {} |] ==> a \<in> interval r a b"
apply (simp (no_asm_simp) add: interval_def)
apply (simp add: PO_imp_trans interval_not_empty)
apply (simp add: reflE)
done

lemma (in PO) right_in_interval:
     "[| a \<in> A; b \<in> A; interval r a b \<noteq> {} |] ==> b \<in> interval r a b"
apply (simp (no_asm_simp) add: interval_def)
apply (simp add: PO_imp_trans interval_not_empty)
apply (simp add: reflE)
done

subsection {* sublattice *}

lemma (in PO) sublattice_imp_CL:
     "S <<= cl  ==> (| pset = S, order = induced S r |) \<in> CompleteLattice"
by (simp add: sublattice_def CompleteLattice_def r_def)

lemma (in CL) sublatticeI:
     "[| S \<subseteq> A; (| pset = S, order = induced S r |) \<in> CompleteLattice |]
      ==> S <<= cl"
by (simp add: sublattice_def A_def r_def)

lemma (in CL) dual:
  "CL (dual cl)"
apply unfold_locales
using cl_co unfolding CompleteLattice_def
apply (simp add: dualPO isGlb_dual_isLub [symmetric] isLub_dual_isGlb [symmetric] dualA_iff)
done

subsection {* lub *}

lemma (in CL) lub_unique: "[| S \<subseteq> A; isLub S cl x; isLub S cl L|] ==> x = L"
apply (rule antisymE)
apply (auto simp add: isLub_def r_def)
done

lemma (in CL) lub_upper: "[|S \<subseteq> A; x \<in> S|] ==> (x, lub S cl) \<in> r"
apply (rule CL_imp_ex_isLub [THEN exE], assumption)
apply (unfold lub_def least_def)
apply (rule some_equality [THEN ssubst])
  apply (simp add: isLub_def)
 apply (simp add: lub_unique A_def isLub_def)
apply (simp add: isLub_def r_def)
done

lemma (in CL) lub_least:
     "[| S \<subseteq> A; L \<in> A; \<forall>x \<in> S. (x,L) \<in> r |] ==> (lub S cl, L) \<in> r"
apply (rule CL_imp_ex_isLub [THEN exE], assumption)
apply (unfold lub_def least_def)
apply (rule_tac s=x in some_equality [THEN ssubst])
  apply (simp add: isLub_def)
 apply (simp add: lub_unique A_def isLub_def)
apply (simp add: isLub_def r_def A_def)
done

lemma (in CL) lub_in_lattice: "S \<subseteq> A ==> lub S cl \<in> A"
apply (rule CL_imp_ex_isLub [THEN exE], assumption)
apply (unfold lub_def least_def)
apply (subst some_equality)
apply (simp add: isLub_def)
prefer 2 apply (simp add: isLub_def A_def)
apply (simp add: lub_unique A_def isLub_def)
done

lemma (in CL) lubI:
     "[| S \<subseteq> A; L \<in> A; \<forall>x \<in> S. (x,L) \<in> r;
         \<forall>z \<in> A. (\<forall>y \<in> S. (y,z) \<in> r) --> (L,z) \<in> r |] ==> L = lub S cl"
apply (rule lub_unique, assumption)
apply (simp add: isLub_def A_def r_def)
apply (unfold isLub_def)
apply (rule conjI)
apply (fold A_def r_def)
apply (rule lub_in_lattice, assumption)
apply (simp add: lub_upper lub_least)
done

lemma (in CL) lubIa: "[| S \<subseteq> A; isLub S cl L |] ==> L = lub S cl"
by (simp add: lubI isLub_def A_def r_def)

lemma (in CL) isLub_in_lattice: "isLub S cl L ==> L \<in> A"
by (simp add: isLub_def  A_def)

lemma (in CL) isLub_upper: "[|isLub S cl L; y \<in> S|] ==> (y, L) \<in> r"
by (simp add: isLub_def r_def)

lemma (in CL) isLub_least:
     "[| isLub S cl L; z \<in> A; \<forall>y \<in> S. (y, z) \<in> r|] ==> (L, z) \<in> r"
by (simp add: isLub_def A_def r_def)

lemma (in CL) isLubI:
     "[| L \<in> A; \<forall>y \<in> S. (y, L) \<in> r;
         (\<forall>z \<in> A. (\<forall>y \<in> S. (y, z):r) --> (L, z) \<in> r)|] ==> isLub S cl L"
by (simp add: isLub_def A_def r_def)

subsection {* glb *}

lemma (in CL) glb_in_lattice: "S \<subseteq> A ==> glb S cl \<in> A"
apply (subst glb_dual_lub)
apply (simp add: A_def)
apply (rule dualA_iff [THEN subst])
apply (rule CL.lub_in_lattice)
apply (rule dual)
apply (simp add: dualA_iff)
done

lemma (in CL) glb_lower: "[|S \<subseteq> A; x \<in> S|] ==> (glb S cl, x) \<in> r"
apply (subst glb_dual_lub)
apply (simp add: r_def)
apply (rule dualr_iff [THEN subst])
apply (rule CL.lub_upper)
apply (rule dual)
apply (simp add: dualA_iff A_def, assumption)
done

text {*
  Reduce the sublattice property by using substructural properties;
  abandoned see @{text "Tarski_4.ML"}.
*}

lemma (in CLF) [simp]:
    "f: pset cl -> pset cl & monotone f (pset cl) (order cl)"
apply (insert f_cl)
apply (simp add: CLF_set_def)
done

declare (in CLF) f_cl [simp]

lemma (in CLF) f_in_funcset: "f \<in> A -> A"
by (simp add: A_def)

lemma (in CLF) monotone_f: "monotone f A r"
by (simp add: A_def r_def)

lemma (in CLF) CLF_dual: "(dual cl, f) \<in> CLF_set"
apply (simp add: CLF_set_def  CL_dualCL monotone_dual)
apply (simp add: dualA_iff)
done

lemma (in CLF) dual:
  "CLF (dual cl) f"
apply (rule CLF.intro)
apply (rule CLF_dual)
done

subsection {* fixed points *}

lemma fix_subset: "fix f A \<subseteq> A"
by (simp add: fix_def, fast)

lemma fix_imp_eq: "x \<in> fix f A ==> f x = x"
by (simp add: fix_def)

lemma fixf_subset:
     "[| A \<subseteq> B; x \<in> fix (%y: A. f y) A |] ==> x \<in> fix f B"
by (simp add: fix_def, auto)

subsection {* lemmas for Tarski, lub *}
lemma (in CLF) lubH_le_flubH:
     "H = {x. (x, f x) \<in> r & x \<in> A} ==> (lub H cl, f (lub H cl)) \<in> r"
apply (rule lub_least, fast)
apply (rule f_in_funcset [THEN funcset_mem])
apply (rule lub_in_lattice, fast)
-- {* @{text "\<forall>x:H. (x, f (lub H r)) \<in> r"} *}
apply (rule ballI)
apply (rule transE)
-- {* instantiates @{text "(x, ???z) \<in> order cl to (x, f x)"}, *}
-- {* because of the def of @{text H} *}
apply fast
-- {* so it remains to show @{text "(f x, f (lub H cl)) \<in> r"} *}
apply (rule_tac f = "f" in monotoneE)
apply (rule monotone_f, fast)
apply (rule lub_in_lattice, fast)
apply (rule lub_upper, fast)
apply assumption
done

lemma (in CLF) flubH_le_lubH:
     "[|  H = {x. (x, f x) \<in> r & x \<in> A} |] ==> (f (lub H cl), lub H cl) \<in> r"
apply (rule lub_upper, fast)
apply (rule_tac t = "H" in ssubst, assumption)
apply (rule CollectI)
apply (rule conjI)
apply (rule_tac [2] f_in_funcset [THEN funcset_mem])
apply (rule_tac [2] lub_in_lattice)
prefer 2 apply fast
apply (rule_tac f = "f" in monotoneE)
apply (rule monotone_f)
  apply (blast intro: lub_in_lattice)
 apply (blast intro: lub_in_lattice f_in_funcset [THEN funcset_mem])
apply (simp add: lubH_le_flubH)
done

lemma (in CLF) lubH_is_fixp:
     "H = {x. (x, f x) \<in> r & x \<in> A} ==> lub H cl \<in> fix f A"
apply (simp add: fix_def)
apply (rule conjI)
apply (rule lub_in_lattice, fast)
apply (rule antisymE)
apply (simp add: flubH_le_lubH)
apply (simp add: lubH_le_flubH)
done

lemma (in CLF) fix_in_H:
     "[| H = {x. (x, f x) \<in> r & x \<in> A};  x \<in> P |] ==> x \<in> H"
by (simp add: P_def fix_imp_eq [of _ f A] reflE CO_refl_on
                    fix_subset [of f A, THEN subsetD])

lemma (in CLF) fixf_le_lubH:
     "H = {x. (x, f x) \<in> r & x \<in> A} ==> \<forall>x \<in> fix f A. (x, lub H cl) \<in> r"
apply (rule ballI)
apply (rule lub_upper, fast)
apply (rule fix_in_H)
apply (simp_all add: P_def)
done

lemma (in CLF) lubH_least_fixf:
     "H = {x. (x, f x) \<in> r & x \<in> A}
      ==> \<forall>L. (\<forall>y \<in> fix f A. (y,L) \<in> r) --> (lub H cl, L) \<in> r"
apply (rule allI)
apply (rule impI)
apply (erule bspec)
apply (rule lubH_is_fixp, assumption)
done

subsection {* Tarski fixpoint theorem 1, first part *}
lemma (in CLF) T_thm_1_lub: "lub P cl = lub {x. (x, f x) \<in> r & x \<in> A} cl"
apply (rule sym)
apply (simp add: P_def)
apply (rule lubI)
apply (rule fix_subset)
apply (rule lub_in_lattice, fast)
apply (simp add: fixf_le_lubH)
apply (simp add: lubH_least_fixf)
done

lemma (in CLF) glbH_is_fixp: "H = {x. (f x, x) \<in> r & x \<in> A} ==> glb H cl \<in> P"
  -- {* Tarski for glb *}
apply (simp add: glb_dual_lub P_def A_def r_def)
apply (rule dualA_iff [THEN subst])
apply (rule CLF.lubH_is_fixp)
apply (rule dual)
apply (simp add: dualr_iff dualA_iff)
done

lemma (in CLF) T_thm_1_glb: "glb P cl = glb {x. (f x, x) \<in> r & x \<in> A} cl"
apply (simp add: glb_dual_lub P_def A_def r_def)
apply (rule dualA_iff [THEN subst])
apply (simp add: CLF.T_thm_1_lub [of _ f, OF dual]
                 dualPO CL_dualCL CLF_dual dualr_iff)
done

subsection {* interval *}

lemma (in CLF) rel_imp_elem: "(x, y) \<in> r ==> x \<in> A"
apply (insert CO_refl_on)
apply (simp add: refl_on_def, blast)
done

lemma (in CLF) interval_subset: "[| a \<in> A; b \<in> A |] ==> interval r a b \<subseteq> A"
apply (simp add: interval_def)
apply (blast intro: rel_imp_elem)
done

lemma (in CLF) intervalI:
     "[| (a, x) \<in> r; (x, b) \<in> r |] ==> x \<in> interval r a b"
by (simp add: interval_def)

lemma (in CLF) interval_lemma1:
     "[| S \<subseteq> interval r a b; x \<in> S |] ==> (a, x) \<in> r"
by (unfold interval_def, fast)

lemma (in CLF) interval_lemma2:
     "[| S \<subseteq> interval r a b; x \<in> S |] ==> (x, b) \<in> r"
by (unfold interval_def, fast)

lemma (in CLF) a_less_lub:
     "[| S \<subseteq> A; S \<noteq> {};
         \<forall>x \<in> S. (a,x) \<in> r; \<forall>y \<in> S. (y, L) \<in> r |] ==> (a,L) \<in> r"
by (blast intro: transE)

lemma (in CLF) glb_less_b:
     "[| S \<subseteq> A; S \<noteq> {};
         \<forall>x \<in> S. (x,b) \<in> r; \<forall>y \<in> S. (G, y) \<in> r |] ==> (G,b) \<in> r"
by (blast intro: transE)

lemma (in CLF) S_intv_cl:
     "[| a \<in> A; b \<in> A; S \<subseteq> interval r a b |]==> S \<subseteq> A"
by (simp add: subset_trans [OF _ interval_subset])

lemma (in CLF) L_in_interval:
     "[| a \<in> A; b \<in> A; S \<subseteq> interval r a b;
         S \<noteq> {}; isLub S cl L; interval r a b \<noteq> {} |] ==> L \<in> interval r a b"
apply (rule intervalI)
apply (rule a_less_lub)
prefer 2 apply assumption
apply (simp add: S_intv_cl)
apply (rule ballI)
apply (simp add: interval_lemma1)
apply (simp add: isLub_upper)
-- {* @{text "(L, b) \<in> r"} *}
apply (simp add: isLub_least interval_lemma2)
done

lemma (in CLF) G_in_interval:
     "[| a \<in> A; b \<in> A; interval r a b \<noteq> {}; S \<subseteq> interval r a b; isGlb S cl G;
         S \<noteq> {} |] ==> G \<in> interval r a b"
apply (simp add: interval_dual)
apply (simp add: CLF.L_in_interval [of _ f, OF dual]
                 dualA_iff A_def isGlb_dual_isLub)
done

lemma (in CLF) intervalPO:
     "[| a \<in> A; b \<in> A; interval r a b \<noteq> {} |]
      ==> (| pset = interval r a b, order = induced (interval r a b) r |)
          \<in> PartialOrder"
apply (rule po_subset_po)
apply (simp add: interval_subset)
done

lemma (in CLF) intv_CL_lub:
 "[| a \<in> A; b \<in> A; interval r a b \<noteq> {} |]
  ==> \<forall>S. S \<subseteq> interval r a b -->
          (\<exists>L. isLub S (| pset = interval r a b,
                          order = induced (interval r a b) r |)  L)"
apply (intro strip)
apply (frule S_intv_cl [THEN CL_imp_ex_isLub])
prefer 2 apply assumption
apply assumption
apply (erule exE)
-- {* define the lub for the interval as *}
apply (rule_tac x = "if S = {} then a else L" in exI)
apply (simp (no_asm_simp) add: isLub_def split del: split_if)
apply (intro impI conjI)
-- {* @{text "(if S = {} then a else L) \<in> interval r a b"} *}
apply (simp add: CL_imp_PO L_in_interval)
apply (simp add: left_in_interval)
-- {* lub prop 1 *}
apply (case_tac "S = {}")
-- {* @{text "S = {}, y \<in> S = False => everything"} *}
apply fast
-- {* @{text "S \<noteq> {}"} *}
apply simp
-- {* @{text "\<forall>y:S. (y, L) \<in> induced (interval r a b) r"} *}
apply (rule ballI)
apply (simp add: induced_def  L_in_interval)
apply (rule conjI)
apply (rule subsetD)
apply (simp add: S_intv_cl, assumption)
apply (simp add: isLub_upper)
-- {* @{text "\<forall>z:interval r a b. (\<forall>y:S. (y, z) \<in> induced (interval r a b) r \<longrightarrow> (if S = {} then a else L, z) \<in> induced (interval r a b) r"} *}
apply (rule ballI)
apply (rule impI)
apply (case_tac "S = {}")
-- {* @{text "S = {}"} *}
apply simp
apply (simp add: induced_def  interval_def)
apply (rule conjI)
apply (rule reflE, assumption)
apply (rule interval_not_empty)
apply (simp add: interval_def)
-- {* @{text "S \<noteq> {}"} *}
apply simp
apply (simp add: induced_def  L_in_interval)
apply (rule isLub_least, assumption)
apply (rule subsetD)
prefer 2 apply assumption
apply (simp add: S_intv_cl, fast)
done

lemmas (in CLF) intv_CL_glb = intv_CL_lub [THEN Rdual]

lemma (in CLF) interval_is_sublattice:
     "[| a \<in> A; b \<in> A; interval r a b \<noteq> {} |]
        ==> interval r a b <<= cl"
apply (rule sublatticeI)
apply (simp add: interval_subset)
apply (rule CompleteLatticeI)
apply (simp add: intervalPO)
 apply (simp add: intv_CL_lub)
apply (simp add: intv_CL_glb)
done

lemmas (in CLF) interv_is_compl_latt =
    interval_is_sublattice [THEN sublattice_imp_CL]

subsection {* Top and Bottom *}
lemma (in CLF) Top_dual_Bot: "Top cl = Bot (dual cl)"
by (simp add: Top_def Bot_def least_def greatest_def dualA_iff dualr_iff)

lemma (in CLF) Bot_dual_Top: "Bot cl = Top (dual cl)"
by (simp add: Top_def Bot_def least_def greatest_def dualA_iff dualr_iff)

lemma (in CLF) Bot_in_lattice: "Bot cl \<in> A"
apply (simp add: Bot_def least_def)
apply (rule_tac a="glb A cl" in someI2)
apply (simp_all add: glb_in_lattice glb_lower
                     r_def [symmetric] A_def [symmetric])
done

lemma (in CLF) Top_in_lattice: "Top cl \<in> A"
apply (simp add: Top_dual_Bot A_def)
apply (rule dualA_iff [THEN subst])
apply (rule CLF.Bot_in_lattice [OF dual])
done

lemma (in CLF) Top_prop: "x \<in> A ==> (x, Top cl) \<in> r"
apply (simp add: Top_def greatest_def)
apply (rule_tac a="lub A cl" in someI2)
apply (rule someI2)
apply (simp_all add: lub_in_lattice lub_upper
                     r_def [symmetric] A_def [symmetric])
done

lemma (in CLF) Bot_prop: "x \<in> A ==> (Bot cl, x) \<in> r"
apply (simp add: Bot_dual_Top r_def)
apply (rule dualr_iff [THEN subst])
apply (rule CLF.Top_prop [OF dual])
apply (simp add: dualA_iff A_def)
done

lemma (in CLF) Top_intv_not_empty: "x \<in> A  ==> interval r x (Top cl) \<noteq> {}"
apply (rule notI)
apply (drule_tac a = "Top cl" in equals0D)
apply (simp add: interval_def)
apply (simp add: refl_on_def Top_in_lattice Top_prop)
done

lemma (in CLF) Bot_intv_not_empty: "x \<in> A ==> interval r (Bot cl) x \<noteq> {}"
apply (simp add: Bot_dual_Top)
apply (subst interval_dual)
prefer 2 apply assumption
apply (simp add: A_def)
apply (rule dualA_iff [THEN subst])
apply (rule CLF.Top_in_lattice [OF dual])
apply (rule CLF.Top_intv_not_empty [OF dual])
apply (simp add: dualA_iff A_def)
done

subsection {* fixed points form a partial order *}

lemma (in CLF) fixf_po: "(| pset = P, order = induced P r|) \<in> PartialOrder"
by (simp add: P_def fix_subset po_subset_po)

lemma (in Tarski) Y_subset_A: "Y \<subseteq> A"
apply (rule subset_trans [OF _ fix_subset])
apply (rule Y_ss [simplified P_def])
done

lemma (in Tarski) lubY_in_A: "lub Y cl \<in> A"
  by (rule Y_subset_A [THEN lub_in_lattice])

lemma (in Tarski) lubY_le_flubY: "(lub Y cl, f (lub Y cl)) \<in> r"
apply (rule lub_least)
apply (rule Y_subset_A)
apply (rule f_in_funcset [THEN funcset_mem])
apply (rule lubY_in_A)
-- {* @{text "Y \<subseteq> P ==> f x = x"} *}
apply (rule ballI)
apply (rule_tac t = "x" in fix_imp_eq [THEN subst])
apply (erule Y_ss [simplified P_def, THEN subsetD])
-- {* @{text "reduce (f x, f (lub Y cl)) \<in> r to (x, lub Y cl) \<in> r"} by monotonicity *}
apply (rule_tac f = "f" in monotoneE)
apply (rule monotone_f)
apply (simp add: Y_subset_A [THEN subsetD])
apply (rule lubY_in_A)
apply (simp add: lub_upper Y_subset_A)
done

lemma (in Tarski) intY1_subset: "intY1 \<subseteq> A"
apply (unfold intY1_def)
apply (rule interval_subset)
apply (rule lubY_in_A)
apply (rule Top_in_lattice)
done

lemmas (in Tarski) intY1_elem = intY1_subset [THEN subsetD]

lemma (in Tarski) intY1_f_closed: "x \<in> intY1 \<Longrightarrow> f x \<in> intY1"
apply (simp add: intY1_def  interval_def)
apply (rule conjI)
apply (rule transE)
apply (rule lubY_le_flubY)
-- {* @{text "(f (lub Y cl), f x) \<in> r"} *}
apply (rule_tac f=f in monotoneE)
apply (rule monotone_f)
apply (rule lubY_in_A)
apply (simp add: intY1_def interval_def  intY1_elem)
apply (simp add: intY1_def  interval_def)
-- {* @{text "(f x, Top cl) \<in> r"} *}
apply (rule Top_prop)
apply (rule f_in_funcset [THEN funcset_mem])
apply (simp add: intY1_def interval_def  intY1_elem)
done

lemma (in Tarski) intY1_mono:
     "monotone (%x: intY1. f x) intY1 (induced intY1 r)"
apply (auto simp add: monotone_def induced_def intY1_f_closed)
apply (blast intro: intY1_elem monotone_f [THEN monotoneE])
done

lemma (in Tarski) intY1_is_cl:
    "(| pset = intY1, order = induced intY1 r |) \<in> CompleteLattice"
apply (unfold intY1_def)
apply (rule interv_is_compl_latt)
apply (rule lubY_in_A)
apply (rule Top_in_lattice)
apply (rule Top_intv_not_empty)
apply (rule lubY_in_A)
done

lemma (in Tarski) v_in_P: "v \<in> P"
apply (unfold P_def)
apply (rule_tac A = "intY1" in fixf_subset)
apply (rule intY1_subset)
unfolding v_def
apply (rule CLF.glbH_is_fixp [OF CLF.intro, unfolded CLF_set_def, of "\<lparr>pset = intY1, order = induced intY1 r\<rparr>", simplified])
apply auto
apply (rule intY1_is_cl)
apply (erule intY1_f_closed)
apply (rule intY1_mono)
done

lemma (in Tarski) z_in_interval:
     "[| z \<in> P; \<forall>y\<in>Y. (y, z) \<in> induced P r |] ==> z \<in> intY1"
apply (unfold intY1_def P_def)
apply (rule intervalI)
prefer 2
 apply (erule fix_subset [THEN subsetD, THEN Top_prop])
apply (rule lub_least)
apply (rule Y_subset_A)
apply (fast elim!: fix_subset [THEN subsetD])
apply (simp add: induced_def)
done

lemma (in Tarski) f'z_in_int_rel: "[| z \<in> P; \<forall>y\<in>Y. (y, z) \<in> induced P r |]
      ==> ((%x: intY1. f x) z, z) \<in> induced intY1 r"
apply (simp add: induced_def  intY1_f_closed z_in_interval P_def)
apply (simp add: fix_imp_eq [of _ f A] fix_subset [of f A, THEN subsetD]
                 reflE)
done

lemma (in Tarski) tarski_full_lemma:
     "\<exists>L. isLub Y (| pset = P, order = induced P r |) L"
apply (rule_tac x = "v" in exI)
apply (simp add: isLub_def)
-- {* @{text "v \<in> P"} *}
apply (simp add: v_in_P)
apply (rule conjI)
-- {* @{text v} is lub *}
-- {* @{text "1. \<forall>y:Y. (y, v) \<in> induced P r"} *}
apply (rule ballI)
apply (simp add: induced_def subsetD v_in_P)
apply (rule conjI)
apply (erule Y_ss [THEN subsetD])
apply (rule_tac b = "lub Y cl" in transE)
apply (rule lub_upper)
apply (rule Y_subset_A, assumption)
apply (rule_tac b = "Top cl" in interval_imp_mem)
apply (simp add: v_def)
apply (fold intY1_def)
apply (rule CL.glb_in_lattice [OF CL.intro [OF intY1_is_cl], simplified])
apply auto
apply (rule indI)
  prefer 3 apply assumption
 prefer 2 apply (simp add: v_in_P)
apply (unfold v_def)
apply (rule indE)
apply (rule_tac [2] intY1_subset)
apply (rule CL.glb_lower [OF CL.intro [OF intY1_is_cl], simplified])
  apply (simp add: CL_imp_PO intY1_is_cl)
 apply force
apply (simp add: induced_def intY1_f_closed z_in_interval)
apply (simp add: P_def fix_imp_eq [of _ f A] reflE
                 fix_subset [of f A, THEN subsetD])
done

lemma CompleteLatticeI_simp:
     "[| (| pset = A, order = r |) \<in> PartialOrder;
         \<forall>S. S \<subseteq> A --> (\<exists>L. isLub S (| pset = A, order = r |)  L) |]
    ==> (| pset = A, order = r |) \<in> CompleteLattice"
by (simp add: CompleteLatticeI Rdual)

theorem (in CLF) Tarski_full:
     "(| pset = P, order = induced P r|) \<in> CompleteLattice"
apply (rule CompleteLatticeI_simp)
apply (rule fixf_po, clarify)
apply (simp add: P_def A_def r_def)
apply (rule Tarski.tarski_full_lemma [OF Tarski.intro [OF _ Tarski_axioms.intro]])
proof - show "CLF cl f" .. qed

end


section{*Examples of Classical Reasoning*}

theory FOL_examples imports "~~/src/FOL/FOL" begin

lemma "EX y. ALL x. P(y)-->P(x)"
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (rule exCI)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (rule allI)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (rule impI)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (erule allE)
  --{* @{subgoals[display,indent=0,margin=65]} *}
txt{*see below for @{text allI} combined with @{text swap}*}
apply (erule allI [THEN [2] swap])
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (rule impI)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply (erule notE)
  --{* @{subgoals[display,indent=0,margin=65]} *}
apply assumption
done

text {*
@{thm[display] allI [THEN [2] swap]}
*}

lemma "EX y. ALL x. P(y)-->P(x)"
by blast

end