(*  Title:      HOL/HOLCF/Porder.thy
    Author:     Franz Regensburger and Brian Huffman
*)

section \<open>Partial orders\<close>

theory Porder
  imports Main
begin

declare [[typedef_overloaded]]

subsection \<open>Type class for partial orders\<close>

class below =
  fixes below :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

notation (ASCII)
  below (infix "<<" 50)

notation
  below (infix "\<sqsubseteq>" 50)

abbreviation not_below :: "'a \<Rightarrow> 'a \<Rightarrow> bool"  (infix "\<notsqsubseteq>" 50)
  where "not_below x y \<equiv> \<not> below x y"

notation (ASCII)
  not_below  (infix "~<<" 50)

lemma below_eq_trans: "a \<sqsubseteq> b \<Longrightarrow> b = c \<Longrightarrow> a \<sqsubseteq> c"
  by (rule subst)

lemma eq_below_trans: "a = b \<Longrightarrow> b \<sqsubseteq> c \<Longrightarrow> a \<sqsubseteq> c"
  by (rule ssubst)

end

class po = below +
  assumes below_refl [iff]: "x \<sqsubseteq> x"
  assumes below_trans: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z"
  assumes below_antisym: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> x \<Longrightarrow> x = y"
begin

lemma eq_imp_below: "x = y \<Longrightarrow> x \<sqsubseteq> y"
  by simp

lemma box_below: "a \<sqsubseteq> b \<Longrightarrow> c \<sqsubseteq> a \<Longrightarrow> b \<sqsubseteq> d \<Longrightarrow> c \<sqsubseteq> d"
  by (rule below_trans [OF below_trans])

lemma po_eq_conv: "x = y \<longleftrightarrow> x \<sqsubseteq> y \<and> y \<sqsubseteq> x"
  by (fast intro!: below_antisym)

lemma rev_below_trans: "y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> x \<sqsubseteq> z"
  by (rule below_trans)

lemma not_below2not_eq: "x \<notsqsubseteq> y \<Longrightarrow> x \<noteq> y"
  by auto

end

lemmas HOLCF_trans_rules [trans] =
  below_trans
  below_antisym
  below_eq_trans
  eq_below_trans

context po
begin

subsection \<open>Upper bounds\<close>

definition is_ub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix "<|" 55)
  where "S <| x \<longleftrightarrow> (\<forall>y\<in>S. y \<sqsubseteq> x)"

lemma is_ubI: "(\<And>x. x \<in> S \<Longrightarrow> x \<sqsubseteq> u) \<Longrightarrow> S <| u"
  by (simp add: is_ub_def)

lemma is_ubD: "\<lbrakk>S <| u; x \<in> S\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
  by (simp add: is_ub_def)

lemma ub_imageI: "(\<And>x. x \<in> S \<Longrightarrow> f x \<sqsubseteq> u) \<Longrightarrow> (\<lambda>x. f x) ` S <| u"
  unfolding is_ub_def by fast

lemma ub_imageD: "\<lbrakk>f ` S <| u; x \<in> S\<rbrakk> \<Longrightarrow> f x \<sqsubseteq> u"
  unfolding is_ub_def by fast

lemma ub_rangeI: "(\<And>i. S i \<sqsubseteq> x) \<Longrightarrow> range S <| x"
  unfolding is_ub_def by fast

lemma ub_rangeD: "range S <| x \<Longrightarrow> S i \<sqsubseteq> x"
  unfolding is_ub_def by fast

lemma is_ub_empty [simp]: "{} <| u"
  unfolding is_ub_def by fast

lemma is_ub_insert [simp]: "(insert x A) <| y = (x \<sqsubseteq> y \<and> A <| y)"
  unfolding is_ub_def by fast

lemma is_ub_upward: "\<lbrakk>S <| x; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> S <| y"
  unfolding is_ub_def by (fast intro: below_trans)

subsection \<open>Least upper bounds\<close>

definition is_lub :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix "<<|" 55)
  where "S <<| x \<longleftrightarrow> S <| x \<and> (\<forall>u. S <| u \<longrightarrow> x \<sqsubseteq> u)"

definition lub :: "'a set \<Rightarrow> 'a"
  where "lub S = (THE x. S <<| x)"

end

syntax (ASCII)
  "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3LUB _:_./ _)" [0,0, 10] 10)

syntax
  "_BLub" :: "[pttrn, 'a set, 'b] \<Rightarrow> 'b" ("(3\<Squnion>_\<in>_./ _)" [0,0, 10] 10)

translations
  "LUB x:A. t" \<rightleftharpoons> "CONST lub ((\<lambda>x. t) ` A)"

context po
begin

abbreviation Lub  (binder "\<Squnion>" 10)
  where "\<Squnion>n. t n \<equiv> lub (range t)"

notation (ASCII)
  Lub  (binder "LUB " 10)

text \<open>access to some definition as inference rule\<close>

lemma is_lubD1: "S <<| x \<Longrightarrow> S <| x"
  unfolding is_lub_def by fast

lemma is_lubD2: "\<lbrakk>S <<| x; S <| u\<rbrakk> \<Longrightarrow> x \<sqsubseteq> u"
  unfolding is_lub_def by fast

lemma is_lubI: "\<lbrakk>S <| x; \<And>u. S <| u \<Longrightarrow> x \<sqsubseteq> u\<rbrakk> \<Longrightarrow> S <<| x"
  unfolding is_lub_def by fast

