(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   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_prop_65
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

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

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

theorem property0 :
  "t2 i (S (t22 m i))"
  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_nat_pow_one
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 formulapow :: "Nat => Nat => Nat" where
"formulapow x (Z) = S Z"
| "formulapow x (S z) = times x (formulapow x z)"

theorem property0 :
  "((formulapow (S Z) x) = (S Z))"
  oops

end


(*  Title:      HOL/MicroJava/DFA/Semilat.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM
*)

chapter \<open>Bytecode Verifier \label{cha:bv}\<close>

section \<open>Semilattices\<close>

theory Semilat
imports MainRLT "HOL-Library.While_Combinator"
begin

type_synonym 'a ord = "'a \<Rightarrow> 'a \<Rightarrow> bool"
type_synonym 'a binop = "'a \<Rightarrow> 'a \<Rightarrow> 'a"
type_synonym 'a sl = "'a set \<times> 'a ord \<times> 'a binop"

definition lesub :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool"
  where "lesub x r y \<longleftrightarrow> r x y"

definition lesssub :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool"
  where "lesssub x r y \<longleftrightarrow> lesub x r y \<and> x \<noteq> y"

definition plussub :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c"
  where "plussub x f y = f x y"

notation (ASCII)
  "lesub"  ("(_ /<='__ _)" [50, 1000, 51] 50) and
  "lesssub"  ("(_ /<'__ _)" [50, 1000, 51] 50) and
  "plussub"  ("(_ /+'__ _)" [65, 1000, 66] 65)

notation
  "lesub"  ("(_ /\<sqsubseteq>\<^bsub>_\<^esub> _)" [50, 0, 51] 50) and
  "lesssub"  ("(_ /\<sqsubset>\<^bsub>_\<^esub> _)" [50, 0, 51] 50) and
  "plussub"  ("(_ /\<squnion>\<^bsub>_\<^esub> _)" [65, 0, 66] 65)

(* allow \<sub> instead of \<bsub>..\<esub> *)
abbreviation (input)
  lesub1 :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<sqsubseteq>\<^sub>_ _)" [50, 1000, 51] 50)
  where "x \<sqsubseteq>\<^sub>r y == x \<sqsubseteq>\<^bsub>r\<^esub> y"

abbreviation (input)
  lesssub1 :: "'a \<Rightarrow> 'a ord \<Rightarrow> 'a \<Rightarrow> bool" ("(_ /\<sqsubset>\<^sub>_ _)" [50, 1000, 51] 50)
  where "x \<sqsubset>\<^sub>r y == x \<sqsubset>\<^bsub>r\<^esub> y"

abbreviation (input)
  plussub1 :: "'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'b \<Rightarrow> 'c" ("(_ /\<squnion>\<^sub>_ _)" [65, 1000, 66] 65)
  where "x \<squnion>\<^sub>f y == x \<squnion>\<^bsub>f\<^esub> y"

definition ord :: "('a \<times> 'a) set \<Rightarrow> 'a ord" where
  "ord r \<equiv> \<lambda>x y. (x,y) \<in> r"

definition order :: "'a ord \<Rightarrow> bool" where
  "order r \<equiv> (\<forall>x. x \<sqsubseteq>\<^sub>r x) \<and> (\<forall>x y. x \<sqsubseteq>\<^sub>r y \<and> y \<sqsubseteq>\<^sub>r x \<longrightarrow> x=y) \<and> (\<forall>x y z. x \<sqsubseteq>\<^sub>r y \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<sqsubseteq>\<^sub>r z)"

definition top :: "'a ord \<Rightarrow> 'a \<Rightarrow> bool" where
  "top r T \<equiv> \<forall>x. x \<sqsubseteq>\<^sub>r T"

definition acc :: "'a ord \<Rightarrow> bool" where
  "acc r \<equiv> wf {(y,x). x \<sqsubset>\<^sub>r y}"

definition closed :: "'a set \<Rightarrow> 'a binop \<Rightarrow> bool" where
  "closed A f \<equiv> \<forall>x\<in>A. \<forall>y\<in>A. x \<squnion>\<^sub>f y \<in> A"

definition semilat :: "'a sl \<Rightarrow> bool" where
  "semilat \<equiv> \<lambda>(A,r,f). order r \<and> closed A f \<and>
                       (\<forall>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                       (\<forall>x\<in>A. \<forall>y\<in>A. y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                       (\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z)"

definition is_ub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "is_ub r x y u \<equiv> (x,u)\<in>r \<and> (y,u)\<in>r"

definition is_lub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "is_lub r x y u \<equiv> is_ub r x y u \<and> (\<forall>z. is_ub r x y z \<longrightarrow> (u,z)\<in>r)"

definition some_lub :: "('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "some_lub r x y \<equiv> SOME z. is_lub r x y z"

locale Semilat =
  fixes A :: "'a set"
  fixes r :: "'a ord"
  fixes f :: "'a binop"
  assumes semilat: "semilat (A, r, f)"

lemma order_refl [simp, intro]: "order r \<Longrightarrow> x \<sqsubseteq>\<^sub>r x"
  (*<*) by (unfold order_def) (simp (no_asm_simp)) (*>*)

lemma order_antisym: "\<lbrakk> order r; x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r x \<rbrakk> \<Longrightarrow> x = y"
  (*<*) by (unfold order_def) (simp (no_asm_simp)) (*>*)

lemma order_trans: "\<lbrakk> order r; x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r z \<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r z"
  (*<*) by (unfold order_def) blast (*>*)

lemma order_less_irrefl [intro, simp]: "order r \<Longrightarrow> \<not> x \<sqsubset>\<^sub>r x"
  (*<*) by (unfold order_def lesssub_def) blast (*>*)

lemma order_less_trans: "\<lbrakk> order r; x \<sqsubset>\<^sub>r y; y \<sqsubset>\<^sub>r z \<rbrakk> \<Longrightarrow> x \<sqsubset>\<^sub>r z"
  (*<*) by (unfold order_def lesssub_def) blast (*>*)

lemma topD [simp, intro]: "top r T \<Longrightarrow> x \<sqsubseteq>\<^sub>r T"
  (*<*) by (simp add: top_def) (*>*)

lemma top_le_conv [simp]: "\<lbrakk> order r; top r T \<rbrakk> \<Longrightarrow> (T \<sqsubseteq>\<^sub>r x) = (x = T)"
  (*<*) by (blast intro: order_antisym) (*>*)

lemma semilat_Def:
"semilat(A,r,f) \<equiv> order r \<and> closed A f \<and>
                 (\<forall>x\<in>A. \<forall>y\<in>A. x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                 (\<forall>x\<in>A. \<forall>y\<in>A. y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y) \<and>
                 (\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z \<longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z)"
  (*<*) by (unfold semilat_def) clarsimp (*>*)

lemma (in Semilat) orderI [simp, intro]: "order r"
  (*<*) using semilat by (simp add: semilat_Def) (*>*)

lemma (in Semilat) closedI [simp, intro]: "closed A f"
  (*<*) using semilat by (simp add: semilat_Def) (*>*)

lemma closedD: "\<lbrakk> closed A f; x\<in>A; y\<in>A \<rbrakk> \<Longrightarrow> x \<squnion>\<^sub>f y \<in> A"
  (*<*) by (unfold closed_def) blast (*>*)

lemma closed_UNIV [simp]: "closed UNIV f"
  (*<*) by (simp add: closed_def) (*>*)

lemma (in Semilat) closed_f [simp, intro]: "\<lbrakk>x \<in> A; y \<in> A\<rbrakk>  \<Longrightarrow> x \<squnion>\<^sub>f y \<in> A"
  (*<*) by (simp add: closedD [OF closedI]) (*>*)

lemma (in Semilat) refl_r [intro, simp]: "x \<sqsubseteq>\<^sub>r x" by simp

lemma (in Semilat) antisym_r [intro?]: "\<lbrakk> x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r x \<rbrakk> \<Longrightarrow> x = y"
  (*<*) by (rule order_antisym) auto (*>*)

lemma (in Semilat) trans_r [trans, intro?]: "\<lbrakk>x \<sqsubseteq>\<^sub>r y; y \<sqsubseteq>\<^sub>r z\<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r z"
  (*<*) by (auto intro: order_trans) (*>*)

lemma (in Semilat) ub1 [simp, intro?]: "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> x \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y"
  (*<*) using semilat by (simp add: semilat_Def) (*>*)

lemma (in Semilat) ub2 [simp, intro?]: "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> y \<sqsubseteq>\<^sub>r x \<squnion>\<^sub>f y"
  (*<*) using semilat by (simp add: semilat_Def) (*>*)

lemma (in Semilat) lub [simp, intro?]:
  "\<lbrakk> x \<sqsubseteq>\<^sub>r z; y \<sqsubseteq>\<^sub>r z; x \<in> A; y \<in> A; z \<in> A \<rbrakk> \<Longrightarrow> x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z"
  (*<*) using semilat by (simp add: semilat_Def) (*>*)

lemma (in Semilat) plus_le_conv [simp]:
  "\<lbrakk> x \<in> A; y \<in> A; z \<in> A \<rbrakk> \<Longrightarrow> (x \<squnion>\<^sub>f y \<sqsubseteq>\<^sub>r z) = (x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z)"
  (*<*) by (blast intro: ub1 ub2 lub order_trans) (*>*)

lemma (in Semilat) le_iff_plus_unchanged: "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> (x \<sqsubseteq>\<^sub>r y) = (x \<squnion>\<^sub>f y = y)"
(*<*)
apply (rule iffI)
 apply (blast intro: antisym_r lub ub2)
apply (erule subst)
apply simp
done
(*>*)

lemma (in Semilat) le_iff_plus_unchanged2: "\<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> (x \<sqsubseteq>\<^sub>r y) = (y \<squnion>\<^sub>f x = y)"
(*<*)
apply (rule iffI)
 apply (blast intro: order_antisym lub ub1)
apply (erule subst)
apply simp
done
(*>*)

lemma (in Semilat) plus_assoc [simp]:
  assumes a: "a \<in> A" and b: "b \<in> A" and c: "c \<in> A"
  shows "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) = a \<squnion>\<^sub>f b \<squnion>\<^sub>f c"
(*<*)
proof -
  from a b have ab: "a \<squnion>\<^sub>f b \<in> A" ..
  from this c have abc: "(a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c \<in> A" ..
  from b c have bc: "b \<squnion>\<^sub>f c \<in> A" ..
  from a this have abc': "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) \<in> A" ..

  show ?thesis
  proof
    show "a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c) \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c"
    proof -
      from a b have "a \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f b" ..
      also from ab c have "\<dots> \<sqsubseteq>\<^sub>r \<dots> \<squnion>\<^sub>f c" ..
      finally have "a<": "a \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" .
      from a b have "b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f b" ..
      also from ab c have "\<dots> \<sqsubseteq>\<^sub>r \<dots> \<squnion>\<^sub>f c" ..
      finally have "b<": "b \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" .
      from ab c have "c<": "c \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" ..
      from "b<" "c<" b c abc have "b \<squnion>\<^sub>f c \<sqsubseteq>\<^sub>r (a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c" ..
      from "a<" this a bc abc show ?thesis ..
    qed
    show "(a \<squnion>\<^sub>f b) \<squnion>\<^sub>f c \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)"
    proof -
      from b c have "b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f c" ..
      also from a bc have "\<dots> \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f \<dots>" ..
      finally have "b<": "b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" .
      from b c have "c \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f c" ..
      also from a bc have "\<dots> \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f \<dots>" ..
      finally have "c<": "c \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" .
      from a bc have "a<": "a \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" ..
      from "a<" "b<" a b abc' have "a \<squnion>\<^sub>f b \<sqsubseteq>\<^sub>r a \<squnion>\<^sub>f (b \<squnion>\<^sub>f c)" ..
      from this "c<" ab c abc' show ?thesis ..
    qed
  qed
qed
(*>*)

lemma (in Semilat) plus_com_lemma:
  "\<lbrakk>a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> a \<squnion>\<^sub>f b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a"
(*<*)
proof -
  assume a: "a \<in> A" and b: "b \<in> A"
  from b a have "a \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a" ..
  moreover from b a have "b \<sqsubseteq>\<^sub>r b \<squnion>\<^sub>f a" ..
  moreover note a b
  moreover from b a have "b \<squnion>\<^sub>f a \<in> A" ..
  ultimately show ?thesis ..
qed
(*>*)

lemma (in Semilat) plus_commutative:
  "\<lbrakk>a \<in> A; b \<in> A\<rbrakk> \<Longrightarrow> a \<squnion>\<^sub>f b = b \<squnion>\<^sub>f a"
  (*<*) by(blast intro: order_antisym plus_com_lemma) (*>*)

lemma is_lubD:
  "is_lub r x y u \<Longrightarrow> is_ub r x y u \<and> (\<forall>z. is_ub r x y z \<longrightarrow> (u,z) \<in> r)"
  (*<*) by (simp add: is_lub_def) (*>*)

lemma is_ubI:
  "\<lbrakk> (x,u) \<in> r; (y,u) \<in> r \<rbrakk> \<Longrightarrow> is_ub r x y u"
  (*<*) by (simp add: is_ub_def) (*>*)

lemma is_ubD:
  "is_ub r x y u \<Longrightarrow> (x,u) \<in> r \<and> (y,u) \<in> r"
  (*<*) by (simp add: is_ub_def) (*>*)

lemma is_lub_bigger1 [iff]:
  "is_lub (r\<^sup>*) x y y = ((x,y)\<in>r\<^sup>*)"
(*<*)
apply (unfold is_lub_def is_ub_def)
apply blast
done
(*>*)

lemma is_lub_bigger2 [iff]:
  "is_lub (r\<^sup>*) x y x = ((y,x)\<in>r\<^sup>*)"
(*<*)
apply (unfold is_lub_def is_ub_def)
apply blast
done
(*>*)

lemma extend_lub:
  "\<lbrakk> single_valued r; is_lub (r\<^sup>*) x y u; (x',x) \<in> r \<rbrakk>
  \<Longrightarrow> \<exists>v. is_lub (r\<^sup>*) x' y v"
(*<*)
apply (unfold is_lub_def is_ub_def)
apply (case_tac "(y,x) \<in> r\<^sup>*")
 apply (case_tac "(y,x') \<in> r\<^sup>*")
  apply blast
 apply (blast elim: converse_rtranclE dest: single_valuedD)
apply (rule exI)
apply (rule conjI)
 apply (blast intro: converse_rtrancl_into_rtrancl dest: single_valuedD)
apply (blast intro: rtrancl_into_rtrancl converse_rtrancl_into_rtrancl
             elim: converse_rtranclE dest: single_valuedD)
done
(*>*)

lemma single_valued_has_lubs [rule_format]:
  "\<lbrakk>single_valued r; (x,u) \<in> r\<^sup>*\<rbrakk> \<Longrightarrow> (\<forall>y. (y,u) \<in> r\<^sup>* \<longrightarrow>
  (\<exists>z. is_lub (r\<^sup>*) x y z))"
(*<*)
apply (erule converse_rtrancl_induct)
 apply clarify
 apply (erule converse_rtrancl_induct)
  apply blast
 apply (blast intro: converse_rtrancl_into_rtrancl)
apply (blast intro: extend_lub)
done
(*>*)

lemma some_lub_conv:
  "\<lbrakk>acyclic r; is_lub (r\<^sup>*) x y u\<rbrakk> \<Longrightarrow> some_lub (r\<^sup>*) x y = u"
(*<*)
apply (unfold some_lub_def is_lub_def)
apply (rule someI2)
 apply assumption
apply (blast intro: antisymD dest!: acyclic_impl_antisym_rtrancl)
done
(*>*)

lemma is_lub_some_lub:
  "\<lbrakk>single_valued r; acyclic r; (x,u)\<in>r\<^sup>*; (y,u)\<in>r\<^sup>*\<rbrakk>
  \<Longrightarrow> is_lub (r\<^sup>*) x y (some_lub (r\<^sup>*) x y)"
  (*<*) by (fastforce dest: single_valued_has_lubs simp add: some_lub_conv) (*>*)

subsection\<open>An executable lub-finder\<close>

definition exec_lub :: "('a * 'a) set \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a binop" where
"exec_lub r f x y \<equiv> while (\<lambda>z. (x,z) \<notin> r\<^sup>*) f y"

lemma exec_lub_refl: "exec_lub r f T T = T"
by (simp add: exec_lub_def while_unfold)

lemma acyclic_single_valued_finite:
 "\<lbrakk>acyclic r; single_valued r; (x,y) \<in> r\<^sup>*\<rbrakk>
  \<Longrightarrow> finite (r \<inter> {a. (x, a) \<in> r\<^sup>*} \<times> {b. (b, y) \<in> r\<^sup>*})"
(*<*)
apply(erule converse_rtrancl_induct)
 apply(rule_tac B = "{}" in finite_subset)
  apply(simp only:acyclic_def)
  apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
 apply simp
apply(rename_tac x x')
apply(subgoal_tac "r \<inter> {a. (x,a) \<in> r\<^sup>*} \<times> {b. (b,y) \<in> r\<^sup>*} =
                   insert (x,x') (r \<inter> {a. (x', a) \<in> r\<^sup>*} \<times> {b. (b, y) \<in> r\<^sup>*})")
 apply simp
apply(blast intro:converse_rtrancl_into_rtrancl
            elim:converse_rtranclE dest:single_valuedD)
done
(*>*)

lemma exec_lub_conv:
  "\<lbrakk> acyclic r; \<forall>x y. (x,y) \<in> r \<longrightarrow> f x = y; is_lub (r\<^sup>*) x y u \<rbrakk> \<Longrightarrow>
  exec_lub r f x y = u"
(*<*)
apply(unfold exec_lub_def)
apply(rule_tac P = "\<lambda>z. (y,z) \<in> r\<^sup>* \<and> (z,u) \<in> r\<^sup>*" and
               r = "(r \<inter> {(a,b). (y,a) \<in> r\<^sup>* \<and> (b,u) \<in> r\<^sup>*})\<inverse>" in while_rule)
    apply(blast dest: is_lubD is_ubD)
   apply(erule conjE)
   apply(erule_tac z = u in converse_rtranclE)
    apply(blast dest: is_lubD is_ubD)
   apply(blast dest:rtrancl_into_rtrancl)
  apply(rename_tac s)
  apply(subgoal_tac "is_ub (r\<^sup>*) x y s")
   prefer 2 apply(simp add:is_ub_def)
  apply(subgoal_tac "(u, s) \<in> r\<^sup>*")
   prefer 2 apply(blast dest:is_lubD)
  apply(erule converse_rtranclE)
   apply blast
  apply(simp only:acyclic_def)
  apply(blast intro:rtrancl_into_trancl2 rtrancl_trancl_trancl)
 apply(rule finite_acyclic_wf)
  apply simp
  apply(erule acyclic_single_valued_finite)
   apply(blast intro:single_valuedI)
  apply(simp add:is_lub_def is_ub_def)
 apply simp
 apply(erule acyclic_subset)
 apply blast
apply simp
apply(erule conjE)
apply(erule_tac z = u in converse_rtranclE)
 apply(blast dest: is_lubD is_ubD)
apply(blast dest:rtrancl_into_rtrancl)
done
(*>*)

lemma is_lub_exec_lub:
  "\<lbrakk> single_valued r; acyclic r; (x,u)\<in>r\<^sup>*; (y,u)\<in>r\<^sup>*; \<forall>x y. (x,y) \<in> r \<longrightarrow> f x = y \<rbrakk>
  \<Longrightarrow> is_lub (r\<^sup>*) x y (exec_lub r f x y)"
  (*<*) by (fastforce dest: single_valued_has_lubs simp add: exec_lub_conv) (*>*)

end


(*  Title:      HOL/Quotient_Examples/Lift_FSet.thy
    Author:     Brian Huffman, TU Munich
*)

section \<open>Lifting and transfer with a finite set type\<close>

theory Lift_FSet
imports Main
begin

subsection \<open>Equivalence relation and quotient type definition\<close>

definition list_eq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where [simp]: "list_eq xs ys \<longleftrightarrow> set xs = set ys"

lemma reflp_list_eq: "reflp list_eq"
  unfolding reflp_def by simp

lemma symp_list_eq: "symp list_eq"
  unfolding symp_def by simp

lemma transp_list_eq: "transp list_eq"
  unfolding transp_def by simp

lemma equivp_list_eq: "equivp list_eq"
  by (intro equivpI reflp_list_eq symp_list_eq transp_list_eq)

context includes lifting_syntax
begin

lemma list_eq_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "(list_all2 A ===> list_all2 A ===> (=)) list_eq list_eq"
  unfolding list_eq_def [abs_def] by transfer_prover

quotient_type 'a fset = "'a list" / "list_eq" parametric list_eq_transfer
  by (rule equivp_list_eq)

subsection \<open>Lifted constant definitions\<close>

lift_definition fnil :: "'a fset" ("{||}") is "[]" parametric list.ctr_transfer(1) .

lift_definition fcons :: "'a \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is Cons parametric list.ctr_transfer(2)
  by simp

lift_definition fappend :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is append parametric append_transfer
  by simp

lift_definition fmap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a fset \<Rightarrow> 'b fset" is map parametric list.map_transfer
  by simp

lift_definition ffilter :: "('a \<Rightarrow> bool) \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is filter parametric filter_transfer
  by simp

lift_definition fset :: "'a fset \<Rightarrow> 'a set" is set parametric list.set_transfer
  by simp

text \<open>Constants with nested types (like concat) yield a more
  complicated proof obligation.\<close>

lemma list_all2_cr_fset:
  "list_all2 cr_fset xs ys \<longleftrightarrow> map abs_fset xs = ys"
  unfolding cr_fset_def
  apply safe
  apply (erule list_all2_induct, simp, simp)
  apply (simp add: list_all2_map2 List.list_all2_refl)
  done

lemma abs_fset_eq_iff: "abs_fset xs = abs_fset ys \<longleftrightarrow> list_eq xs ys"
  using Quotient_rel [OF Quotient_fset] by simp

lift_definition fconcat :: "'a fset fset \<Rightarrow> 'a fset" is concat parametric concat_transfer
proof (simp only: fset.pcr_cr_eq)
  fix xss yss :: "'a list list"
  assume "(list_all2 cr_fset OO list_eq OO (list_all2 cr_fset)\<inverse>\<inverse>) xss yss"
  then obtain uss vss where
    "list_all2 cr_fset xss uss" and "list_eq uss vss" and
    "list_all2 cr_fset yss vss" by clarsimp
  hence "list_eq (map abs_fset xss) (map abs_fset yss)"
    unfolding list_all2_cr_fset by simp
  thus "list_eq (concat xss) (concat yss)"
    apply (simp add: set_eq_iff image_def)
    apply safe
    apply (rename_tac xs, drule_tac x="abs_fset xs" in spec)
    apply (drule iffD1, fast, clarsimp simp add: abs_fset_eq_iff, fast)
    apply (rename_tac xs, drule_tac x="abs_fset xs" in spec)
    apply (drule iffD2, fast, clarsimp simp add: abs_fset_eq_iff, fast)
    done
qed

lemma member_transfer:
  assumes [transfer_rule]: "bi_unique A"
  shows "(A ===> list_all2 A ===> (=)) (\<lambda>x xs. x \<in> set xs) (\<lambda>x xs. x \<in> set xs)"
by transfer_prover

end

syntax
  "_insert_fset"     :: "args => 'a fset"  ("{|(_)|}")

translations
  "{|x, xs|}" == "CONST fcons x {|xs|}"
  "{|x|}"     == "CONST fcons x {||}"

lift_definition fmember :: "'a \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<in>|" 50) is "\<lambda>x xs. x \<in> set xs"
   parametric member_transfer by simp

abbreviation notin_fset :: "'a \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<notin>|" 50) where
  "x |\<notin>| S \<equiv> \<not> (x |\<in>| S)"