lemma is_lub_below_iff: "S <<| x \<Longrightarrow> x \<sqsubseteq> u \<longleftrightarrow> S <| u"
  unfolding is_lub_def is_ub_def by (metis below_trans)

text \<open>lubs are unique\<close>

lemma is_lub_unique: "S <<| x \<Longrightarrow> S <<| y \<Longrightarrow> x = y"
  unfolding is_lub_def is_ub_def by (blast intro: below_antisym)

text \<open>technical lemmas about \<^term>\<open>lub\<close> and \<^term>\<open>is_lub\<close>\<close>

lemma is_lub_lub: "M <<| x \<Longrightarrow> M <<| lub M"
  unfolding lub_def by (rule theI [OF _ is_lub_unique])

lemma lub_eqI: "M <<| l \<Longrightarrow> lub M = l"
  by (rule is_lub_unique [OF is_lub_lub])

lemma is_lub_singleton [simp]: "{x} <<| x"
  by (simp add: is_lub_def)

lemma lub_singleton [simp]: "lub {x} = x"
  by (rule is_lub_singleton [THEN lub_eqI])

lemma is_lub_bin: "x \<sqsubseteq> y \<Longrightarrow> {x, y} <<| y"
  by (simp add: is_lub_def)

lemma lub_bin: "x \<sqsubseteq> y \<Longrightarrow> lub {x, y} = y"
  by (rule is_lub_bin [THEN lub_eqI])

lemma is_lub_maximal: "S <| x \<Longrightarrow> x \<in> S \<Longrightarrow> S <<| x"
  by (erule is_lubI, erule (1) is_ubD)

lemma lub_maximal: "S <| x \<Longrightarrow> x \<in> S \<Longrightarrow> lub S = x"
  by (rule is_lub_maximal [THEN lub_eqI])

subsection \<open>Countable chains\<close>

definition chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
  where \<comment> \<open>Here we use countable chains and I prefer to code them as functions!\<close>
  "chain Y = (\<forall>i. Y i \<sqsubseteq> Y (Suc i))"

lemma chainI: "(\<And>i. Y i \<sqsubseteq> Y (Suc i)) \<Longrightarrow> chain Y"
  unfolding chain_def by fast

lemma chainE: "chain Y \<Longrightarrow> Y i \<sqsubseteq> Y (Suc i)"
  unfolding chain_def by fast

text \<open>chains are monotone functions\<close>

lemma chain_mono_less: "chain Y \<Longrightarrow> i < j \<Longrightarrow> Y i \<sqsubseteq> Y j"
  by (erule less_Suc_induct, erule chainE, erule below_trans)

lemma chain_mono: "chain Y \<Longrightarrow> i \<le> j \<Longrightarrow> Y i \<sqsubseteq> Y j"
  by (cases "i = j") (simp_all add: chain_mono_less)

lemma chain_shift: "chain Y \<Longrightarrow> chain (\<lambda>i. Y (i + j))"
  by (rule chainI, simp, erule chainE)

text \<open>technical lemmas about (least) upper bounds of chains\<close>

lemma is_lub_rangeD1: "range S <<| x \<Longrightarrow> S i \<sqsubseteq> x"
  by (rule is_lubD1 [THEN ub_rangeD])

lemma is_ub_range_shift: "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <| x = range S <| x"
  apply (rule iffI)
   apply (rule ub_rangeI)
   apply (rule_tac y="S (i + j)" in below_trans)
    apply (erule chain_mono)
    apply (rule le_add1)
   apply (erule ub_rangeD)
  apply (rule ub_rangeI)
  apply (erule ub_rangeD)
  done

lemma is_lub_range_shift: "chain S \<Longrightarrow> range (\<lambda>i. S (i + j)) <<| x = range S <<| x"
  by (simp add: is_lub_def is_ub_range_shift)

text \<open>the lub of a constant chain is the constant\<close>

lemma chain_const [simp]: "chain (\<lambda>i. c)"
  by (simp add: chainI)

lemma is_lub_const: "range (\<lambda>x. c) <<| c"
by (blast dest: ub_rangeD intro: is_lubI ub_rangeI)

lemma lub_const [simp]: "(\<Squnion>i. c) = c"
  by (rule is_lub_const [THEN lub_eqI])

subsection \<open>Finite chains\<close>

definition max_in_chain :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool"
  where \<comment> \<open>finite chains, needed for monotony of continuous functions\<close>
  "max_in_chain i C \<longleftrightarrow> (\<forall>j. i \<le> j \<longrightarrow> C i = C j)"

definition finite_chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
  where "finite_chain C = (chain C \<and> (\<exists>i. max_in_chain i C))"

text \<open>results about finite chains\<close>

lemma max_in_chainI: "(\<And>j. i \<le> j \<Longrightarrow> Y i = Y j) \<Longrightarrow> max_in_chain i Y"
  unfolding max_in_chain_def by fast

lemma max_in_chainD: "max_in_chain i Y \<Longrightarrow> i \<le> j \<Longrightarrow> Y i = Y j"
  unfolding max_in_chain_def by fast

lemma finite_chainI: "chain C \<Longrightarrow> max_in_chain i C \<Longrightarrow> finite_chain C"
  unfolding finite_chain_def by fast

lemma finite_chainE: "\<lbrakk>finite_chain C; \<And>i. \<lbrakk>chain C; max_in_chain i C\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  unfolding finite_chain_def by fast