lemma fmember_fmap[simp]: "a |\<in>| fmap f X = (\<exists>b. b |\<in>| X \<and> a = f b)"
  by transfer auto

text \<open>We can export code:\<close>

export_code fnil fcons fappend fmap ffilter fset fmember in SML file_prefix fset

subsection \<open>Using transfer with type \<open>fset\<close>\<close>

text \<open>The correspondence relation \<open>cr_fset\<close> can only relate
  \<open>list\<close> and \<open>fset\<close> types with the same element type.
  To relate nested types like \<open>'a list list\<close> and
  \<open>'a fset fset\<close>, we define a parameterized version of the
  correspondence relation, \<open>pcr_fset\<close>.\<close>

thm pcr_fset_def

subsection \<open>Transfer examples\<close>

text \<open>The \<open>transfer\<close> method replaces equality on \<open>fset\<close> with the \<open>list_eq\<close> relation on lists, which is
  logically equivalent.\<close>

lemma "fmap f (fmap g xs) = fmap (f \<circ> g) xs"
  apply transfer
  apply simp
  done

text \<open>The \<open>transfer'\<close> variant can replace equality on \<open>fset\<close> with equality on \<open>list\<close>, which is logically stronger
  but sometimes more convenient.\<close>

lemma "fmap f (fmap g xs) = fmap (f \<circ> g) xs"
  using map_map [Transfer.transferred] .

lemma "ffilter p (fmap f xs) = fmap f (ffilter (p \<circ> f) xs)"
  using filter_map [Transfer.transferred] .

lemma "ffilter p (ffilter q xs) = ffilter (\<lambda>x. q x \<and> p x) xs"
  using filter_filter [Transfer.transferred] .

lemma "fset (fcons x xs) = insert x (fset xs)"
  using list.set(2) [Transfer.transferred] .

lemma "fset (fappend xs ys) = fset xs \<union> fset ys"
  using set_append [Transfer.transferred] .

lemma "fset (fconcat xss) = (\<Union>xs\<in>fset xss. fset xs)"
  using set_concat [Transfer.transferred] .

lemma "\<forall>x\<in>fset xs. f x = g x \<Longrightarrow> fmap f xs = fmap g xs"
  apply transfer
  apply (simp cong: map_cong del: set_map)
  done

lemma "fnil = fconcat xss \<longleftrightarrow> (\<forall>xs\<in>fset xss. xs = fnil)"
  apply transfer
  apply simp
  done

lemma "fconcat (fmap (\<lambda>x. fcons x fnil) xs) = xs"
  apply transfer
  apply simp
  done

lemma concat_map_concat: "concat (map concat xsss) = concat (concat xsss)"
  by (induct xsss, simp_all)