lemma lub_finch1: "chain C \<Longrightarrow> max_in_chain i C \<Longrightarrow> range C <<| C i"
  apply (rule is_lubI)
   apply (rule ub_rangeI, rename_tac j)
   apply (rule_tac x=i and y=j in linorder_le_cases)
    apply (drule (1) max_in_chainD, simp)
   apply (erule (1) chain_mono)
  apply (erule ub_rangeD)
  done

lemma lub_finch2: "finite_chain C \<Longrightarrow> range C <<| C (LEAST i. max_in_chain i C)"
  apply (erule finite_chainE)
  apply (erule LeastI2 [where Q="\<lambda>i. range C <<| C i"])
  apply (erule (1) lub_finch1)
  done

lemma finch_imp_finite_range: "finite_chain Y \<Longrightarrow> finite (range Y)"
  apply (erule finite_chainE)
  apply (rule_tac B="Y ` {..i}" in finite_subset)
   apply (rule subsetI)
   apply (erule rangeE, rename_tac j)
   apply (rule_tac x=i and y=j in linorder_le_cases)
    apply (subgoal_tac "Y j = Y i", simp)
    apply (simp add: max_in_chain_def)
   apply simp
  apply simp
  done

lemma finite_range_has_max:
  fixes f :: "nat \<Rightarrow> 'a"
    and r :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  assumes mono: "\<And>i j. i \<le> j \<Longrightarrow> r (f i) (f j)"
  assumes finite_range: "finite (range f)"
  shows "\<exists>k. \<forall>i. r (f i) (f k)"
proof (intro exI allI)
  fix i :: nat
  let ?j = "LEAST k. f k = f i"
  let ?k = "Max ((\<lambda>x. LEAST k. f k = x) ` range f)"
  have "?j \<le> ?k"
  proof (rule Max_ge)
    show "finite ((\<lambda>x. LEAST k. f k = x) ` range f)"
      using finite_range by (rule finite_imageI)
    show "?j \<in> (\<lambda>x. LEAST k. f k = x) ` range f"
      by (intro imageI rangeI)
  qed
  hence "r (f ?j) (f ?k)"
    by (rule mono)
  also have "f ?j = f i"
    by (rule LeastI, rule refl)
  finally show "r (f i) (f ?k)" .
qed

lemma finite_range_imp_finch: "chain Y \<Longrightarrow> finite (range Y) \<Longrightarrow> finite_chain Y"
  apply (subgoal_tac "\<exists>k. \<forall>i. Y i \<sqsubseteq> Y k")
   apply (erule exE)
   apply (rule finite_chainI, assumption)
   apply (rule max_in_chainI)
   apply (rule below_antisym)
    apply (erule (1) chain_mono)
   apply (erule spec)
  apply (rule finite_range_has_max)
   apply (erule (1) chain_mono)
  apply assumption
  done

lemma bin_chain: "x \<sqsubseteq> y \<Longrightarrow> chain (\<lambda>i. if i=0 then x else y)"
  by (rule chainI) simp

lemma bin_chainmax: "x \<sqsubseteq> y \<Longrightarrow> max_in_chain (Suc 0) (\<lambda>i. if i=0 then x else y)"
  by (simp add: max_in_chain_def)

lemma is_lub_bin_chain: "x \<sqsubseteq> y \<Longrightarrow> range (\<lambda>i::nat. if i=0 then x else y) <<| y"
  apply (frule bin_chain)
  apply (drule bin_chainmax)
  apply (drule (1) lub_finch1)
  apply simp
  done

text \<open>the maximal element in a chain is its lub\<close>

lemma lub_chain_maxelem: "Y i = c \<Longrightarrow> \<forall>i. Y i \<sqsubseteq> c \<Longrightarrow> lub (range Y) = c"
  by (blast dest: ub_rangeD intro: lub_eqI is_lubI ub_rangeI)

end

end