lemma "fconcat (fmap fconcat xss) = fconcat (fconcat xss)"
  using concat_map_concat [Transfer.transferred] .

end


(* Author: Florian Haftmann, TU Muenchen *)

header {* Some basic facts about discrete summation *}

theory Summation
imports Main
begin

subsection {* Auxiliary *}

lemma add_setsum_orient:
  "setsum f {k..<j} + setsum f {l..<k} = setsum f {l..<k} + setsum f {k..<j}"
  by (fact add.commute)

lemma add_setsum_int:
  fixes j k l :: int
  shows "j < k \<Longrightarrow> k < l \<Longrightarrow>
    setsum f {j..<k} + setsum f {k..<l} = setsum f {j..<l}"
  by (simp_all add: setsum.union_inter [symmetric] ivl_disj_un)

subsection {* The shift operator *}

definition \<Delta> :: "('b\<Colon>ring_1 \<Rightarrow> 'a\<Colon>ab_group_add) \<Rightarrow> int \<Rightarrow> 'a"
where
  "\<Delta> f k = f (of_int (k + 1)) - f (of_int k)"

lemma \<Delta>_shift:
  "\<Delta> (\<lambda>k. l + f k) = \<Delta> f"
  by (simp add: \<Delta>_def fun_eq_iff)

lemma \<Delta>_same_shift:
  assumes "\<Delta> f = \<Delta> g"
  shows "\<exists>l. plus l \<circ> f \<circ> of_int = g \<circ> of_int"
proof -
  let ?F = "\<lambda>k. f (of_int k)"
  let ?G = "\<lambda>k. g (of_int k)"
  from assms have "\<And>k. \<Delta> f (of_int k) = \<Delta> g (of_int k)" by simp
  then have k_incr: "\<And>k. ?F (k + 1) - ?G (k + 1) = ?F k - ?G k"
    by (simp add: \<Delta>_def algebra_simps)
  then have "\<And>k. ?F ((k - 1) + 1) - ?G ((k - 1) + 1) =
    ?F (k - 1) - ?G (k - 1)"
    by blast
  then have k_decr: "\<And>k. ?F (k - 1) - ?G (k - 1) = ?F k - ?G k"
    by simp
  have "\<And>k. ?F k - ?G k = ?F 0 - ?G 0"
  proof -
    fix k
    show "?F k - ?G k = ?F 0 - ?G 0"
      by (induct k rule: int_induct)
        (simp_all add: k_incr k_decr del: of_int_add of_int_diff of_int_0)
  qed
  then have "\<And>k. (plus (?G 0 - ?F 0) \<circ> ?F) k = ?G k"
    by (simp add: algebra_simps)
  then have "plus (?G 0 - ?F 0) \<circ> ?F = ?G" ..
  then have "plus (?G 0 - ?F 0) \<circ> f \<circ> of_int = g \<circ> of_int"
    by (simp only: comp_def)
  then show ?thesis ..
qed

lemma \<Delta>_add:
  "\<Delta> (\<lambda>k. f k + g k) k = \<Delta> f k + \<Delta> g k"
  by (simp add: \<Delta>_def)

lemma \<Delta>_factor:
  "\<Delta> (\<lambda>k. c * k) k = c"
  by (simp add: \<Delta>_def algebra_simps)

subsection {* The formal sum operator *}

definition \<Sigma> :: "('b\<Colon>ring_1 \<Rightarrow> 'a\<Colon>ab_group_add) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> 'a"
where
  "\<Sigma> f j l = (if j < l then setsum (f \<circ> of_int) {j..<l}
    else if j > l then - setsum (f \<circ> of_int) {l..<j}
    else 0)"