(*  Title:      FOL/ex/Propositional_Cla.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section \<open>First-Order Logic: propositional examples (classical version)\<close>

theory Propositional_Cla
imports FOL
begin

text \<open>commutative laws of \<open>\<and>\<close> and \<open>\<or>\<close>\<close>

lemma "P \<and> Q \<longrightarrow> Q \<and> P"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "P \<or> Q \<longrightarrow> Q \<or> P"
  by fast

text \<open>associative laws of \<open>\<and>\<close> and \<open>\<or>\<close>\<close>
lemma "(P \<and> Q) \<and> R \<longrightarrow> P \<and> (Q \<and> R)"
  by fast

lemma "(P \<or> Q) \<or> R \<longrightarrow>  P \<or> (Q \<or> R)"
  by fast

text \<open>distributive laws of \<open>\<and>\<close> and \<open>\<or>\<close>\<close>
lemma "(P \<and> Q) \<or> R \<longrightarrow> (P \<or> R) \<and> (Q \<or> R)"
  by fast

lemma "(P \<or> R) \<and> (Q \<or> R) \<longrightarrow> (P \<and> Q) \<or> R"
  by fast

lemma "(P \<or> Q) \<and> R \<longrightarrow> (P \<and> R) \<or> (Q \<and> R)"
  by fast

lemma "(P \<and> R) \<or> (Q \<and> R) \<longrightarrow> (P \<or> Q) \<and> R"
  by fast

text \<open>Laws involving implication\<close>

lemma "(P \<longrightarrow> R) \<and> (Q \<longrightarrow> R) \<longleftrightarrow> (P \<or> Q \<longrightarrow> R)"
  by fast

lemma "(P \<and> Q \<longrightarrow> R) \<longleftrightarrow> (P \<longrightarrow> (Q \<longrightarrow> R))"
  by fast

lemma "((P \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> ((Q \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> (P \<and> Q \<longrightarrow> R) \<longrightarrow> R"
  by fast

lemma "\<not> (P \<longrightarrow> R) \<longrightarrow> \<not> (Q \<longrightarrow> R) \<longrightarrow> \<not> (P \<and> Q \<longrightarrow> R)"
  by fast

lemma "(P \<longrightarrow> Q \<and> R) \<longleftrightarrow> (P \<longrightarrow> Q) \<and> (P \<longrightarrow> R)"
  by fast

text \<open>Propositions-as-types\<close>

\<comment> \<open>The combinator K\<close>
lemma "P \<longrightarrow> (Q \<longrightarrow> P)"
  by fast

\<comment> \<open>The combinator S\<close>
lemma "(P \<longrightarrow> Q \<longrightarrow> R) \<longrightarrow> (P \<longrightarrow> Q) \<longrightarrow> (P \<longrightarrow> R)"
  by fast

\<comment> \<open>Converse is classical\<close>
lemma "(P \<longrightarrow> Q) \<or> (P \<longrightarrow> R) \<longrightarrow> (P \<longrightarrow> Q \<or> R)"
  by fast

lemma "(P \<longrightarrow> Q) \<longrightarrow> (\<not> Q \<longrightarrow> \<not> P)"
  by fast

text \<open>Schwichtenberg's examples (via T. Nipkow)\<close>

lemma stab_imp: "(((Q \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> Q) \<longrightarrow> (((P \<longrightarrow> Q) \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> P \<longrightarrow> Q"
  by fast

lemma stab_to_peirce:
  "(((P \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> P) \<longrightarrow> (((Q \<longrightarrow> R) \<longrightarrow> R) \<longrightarrow> Q)
    \<longrightarrow> ((P \<longrightarrow> Q) \<longrightarrow> P) \<longrightarrow> P"
  by fast

lemma peirce_imp1:
  "(((Q \<longrightarrow> R) \<longrightarrow> Q) \<longrightarrow> Q)
    \<longrightarrow> (((P \<longrightarrow> Q) \<longrightarrow> R) \<longrightarrow> P \<longrightarrow> Q) \<longrightarrow> P \<longrightarrow> Q"
  by fast

lemma peirce_imp2: "(((P \<longrightarrow> R) \<longrightarrow> P) \<longrightarrow> P) \<longrightarrow> ((P \<longrightarrow> Q \<longrightarrow> R) \<longrightarrow> P) \<longrightarrow> P"
  by fast

lemma mints: "((((P \<longrightarrow> Q) \<longrightarrow> P) \<longrightarrow> P) \<longrightarrow> Q) \<longrightarrow> Q"
  by fast

lemma mints_solovev: "(P \<longrightarrow> (Q \<longrightarrow> R) \<longrightarrow> Q) \<longrightarrow> ((P \<longrightarrow> Q) \<longrightarrow> R) \<longrightarrow> R"
  by fast

lemma tatsuta:
  "(((P7 \<longrightarrow> P1) \<longrightarrow> P10) \<longrightarrow> P4 \<longrightarrow> P5)
  \<longrightarrow> (((P8 \<longrightarrow> P2) \<longrightarrow> P9) \<longrightarrow> P3 \<longrightarrow> P10)
  \<longrightarrow> (P1 \<longrightarrow> P8) \<longrightarrow> P6 \<longrightarrow> P7
  \<longrightarrow> (((P3 \<longrightarrow> P2) \<longrightarrow> P9) \<longrightarrow> P4)
  \<longrightarrow> (P1 \<longrightarrow> P3) \<longrightarrow> (((P6 \<longrightarrow> P1) \<longrightarrow> P2) \<longrightarrow> P9) \<longrightarrow> P5"
  by fast

lemma tatsuta1:
  "(((P8 \<longrightarrow> P2) \<longrightarrow> P9) \<longrightarrow> P3 \<longrightarrow> P10)
  \<longrightarrow> (((P3 \<longrightarrow> P2) \<longrightarrow> P9) \<longrightarrow> P4)
  \<longrightarrow> (((P6 \<longrightarrow> P1) \<longrightarrow> P2) \<longrightarrow> P9)
  \<longrightarrow> (((P7 \<longrightarrow> P1) \<longrightarrow> P10) \<longrightarrow> P4 \<longrightarrow> P5)
  \<longrightarrow> (P1 \<longrightarrow> P3) \<longrightarrow> (P1 \<longrightarrow> P8) \<longrightarrow> P6 \<longrightarrow> P7 \<longrightarrow> P5"
  by fast

end


theory P22 imports Main begin

datatype bdd = Leaf bool | Branch bdd bdd

primrec eval :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> bdd \<Rightarrow> bool" where
"eval p i (Leaf b) = b" |
"eval p i (Branch b1 b2) = (if (p i) then (eval p (i+1) b2) else (eval p (i+1) b1))"

primrec bdd_unop :: "(bool \<Rightarrow> bool) \<Rightarrow> bdd \<Rightarrow> bdd" where
"bdd_unop f (Leaf b) = (Leaf (f b))" |
"bdd_unop f (Branch b1 b2) = (Branch (bdd_unop f b1) (bdd_unop f b2))"

primrec bdd_binop :: "(bool \<Rightarrow> bool \<Rightarrow> bool) \<Rightarrow> bdd \<Rightarrow> bdd \<Rightarrow> bdd" where
"bdd_binop f (Leaf b) c = bdd_unop (f b) c" |
"bdd_binop f (Branch b1 b2) c = (case c of
  Leaf x \<Rightarrow> Branch (bdd_binop f b1 (Leaf x)) (bdd_binop f b2 (Leaf x)) |
  Branch x1 x2 \<Rightarrow> Branch (bdd_binop f b1 x1) (bdd_binop f b2 x2))"