lemma \<Sigma>_same [simp]:
  "\<Sigma> f j j = 0"
  by (simp add: \<Sigma>_def)

lemma \<Sigma>_negative:
  "j > l \<Longrightarrow> \<Sigma> f j l = - \<Sigma> f l j"
  by (simp add: \<Sigma>_def)

lemma \<Sigma>_comp_of_int:
  "\<Sigma> (f \<circ> of_int) = \<Sigma> f"
  by (simp add: \<Sigma>_def fun_eq_iff)

lemma \<Sigma>_const:
  "\<Sigma> (\<lambda>k. c) j l = of_int (l - j) * c"
  by (simp add: \<Sigma>_def algebra_simps of_nat_nat)

lemma \<Sigma>_add:
  "\<Sigma> (\<lambda>k. f k + g k) j l = \<Sigma> f j l + \<Sigma> g j l"
  by (simp add: \<Sigma>_def setsum.distrib)

lemma \<Sigma>_factor:
  "\<Sigma> (\<lambda>k. c * f k) j l = (c::'a::ring) * \<Sigma> (\<lambda>k. f k) j l"
  by (simp add: \<Sigma>_def setsum_right_distrib)

lemma \<Sigma>_concat:
  "\<Sigma> f j k + \<Sigma> f k l = \<Sigma> f j l"
  by (simp add: \<Sigma>_def algebra_simps add_setsum_int)
    (simp_all add: add_setsum_orient [of "\<lambda>k. f (of_int k)" k j l]
      add_setsum_orient [of "\<lambda>k. f (of_int k)" j l k]
      add_setsum_orient [of "\<lambda>k. f (of_int k)" j k l] add_setsum_int)

lemma \<Sigma>_incr_upper:
  "\<Sigma> f j (l + 1) = \<Sigma> f j l + f (of_int l)"
proof -
  have "{l..<l+1} = {l}" by auto
  then have "\<Sigma> f l (l + 1) = f (of_int l)" by (simp add: \<Sigma>_def)
  moreover have "\<Sigma> f j (l + 1) = \<Sigma> f j l + \<Sigma> f l (l + 1)" by (simp add: \<Sigma>_concat)
  ultimately show ?thesis by simp
qed

subsection {* Fundamental lemmas: The relation between @{term \<Delta>} and @{term \<Sigma>} *}

lemma \<Delta>_\<Sigma>:
  "\<Delta> (\<Sigma> f j) = f"
proof
  fix k
  show "\<Delta> (\<Sigma> f j) k = f k"
    by (simp add: \<Delta>_def \<Sigma>_incr_upper)
qed

lemma \<Sigma>_\<Delta>:
  "\<Sigma> (\<Delta> f) j l = f (of_int l) - f (of_int j)"
proof -
  from \<Delta>_\<Sigma> have "\<Delta> (\<Sigma> (\<Delta> f) j) = \<Delta> f" .
  then obtain k where "plus k \<circ> \<Sigma> (\<Delta> f) j \<circ> of_int = f \<circ> of_int"
    by (blast dest: \<Delta>_same_shift)
  then have "\<And>q. f (of_int q) = k + \<Sigma> (\<Delta> f) j q"
    by (simp add: fun_eq_iff)
  then show ?thesis by simp
qed

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Alignment With Definitions from HOL.Main\<close>
theory HOL_Alignment_Functions
  imports
    HOL_Alignment_Binary_Relations
    HOL_Syntax_Bundles_Functions
    LFunctions
begin

unbundle no_HOL_function_syntax

named_theorems HOL_fun_alignment

paragraph \<open>Functions\<close>

subparagraph \<open>Bijection\<close>

overloading
  bijection_on_set \<equiv> "bijection_on :: 'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> bool"