theorem bdd_unop_correctness : "\<forall>i. eval g i (bdd_unop f b) = f (eval g i b)"
  apply (induct b)
  apply auto
  done

theorem bdd_binop_correctness : "\<forall>i. eval g i (bdd_binop f b1 b2) = f (eval g i b1) (eval g i b2)"
  apply (induct b1 arbitrary: b2)
   apply (auto simp add: bdd_unop_correctness)
     apply (case_tac b2)
      apply auto
     apply (case_tac b2)
      apply auto
     apply (case_tac b2)
  apply auto
     apply (case_tac b2)
      apply auto
  done

definition bdd_and:: "bdd \<Rightarrow> bdd \<Rightarrow> bdd" where
"bdd_and \<equiv> bdd_binop (\<and>)"

definition bdd_or:: "bdd \<Rightarrow> bdd \<Rightarrow> bdd" where
"bdd_or \<equiv> bdd_binop (\<or>)"

definition bdd_not:: "bdd \<Rightarrow> bdd" where
"bdd_not \<equiv> bdd_unop (Not)"

definition bdd_xor:: "bdd \<Rightarrow> bdd \<Rightarrow> bdd" where
"bdd_xor \<equiv> bdd_binop (\<lambda>x y. (x \<and> (\<not> y)) \<or> (\<not>x \<and> y))"

lemma bdd_and_correctness: "eval p i (bdd_and b1 b2) = (eval p i b1 \<and> eval p i b2)"
  apply (auto simp add: bdd_and_def bdd_binop_correctness)
  done

lemma bdd_or_correctness: "eval p i (bdd_or b1 b2) = (eval p i b1 \<or> eval p i b2)"
  apply (auto simp add: bdd_or_def bdd_binop_correctness)
  done

lemma bdd_not_correctness: "eval p i (bdd_not b) = (\<not> (eval p i b))"
  apply (auto simp add: bdd_not_def bdd_unop_correctness)
  done

lemma bdd_xor_correctness:
"eval p i (bdd_xor b1 b2) = (eval p i b1 \<and> (\<not> eval p i b2)) \<or> (\<not> eval p i b1 \<and> eval p i b2)"
  apply (auto simp add: bdd_xor_def bdd_binop_correctness)
  done

fun bdd_var :: "nat \<Rightarrow> bdd" where
  "bdd_var 0 = (Branch (Leaf False) (Leaf True))" |
  "bdd_var (Suc n) = (Branch (bdd_var n) (bdd_var n))"

theorem bdd_var_correctness:"\<forall>n. eval p n (bdd_var m) = p (m+n)"
  apply (induct m)
  apply auto
  done

datatype form = T | Var nat | And form form | Xor form form

definition xor :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
  "xor x y \<equiv> (x \<and> \<not> y) \<or> (\<not> x \<and> y)"

primrec evalf :: "(nat \<Rightarrow> bool) \<Rightarrow> form \<Rightarrow> bool" where
  "evalf e T = True"
  | "evalf e (Var i) = e i"
  | "evalf e (And f1 f2) = (evalf e f1 \<and> evalf e f2)"
  | "evalf e (Xor f1 f2) = xor (evalf e f1) (evalf e f2)"

fun mk_bdd :: "form \<Rightarrow> bdd" where
"mk_bdd T = Leaf True" |
"mk_bdd (Var i) = bdd_var i" |
"mk_bdd (And f1 f2) = bdd_and (mk_bdd f1) (mk_bdd f2)" |
"mk_bdd (Xor f1 f2) = bdd_xor (mk_bdd f1) (mk_bdd f2)"

theorem mk_bdd_correct: "eval e 0 (mk_bdd f) = evalf e f"
  apply (induct f)
  using bdd_xor_correctness bdd_xor_def apply auto[1]
  apply (simp add: bdd_var_correctness)
  apply (simp add: bdd_and_correctness)
  apply (simp add: bdd_binop_correctness bdd_xor_def xor_def)
  done

end


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

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

datatype Nat = Z | S "Nat"

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

fun ins1 :: "Nat => Nat list => Nat list" where
  "ins1 y (nil2) = cons2 y (nil2)"
| "ins1 y (cons2 z2 xs) =
     (if x y z2 then cons2 z2 xs else cons2 z2 (ins1 y xs))"

fun elem :: "Nat => Nat list => bool" where
  "elem y (nil2) = False"
| "elem y (cons2 z2 xs) = (if x y z2 then True else elem y xs)"

theorem property0 :
  "elem y (ins1 y xs)"
  (*"arbitrary:y" also works well.*)
  apply(induct xs (*arbitrary: y*))
   apply clarsimp
   apply(induct_tac y)
  by auto

end


theory List_Demo
imports Main
begin

datatype 'a list = Nil | Cons "'a" "'a list"

term "Nil"

declare [[names_short]]

fun app :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"app Nil ys = ys" |
"app (Cons x xs) ys = Cons x (app xs ys)"

fun rev :: "'a list \<Rightarrow> 'a list" where
"rev Nil = Nil" |
"rev (Cons x xs) = app (rev xs) (Cons x Nil)"

value "rev(Cons True (Cons False Nil))"

value "rev(Cons a (Cons b Nil))"

lemma app_Nil2[simp]: "app xs Nil = xs"
apply (induction xs)
apply auto
done

lemma app_assoc[simp]: "app (app xs ys) zs = app xs (app ys zs)"
apply (induction xs)
apply auto
done

lemma rev_app[simp]: "rev (app xs ys) = app (rev ys) (rev xs)"
apply (induction xs)
apply auto
done

theorem rev_rev[simp]: "rev (rev xs) = xs"
apply (induction xs)
apply auto
done

(* Hint for demo:
   do the proof top down, discovering the lemmas one by one,
*)

end


(*  Title:       Executable Transitive Closures of Finite Relations
    Author:      Christian Sternagel <c.sternagel@gmail.com>
                 René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)

header \<open>A Generic Work-List Algorithm\<close>

theory Transitive_Closure_Impl
imports Main
begin

text \<open>
  Let @{term R} be some finite relation. We start to present a standard work-list algorithm to
  compute all elements that are reachable from some initial set by at most @{term n} @{term
  R}-steps. Then, we obtain algorithms for the (reflexive) transitive closure from a given starting
  set by exploiting the fact that for finite relations we have to iterate at most @{term "card R"}
  times. The presented algorithms are generic in the sense that the underlying data structure can
  freely be chosen, you just have to provide certain operations like union, membership, etc.
\<close>

subsection \<open>Bounded Reachability\<close>

text \<open>
  We provide an algorithm @{text relpow_impl} that computes all states that are reachable from an
  initial set of states @{term new} by at most @{term n} steps. The algorithm also stores a set of
  states that have already been visited @{term have}, and then show, do not have to be expanded a
  second time. The algorithm is parametric in the underlying data structure, it just requires
  operations for union and membership as well as a function to compute the successors of a list.
\<close>
fun
  relpow_impl ::
    "('a list \<Rightarrow> 'a list) \<Rightarrow>
      ('a list \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> nat \<Rightarrow> 'b"
where
  "relpow_impl succ un memb new have 0 = un new have" |
  "relpow_impl succ un memb new have (Suc m) =
    (if new = [] then have
    else
      let
        maybe = succ new;
        have' = un new have;
        new' = filter (\<lambda> n. \<not> memb n have') maybe
      in relpow_impl succ un memb new' have' m)"

text \<open>
  We need to know that the provided operations behave correctly.
\<close>

locale set_access =
  fixes un :: "'a list \<Rightarrow> 'b \<Rightarrow> 'b"
    and set_of :: "'b \<Rightarrow> 'a set"
    and memb :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
    and empty :: 'b
  assumes un: "set_of (un as bs) = set as \<union> set_of bs"
    and memb: "memb a bs \<longleftrightarrow> (a \<in> set_of bs)"
    and empty: "set_of empty = {}"

locale set_access_succ = set_access un
  for un :: "'a list \<Rightarrow> 'b \<Rightarrow> 'b" +
  fixes succ :: "'a list \<Rightarrow> 'a list"
   and  rel :: "('a \<times> 'a) set"
  assumes succ: "set (succ as) = {b. \<exists> a \<in> set as. (a, b) \<in> rel}"
begin

abbreviation "relpow_i \<equiv> relpow_impl succ un memb"

text \<open>
  What follows is the main technical result of the @{const relpow_impl} algorithm: what it computes
  for arbitrary values of @{term new} and @{term have}.
\<close>

lemma relpow_impl_main:
  "set_of (relpow_i new have n) =
    {b | a b m. a \<in> set new \<and> m \<le> n \<and> (a, b) \<in> (rel \<inter> {(a, b). b \<notin> set_of have}) ^^ m} \<union>
    set_of have"
  (is "?l new have n = ?r new have n")