begin
  definition "bijection_on_set (S :: 'a set) (S' :: 'b set) :: ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> bool \<equiv>
    bijection_on (mem_of S) (mem_of S')"
end

lemma bijection_on_set_eq_bijection_on_pred [simp]:
  "(bijection_on (S :: 'a set) (S' :: 'b set) :: ('a \<Rightarrow> 'b) \<Rightarrow> _) =
    bijection_on (mem_of S) (mem_of S')"
  unfolding bijection_on_set_def by simp

lemma bijection_on_set_iff_bijection_on_pred [iff]:
  "bijection_on (S :: 'a set) (S' :: 'b set) (f :: 'a \<Rightarrow> 'b) g \<longleftrightarrow>
    bijection_on (mem_of S) (mem_of S') f g"
  by simp

lemma bij_betw_bijection_onE:
  assumes "bij_betw f S S'"
  obtains g where "bijection_on S S' f g"
proof
  let ?g = "the_inv_into S f"
  from assms bij_betw_the_inv_into have "bij_betw ?g S' S" by blast
  with assms show "bijection_on S S' f ?g"
    by (auto intro!: bijection_onI
      dest: bij_betw_apply bij_betw_imp_inj_on the_inv_into_f_f
      simp: f_the_inv_into_f_bij_betw)
qed

lemma bij_betw_if_bijection_on:
  assumes "bijection_on S S' f g"
  shows "bij_betw f S S'"
  using assms by (intro bij_betw_byWitness[where ?f'=g])
  (auto elim: bijection_onE dest: inverse_onD)

corollary bij_betw_iff_ex_bijection_on [HOL_fun_alignment]:
  "bij_betw f S S' \<longleftrightarrow> (\<exists>g. bijection_on S S' f g)"
  by (intro iffI)
  (auto elim!: bij_betw_bijection_onE intro: bij_betw_if_bijection_on)

subparagraph \<open>Injective\<close>

overloading
  injective_on_set \<equiv> "injective_on :: 'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
begin
  definition "injective_on_set (S :: 'a set) :: ('a \<Rightarrow> 'b) \<Rightarrow> bool \<equiv>
    injective_on (mem_of S)"
end

lemma injective_on_set_eq_injective_on_pred [simp]:
  "(injective_on (S :: 'a set) :: ('a \<Rightarrow> 'b) \<Rightarrow> _) = injective_on (mem_of S)"
  unfolding injective_on_set_def by simp

lemma injective_on_set_iff_injective_on_pred [iff]:
  "injective_on (S :: 'a set) (f :: 'a \<Rightarrow> 'b) \<longleftrightarrow> injective_on (mem_of S) f"
  by simp

lemma inj_on_iff_injective_on [HOL_fun_alignment]: "inj_on f P \<longleftrightarrow> injective_on P f"
  by (auto intro: inj_onI dest: inj_onD injective_onD)

lemma inj_eq_injective [HOL_fun_alignment]: "inj = injective"
  by (auto intro: injI dest: injD injectiveD)

subparagraph \<open>Inverse\<close>

overloading
  inverse_on_set \<equiv> "inverse_on :: 'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> bool"
begin
  definition "inverse_on_set (S :: 'a set) :: ('a \<Rightarrow> 'b) \<Rightarrow> _ \<equiv>
    inverse_on (mem_of S)"
end

lemma inverse_on_set_eq_inverse_on_pred [simp]:
  "(inverse_on (S :: 'a set) :: ('a \<Rightarrow> 'b) \<Rightarrow> _) = inverse_on (mem_of S)"
  unfolding inverse_on_set_def by simp

lemma inverse_on_set_iff_inverse_on_pred [iff]:
  "inverse_on (S :: 'a set) (f :: 'a \<Rightarrow> 'b) g \<longleftrightarrow> inverse_on (mem_of S) f g"
  by simp

subparagraph \<open>Monotone\<close>

lemma monotone_on_eq_mono_wrt_rel_restrict_left_right [HOL_fun_alignment]:
  "monotone_on S R = mono_wrt_rel (R\<restriction>\<^bsub>S\<^esub>\<upharpoonleft>\<^bsub>S\<^esub>)"
  unfolding restrict_right_eq
  by (intro ext) (blast intro: monotone_onI dest: monotone_onD)

lemma monotone_eq_mono_wrt_rel [HOL_fun_alignment]: "monotone = mono_wrt_rel"
  by (intro ext) (auto intro: monotoneI dest: monotoneD)

lemma pred_fun_eq_mono_wrt_pred [HOL_fun_alignment]: "pred_fun = mono_wrt_pred"
  by (intro ext) auto

lemma Fun_mono_eq_mono [HOL_fun_alignment]: "Fun.mono = mono"
  by (intro ext) (auto intro: Fun.mono_onI dest: Fun.monoD)

lemma Fun_antimono_eq_antimono [HOL_fun_alignment]: "Fun.antimono = antimono"
  by (intro ext) (auto intro: monotoneI dest: monotoneD)

subparagraph \<open>Surjective\<close>

overloading
  surjective_at_set \<equiv> "surjective_at :: 'a set \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> bool"
begin
  definition "surjective_at_set (S :: 'a set) :: ('b \<Rightarrow> 'a) \<Rightarrow> bool \<equiv>
    surjective_at (mem_of S)"
end

lemma surjective_at_set_eq_surjective_at_pred [simp]:
  "(surjective_at (S :: 'a set) :: ('b \<Rightarrow> 'a) \<Rightarrow> _) = surjective_at (mem_of S)"
  unfolding surjective_at_set_def by simp

lemma surjective_at_set_iff_surjective_at_pred [iff]:
  "surjective_at (S :: 'a set) (f :: 'b \<Rightarrow> 'a) \<longleftrightarrow> surjective_at (mem_of S) f"
  by simp

lemma surj_eq_surjective [HOL_fun_alignment]: "surj = surjective"
  by (intro ext) (fast intro: surjI dest: surjD elim: surjectiveE)

paragraph \<open>Functions\<close>

lemma Fun_id_eq_id [HOL_fun_alignment]: "Fun.id = Functions_Base.id"
  by (intro ext) simp

lemma Fun_comp_eq_comp [HOL_fun_alignment]: "Fun.comp = Functions_Base.comp"
  by (intro ext) simp

lemma map_fun_eq_fun_map [HOL_fun_alignment]: "map_fun = fun_map"
  by (intro ext) simp

paragraph \<open>Relators\<close>

lemma rel_fun_eq_Fun_Rel_rel [HOL_fun_alignment]: "rel_fun = Fun_Rel_rel"
  by (intro ext) (auto dest: rel_funD)

end