proof (induction n arbitrary: "have" new)
  case (Suc n hhave nnew)
  show ?case
  proof (cases "nnew = []")
    case True
    then show ?thesis by auto
  next
    case False
    let ?have = "set_of hhave"
    let ?new = "set nnew"
    obtain "have" new where hav: "have = ?have" and new: "new = ?new" by auto
    let ?reln = "\<lambda> m. (rel \<inter> {(a, b). b \<notin> new \<and> b \<notin> have}) ^^  m"
    let ?rel = "\<lambda> m. (rel \<inter> {(a, b). b \<notin> have}) ^^  m"
    have idl: "?l nnew hhave (Suc n) =
      {uu. \<exists>a. (\<exists>aa\<in> new. (aa,a) \<in> rel) \<and> a \<notin> new \<and> a \<notin> have \<and> (\<exists>m \<le> n. (a, uu) \<in> ?reln m)} \<union>
      (new \<union> have)"
      (is "_ = ?l1 \<union> (?l2 \<union> ?l3)")
      by (simp add: hav new False Let_def Suc, simp add: memb un succ)
    let ?l = "?l1 \<union> (?l2 \<union> ?l3)"
    have idr: "?r nnew hhave (Suc n) = {b. \<exists> a m. a \<in> new \<and> m \<le> Suc n \<and> (a, b) \<in> ?rel m} \<union> have"
      (is "_ = (?r1 \<union> ?r2)") by (simp add: hav new)
    let ?r = "?r1 \<union> ?r2"
    {
      fix b
      assume b: "b \<in> ?l"
      have "b \<in> ?r"
      proof (cases "b \<in> new \<or> b \<in> have")
        case True then show ?thesis
        proof
          assume "b \<in> have" then show ?thesis by auto
        next
          assume b: "b \<in> new"
          have "b \<in> ?r1"
            by (intro CollectI, rule exI, rule exI [of _ 0], intro conjI, rule b, auto)
          then show ?thesis by auto
        qed
      next
        case False
        with b have "b \<in> ?l1" by auto
        then obtain a2 a1 m where a2n: "a2 \<notin> new" and a2h: "a2 \<notin> have" and a1: "a1 \<in> new"
          and a1a2: "(a1,a2) \<in> rel" and m: "m \<le> n" and a2b: "(a2,b) \<in> ?reln m" by auto
        have "b \<in> ?r1"
          by (rule CollectI, rule exI, rule exI [of _ "Suc m"], intro conjI, rule a1, simp add: m, rule relpow_Suc_I2, rule, rule a1a2, simp add: a2h, insert a2b, induct m arbitrary: a2 b, auto)
        then show ?thesis by auto
      qed
    }
    moreover
    {
      fix b
      assume b: "b \<in> ?r"
      then have "b \<in> ?l"
      proof (cases "b \<in> have")
        case True then show ?thesis by auto
      next
        case False
        with b have "b \<in> ?r1" by auto
        then obtain a m where a: "a \<in> new" and m: "m \<le> Suc n" and ab: "(a, b) \<in> ?rel m" by auto
        have seq: "\<exists> a \<in> new. (a, b) \<in> ?rel m"
          using a  ab by auto
        obtain l where l: "l = (LEAST m. (\<exists> a \<in> new. (a, b) \<in> ?rel m))" by auto
        have least: "(\<exists> a \<in> new. (a, b) \<in> ?rel l)"
          by (unfold l, rule LeastI, rule seq)
        have lm: "l \<le> m" unfolding l
          by (rule Least_le, rule seq)
        with m have ln: "l \<le> Suc n" by auto
        from least obtain a where a: "a \<in> new"
          and ab: "(a, b) \<in> ?rel l" by auto
        from ab [unfolded relpow_fun_conv]
        obtain f where fa: "f 0 = a" and fb: "b = f l"
          and steps: "\<And> i. i < l \<Longrightarrow> (f i, f (Suc i)) \<in> ?rel 1" by auto
        {
          fix i
          assume i: "i < l"
          have main: "f (Suc i) \<notin> new"
          proof
            assume new: "f (Suc i) \<in> new"
            let ?f = "\<lambda> j. f (Suc i + j)"
            have seq: "(f (Suc i), b) \<in> ?rel (l - Suc i)"
              unfolding relpow_fun_conv
            proof (rule exI[of _ ?f], intro conjI allI impI)
              from i show "f (Suc i + (l - Suc i)) = b"
                unfolding fb by auto
            next
              fix j
              assume "j < l - Suc i"
              then have small: "Suc i + j < l" by auto
              show "(?f j, ?f (Suc j)) \<in> rel \<inter> {(a, b). b \<notin> have}" using steps [OF small] by auto
            qed simp
            from i have small: "l - Suc i < l" by auto
            from seq new have "\<exists> a \<in> new. (a, b) \<in> ?rel (l - Suc i)"  by auto
            with not_less_Least [OF small [unfolded l]]
            show False unfolding l by auto
          qed
          then have "(f i, f (Suc i)) \<in> ?reln 1"
            using steps [OF i] by auto
        } note steps = this
        have ab: "(a, b) \<in> ?reln l" unfolding relpow_fun_conv
          by (intro exI conjI, insert fa fb steps, auto)
        have "b \<in> ?l1 \<union> ?l2"
        proof (cases l)
          case 0
          with ab a show ?thesis by auto
        next
          case (Suc ll)
          from relpow_Suc_D2 [OF ab [unfolded Suc]] a ln Suc
          show ?thesis by auto
        qed
        then show ?thesis by auto
      qed
    }
    ultimately show ?thesis
      unfolding idl idr by blast
  qed
qed (simp add: un)

text \<open>
  From the previous lemma we can directly derive that @{const relpow_impl} works correctly if @{term
  have} is initially set to @{text empty}
\<close>
lemma relpow_impl:
  "set_of (relpow_i new empty n) = {b | a b m. a \<in> set new \<and> m \<le> n \<and> (a, b) \<in> rel ^^ m}"
proof -
  have id: "rel \<inter> {(a ,b). True} = rel" by auto
  show ?thesis unfolding relpow_impl_main empty by (simp add: id)
qed

end

subsection \<open>Reflexive Transitive Closure and Transitive closure\<close>

text \<open>
  Using @{const relpow_impl} it is now easy to obtain algorithms for the reflexive transitive
  closure and the transitive closure by restricting the number of steps to the size of the finite
  relation. Note that @{const relpow_impl} will abort the computation as soon as no new states are
  detected. Hence, there is no penalty in using this large bound.
\<close>

definition
  rtrancl_impl ::
    "(('a \<times> 'a) list \<Rightarrow> 'a list \<Rightarrow> 'a list) \<Rightarrow>
      ('a list \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'b \<Rightarrow> ('a \<times> 'a) list \<Rightarrow> 'a list \<Rightarrow> 'b"
where
  "rtrancl_impl gen_succ un memb emp rel =
    (let
      succ = gen_succ rel;
      n = length rel
    in (\<lambda> as. relpow_impl succ un memb as emp n))"

definition
  trancl_impl ::
    "(('a \<times> 'a) list \<Rightarrow> 'a list \<Rightarrow> 'a list) \<Rightarrow>
      ('a list \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'b \<Rightarrow> ('a \<times> 'a) list \<Rightarrow> 'a list \<Rightarrow> 'b"
where
  "trancl_impl gen_succ un memb emp rel =
    (let
      succ = gen_succ rel;
      n = length rel
    in (\<lambda> as. relpow_impl succ un memb (succ as) emp n))"

text {*
  The soundness of both @{const rtrancl_impl} and @{const trancl_impl} follows from the soundness of
  @{const relpow_impl} and the fact that for finite relations, we can limit the number of steps to
  explore all elements in the reflexive transitive closure.
*}

lemma rtrancl_finite_relpow:
  "(a, b) \<in> (set rel)\<^sup>* \<longleftrightarrow> (\<exists> n \<le> length rel. (a, b) \<in> set rel ^^ n)" (is "?l = ?r")
proof
  assume ?r
  then show ?l
    unfolding rtrancl_power by auto
next
  assume ?l
  from this [unfolded rtrancl_power]
    obtain n where ab: "(a,b) \<in> set rel ^^ n" ..
  obtain l where l: "l = (LEAST n. (a,b) \<in> set rel ^^ n)" by auto
  have ab: "(a, b) \<in> set rel ^^ l" unfolding l
    by (intro LeastI, rule ab)
  from this [unfolded relpow_fun_conv]
  obtain f where a: "f 0 = a" and b: "f l = b"
    and steps: "\<And> i. i < l \<Longrightarrow> (f i, f (Suc i)) \<in> set rel" by auto
  let ?hits = "map (\<lambda> i. f (Suc i)) [0 ..< l]"
  from steps have subset: "set ?hits \<subseteq> snd ` set rel" by force
  have "l \<le> length rel"
  proof (cases "distinct ?hits")
    case True
    have "l = length ?hits" by simp
    also have "... = card (set ?hits)" unfolding distinct_card [OF True] ..
    also have "... \<le> card (snd ` set rel)" by (rule card_mono [OF _ subset], auto)
    also have "... = card (set (map snd rel))" by auto
    also have "... \<le> length (map snd rel)" by (rule card_length)
    finally  show ?thesis by simp
  next
    case False
    from this [unfolded distinct_conv_nth]
    obtain i j where i: "i < l" and j: "j < l" and ij: "i \<noteq> j" and fij: "f (Suc i) = f (Suc j)" by auto
    let ?i = "min i j"
    let ?j = "max i j"
    have i: "?i < l" and j: "?j < l" and fij: "f (Suc ?i) = f (Suc ?j)"
      and ij: "?i < ?j"
      using i j ij fij unfolding min_def max_def by (cases "i \<le> j", auto)
    from i j fij ij obtain i j where i: "i < l" and j: "j < l" and ij: "i < j" and fij: "f (Suc i) = f (Suc j)" by blast
    let ?g = "\<lambda> n. if n \<le> i then f n else f (n + (j - i))"
    let ?l = "l - (j - i)"
    have abl: "(a,b) \<in> set rel ^^ ?l"
      unfolding relpow_fun_conv
    proof (rule exI [of _ ?g], intro conjI impI allI)
      show "?g ?l = b" unfolding b [symmetric] using j ij by auto
    next
      fix k
      assume k: "k < ?l"
      show "(?g k, ?g (Suc k)) \<in> set rel"
      proof (cases "k < i")
        case True
        with i have "k < l" by auto
        from steps [OF this] show ?thesis using True by simp
      next
        case False
        then have ik: "i \<le> k" by auto
        show ?thesis
        proof (cases "k = i")
          case True
          then show ?thesis using ij fij steps [OF i] by simp
        next
          case False
          with ik have ik: "i < k" by auto
          then have small: "k + (j - i) < l" using k by auto
          show ?thesis using steps[OF small] ik by auto
        qed
      qed
    qed (simp add: a)
    from ij i have ll: "?l < l" by auto
    have "l \<le> ?l" unfolding l
      by (rule Least_le, rule abl [unfolded l])
    with ll have False by simp
    then show ?thesis by simp
  qed
  with ab show ?r by auto
qed

locale set_access_gen = set_access un
  for un :: "'a list \<Rightarrow> 'b \<Rightarrow> 'b" +
  fixes gen_succ :: "('a \<times> 'a) list \<Rightarrow> 'a list \<Rightarrow> 'a list"
  assumes gen_succ: "set (gen_succ rel as) = {b. \<exists> a \<in> set as. (a, b) \<in> set rel}"
begin

abbreviation "rtrancl_i \<equiv> rtrancl_impl gen_succ un memb empty"
abbreviation "trancl_i \<equiv> trancl_impl gen_succ un memb empty"

lemma rtrancl_impl:
  "set_of (rtrancl_i rel as) = {b. (\<exists> a \<in> set as. (a, b) \<in> (set rel)\<^sup>*)}"
proof -
  interpret set_access_succ set_of memb empty un "gen_succ rel" "set rel"
    by (unfold_locales, insert gen_succ, auto)
  show ?thesis unfolding rtrancl_impl_def Let_def relpow_impl
    by (auto simp: rtrancl_finite_relpow)
qed

lemma trancl_impl:
  "set_of (trancl_i rel as) = {b. (\<exists> a \<in> set as. (a, b) \<in> (set rel)\<^sup>+)}"
proof -
  interpret set_access_succ set_of memb empty un "gen_succ rel" "set rel"
    by (unfold_locales, insert gen_succ, auto)
  show ?thesis
    unfolding trancl_impl_def Let_def relpow_impl trancl_unfold_left relcomp_unfold rtrancl_finite_relpow succ by auto
qed

end

end