(*  Title:       Countable Ordinals

    Author:      Brian Huffman, 2005
    Maintainer:  Brian Huffman <brianh at cse.ogi.edu>
*)

section \<open>Ordinal Arithmetic\<close>

theory OrdinalArith
imports OrdinalRec
begin

subsection \<open>Addition\<close>

instantiation ordinal :: plus
begin

definition
  "(+) = (\<lambda>x. ordinal_rec x (\<lambda>p. oSuc))"

instance ..

end

lemma ordinal_plus_0 [simp]: "x + 0 = (x::ordinal)"
by (simp add: plus_ordinal_def)

lemma ordinal_plus_oSuc [simp]: "x + oSuc y = oSuc (x + y)"
by (simp add: plus_ordinal_def)

lemma ordinal_plus_oLimit [simp]: "x + oLimit f = oLimit (\<lambda>n. x + f n)"
by (simp add: normal.oLimit normal_plus)

lemma ordinal_0_plus [simp]: "0 + x = (x::ordinal)"
by (rule_tac a=x in oLimit_induct, simp_all)

lemma ordinal_plus_assoc:
"(x + y) + z = x + (y + z::ordinal)"
by (rule_tac a=z in oLimit_induct, simp_all)

lemma ordinal_plus_monoL [rule_format]:
"\<forall>x x'. x \<le> x' \<longrightarrow> x + y \<le> x' + (y::ordinal)"
 apply (rule_tac a=y in oLimit_induct, simp_all)
 apply clarify
 apply (rule oLimit_leI, clarify)
 apply (rule_tac n=n in le_oLimitI)
 apply simp
done

lemma ordinal_plus_monoR: "y \<le> y' \<Longrightarrow> x + y \<le> x + (y'::ordinal)"
by (rule normal.monoD[OF normal_plus])

lemma ordinal_plus_mono:
"\<lbrakk>x \<le> x'; y \<le> y'\<rbrakk> \<Longrightarrow> x + y \<le> x' + (y'::ordinal)"
by (rule order_trans[OF ordinal_plus_monoL ordinal_plus_monoR])

lemma ordinal_plus_strict_monoR: "y < y' \<Longrightarrow> x + y < x + (y'::ordinal)"
by (rule normal.strict_monoD[OF normal_plus])

lemma ordinal_le_plusL [simp]: "y \<le> x + (y::ordinal)"
by (cut_tac ordinal_plus_monoL[OF ordinal_0_le], simp)

lemma ordinal_le_plusR [simp]: "x \<le> x + (y::ordinal)"
by (cut_tac ordinal_plus_monoR[OF ordinal_0_le], simp)

lemma ordinal_less_plusR: "0 < y \<Longrightarrow> x < x + (y::ordinal)"
by (drule_tac ordinal_plus_strict_monoR, simp)

lemma ordinal_plus_left_cancel [simp]:
"(w + x = w + y) = (x = (y::ordinal))"
by (rule normal.cancel_eq[OF normal_plus])

lemma ordinal_plus_left_cancel_le [simp]:
"(w + x \<le> w + y) = (x \<le> (y::ordinal))"
by (rule normal.cancel_le[OF normal_plus])

lemma ordinal_plus_left_cancel_less [simp]:
"(w + x < w + y) = (x < (y::ordinal))"
by (rule normal.cancel_less[OF normal_plus])

lemma ordinal_plus_not_0: "(0 < x + y) = (0 < x \<or> 0 < (y::ordinal))"
 apply safe
   apply simp
  apply (erule order_less_le_trans, rule ordinal_le_plusR)
 apply (erule order_less_le_trans, rule ordinal_le_plusL)
done

lemma not_inject: "(\<not> P) = (\<not> Q) \<Longrightarrow> P = Q"
by auto

lemma ordinal_plus_eq_0:
"((x::ordinal) + y = 0) = (x = 0 \<and> y = 0)"
by (rule not_inject, simp add: ordinal_plus_not_0)

subsection \<open>Subtraction\<close>

instantiation ordinal :: minus
begin

definition
  minus_ordinal_def:
    "x - y = ordinal_rec 0 (\<lambda>p w. if y \<le> p then oSuc w else w) x"

instance ..

end

lemma continuous_minus: "continuous (\<lambda>x. x - y)"
 apply (unfold minus_ordinal_def)
 apply (rule continuous_ordinal_rec)
 apply (simp add: order_less_imp_le)
done

lemma ordinal_0_minus [simp]: "0 - x = (0::ordinal)"
by (simp add: minus_ordinal_def)

lemma ordinal_oSuc_minus [simp]: "y \<le> x \<Longrightarrow> oSuc x - y = oSuc (x - y)"
by (simp add: minus_ordinal_def)

lemma ordinal_oLimit_minus [simp]: "oLimit f - y = oLimit (\<lambda>n. f n - y)"
by (rule continuousD[OF continuous_minus])

lemma ordinal_minus_0 [simp]: "x - 0 = (x::ordinal)"
by (rule_tac a=x in oLimit_induct, simp_all)

lemma ordinal_oSuc_minus2: "x < y \<Longrightarrow> oSuc x - y = x - y"
by (simp add: minus_ordinal_def linorder_not_le[symmetric])

lemma ordinal_minus_eq_0 [rule_format, simp]:
"x \<le> y \<longrightarrow> x - y = (0::ordinal)"
 apply (rule_tac a=x in oLimit_induct)
   apply simp
  apply (simp add: ordinal_oSuc_minus2 order_less_imp_le oSuc_le_eq_less)
 apply (simp add: order_trans[OF le_oLimit])
done

lemma ordinal_plus_minus1 [simp]: "(x + y) - x = (y::ordinal)"
by (rule_tac a=y in oLimit_induct, simp_all)

lemma ordinal_plus_minus2 [simp]: "x \<le> y \<Longrightarrow> x + (y - x) = (y::ordinal)"
 apply (subgoal_tac "\<forall>z. y < x + z \<longrightarrow> x + (y - x) = y")
  apply (drule_tac x="oSuc y" in spec, erule mp)
  apply (rule order_less_le_trans[OF less_oSuc], simp)
 apply (rule allI, rule_tac a=z in oLimit_induct)
   apply (simp add: linorder_not_less[symmetric])
  apply (clarsimp simp add: less_oSuc_eq_le)
 apply (clarsimp, drule less_oLimitD, clarsimp)
done

lemma ordinal_minusI: "x = y + z \<Longrightarrow> x - y = (z::ordinal)"
by simp

lemma ordinal_minus_less_eq [simp]:
"(y::ordinal) \<le> x \<Longrightarrow> (x - y < z) = (x < y + z)"
 apply (subgoal_tac "(x - y < z) = (y + (x - y) < y + z)", simp)
 apply (simp only: ordinal_plus_left_cancel_less)
done

lemma ordinal_minus_le_eq [simp]:
"(x - y \<le> z) = (x \<le> y + (z::ordinal))"
 apply (rule_tac x=x and y=y in linorder_le_cases)
  apply (simp, erule order_trans, simp)
 apply (subgoal_tac "(x - y \<le> z) = (y + (x - y) \<le> y + z)", simp)
 apply (simp only: ordinal_plus_left_cancel_le)
done

lemma ordinal_minus_monoL: "x \<le> y \<Longrightarrow> x - z \<le> y - (z::ordinal)"
by (erule continuous.monoD[OF continuous_minus])

lemma ordinal_minus_monoR: "x \<le> y \<Longrightarrow> z - y \<le> z - (x::ordinal)"
 apply (rule_tac x=y and y=z in linorder_le_cases)
  apply (subst ordinal_minus_le_eq)
  apply (subgoal_tac "x + (z - x) \<le> y + (z - x)")
   apply (drule order_trans, assumption, simp)
  apply (erule ordinal_plus_monoL)
 apply simp
done

subsection \<open>Multiplication\<close>

instantiation ordinal :: times
begin

definition
  times_ordinal_def: "(*) = (\<lambda>x. ordinal_rec 0 (\<lambda>p w. w + x))"

instance ..

end

lemma continuous_times: "continuous ((*) x)"
by (simp add: times_ordinal_def continuous_ordinal_rec)

lemma normal_times: "0 < x \<Longrightarrow> normal ((*) x)"
 apply (unfold times_ordinal_def)
 apply (rule normal_ordinal_rec[rule_format], rename_tac y)
 apply (subgoal_tac "y + 0 < y + x", simp)
 apply (simp only: ordinal_plus_left_cancel_less)
done

lemma ordinal_times_0 [simp]: "x * 0 = (0::ordinal)"
by (simp add: times_ordinal_def)

lemma ordinal_times_oSuc [simp]: "x * oSuc y = (x * y) + x"
by (simp add: times_ordinal_def)

lemma ordinal_times_oLimit [simp]: "x * oLimit f = oLimit (\<lambda>n. x * f n)"
by (simp add: times_ordinal_def ordinal_rec_oLimit)

lemma ordinal_0_times [simp]: "0 * x = (0::ordinal)"
by (rule_tac a=x in oLimit_induct, simp_all)

lemma ordinal_1_times [simp]: "oSuc 0 * x = (x::ordinal)"
by (rule_tac a=x in oLimit_induct, simp_all)

lemma ordinal_times_1 [simp]: "x * oSuc 0 = (x::ordinal)"
by simp

lemma ordinal_times_distrib:
"x * (y + z) = (x * y) + (x * z::ordinal)"
by (rule_tac a=z in oLimit_induct, simp_all add: ordinal_plus_assoc)

lemma ordinal_times_assoc:
"(x * y::ordinal) * z = x * (y * z)"
by (rule_tac a=z in oLimit_induct, simp_all add: ordinal_times_distrib)

lemma ordinal_times_monoL [rule_format]:
"\<forall>x x'. x \<le> x' \<longrightarrow> x * y \<le> x' * (y::ordinal)"
 apply (rule_tac a=y in oLimit_induct)
   apply simp
  apply clarify
  apply (simp add: ordinal_plus_mono)
 apply clarsimp
 apply (rule oLimit_leI, clarify)
 apply (rule_tac n=n in le_oLimitI)
 apply simp
done

lemma ordinal_times_monoR: "y \<le> y' \<Longrightarrow> x * y \<le> x * (y'::ordinal)"
by (rule continuous.monoD[OF continuous_times])

lemma ordinal_times_mono:
"\<lbrakk>x \<le> x'; y \<le> y'\<rbrakk> \<Longrightarrow> x * y \<le> x' * (y'::ordinal)"
by (rule order_trans[OF ordinal_times_monoL ordinal_times_monoR])

lemma ordinal_times_strict_monoR:
"\<lbrakk>y < y'; 0 < x\<rbrakk> \<Longrightarrow> x * y < x * (y'::ordinal)"
by (rule normal.strict_monoD[OF normal_times])

lemma ordinal_le_timesL [simp]: "0 < x \<Longrightarrow> y \<le> x * (y::ordinal)"
by (drule ordinal_times_monoL[OF oSuc_leI], simp)

lemma ordinal_le_timesR [simp]: "0 < y \<Longrightarrow> x \<le> x * (y::ordinal)"
by (drule ordinal_times_monoR[OF oSuc_leI], simp)

lemma ordinal_less_timesR: "\<lbrakk>0 < x; oSuc 0 < y\<rbrakk> \<Longrightarrow> x < x * (y::ordinal)"
by (drule ordinal_times_strict_monoR, assumption, simp)

lemma ordinal_times_left_cancel [simp]:
"0 < w \<Longrightarrow> (w * x = w * y) = (x = (y::ordinal))"
by (rule normal.cancel_eq[OF normal_times])

lemma ordinal_times_left_cancel_le [simp]:
"0 < w \<Longrightarrow> (w * x \<le> w * y) = (x \<le> (y::ordinal))"
by (rule normal.cancel_le[OF normal_times])

lemma ordinal_times_left_cancel_less [simp]:
"0 < w \<Longrightarrow> (w * x < w * y) = (x < (y::ordinal))"
by (rule normal.cancel_less[OF normal_times])

lemma ordinal_times_eq_0:
"((x::ordinal) * y = 0) = (x = 0 \<or> y = 0)"
 apply (rule iffI)
  apply (erule contrapos_pp, clarsimp)
  apply (drule oSuc_leI)
  apply (erule order_less_le_trans)
  apply (drule ordinal_times_monoL, simp)
 apply auto
done

lemma ordinal_times_not_0 [simp]:
"((0::ordinal) < x * y) = (0 < x \<and> 0 < y)"
by (rule not_inject, simp add: ordinal_times_eq_0)

subsection \<open>Exponentiation\<close>

definition
  exp_ordinal :: "[ordinal, ordinal] \<Rightarrow> ordinal" (infixr "**" 75) where
  "(**) = (\<lambda>x. if 0 < x then ordinal_rec 1 (\<lambda>p w. w * x)
                         else (\<lambda>y. if y = 0 then 1 else 0))"

lemma continuous_exp: "0 < x \<Longrightarrow> continuous ((**) x)"
by (simp add: exp_ordinal_def continuous_ordinal_rec)

lemma ordinal_exp_0 [simp]: "x ** 0 = (1::ordinal)"
by (simp add: exp_ordinal_def)

lemma ordinal_exp_oSuc [simp]: "x ** oSuc y = (x ** y) * x"
by (simp add: exp_ordinal_def)

lemma ordinal_exp_oLimit [simp]:
"0 < x \<Longrightarrow> x ** oLimit f = oLimit (\<lambda>n. x ** f n)"
by (rule continuousD[OF continuous_exp])

lemma ordinal_0_exp [simp]: "0 ** x = (if x = 0 then 1 else 0)"
by (simp add: exp_ordinal_def)

lemma ordinal_1_exp [simp]: "oSuc 0 ** x = oSuc 0"
by (rule_tac a=x in oLimit_induct, simp_all)

lemma ordinal_exp_1 [simp]: "x ** oSuc 0 = x"
by simp

lemma ordinal_exp_distrib:
"x ** (y + z) = (x ** y) * (x ** (z::ordinal))"
 apply (case_tac "x = 0", simp_all add: ordinal_plus_not_0)
 apply (rule_tac a=z in oLimit_induct, simp_all add: ordinal_times_assoc)
done

lemma ordinal_exp_not_0 [simp]: "(0 < x ** y) = (0 < x \<or> y = 0)"
 apply auto
  apply (erule contrapos_pp, simp)
 apply (rule_tac a=y in oLimit_induct, simp_all)
 apply (rule less_oLimitI, erule spec)
done

lemma ordinal_exp_eq_0 [simp]: "(x ** y = 0) = (x = 0 \<and> 0 < y)"
by (rule not_inject, simp)

lemma ordinal_exp_assoc:
"(x ** y) ** z = x ** (y * z)"
 apply (case_tac "x = 0", simp_all)
 apply (rule_tac a=z in oLimit_induct, simp_all add: ordinal_exp_distrib)
done

lemma ordinal_exp_monoL [rule_format]:
"\<forall>x x'. x \<le> x' \<longrightarrow> x ** y \<le> x' ** (y::ordinal)"
 apply (rule_tac a=y in oLimit_induct)
   apply simp
  apply (simp add: ordinal_times_mono)
 apply clarsimp
 apply (case_tac "x = 0", simp)
 apply (case_tac "x' = 0", simp_all)
 apply (rule oLimit_leI, clarify)
 apply (rule_tac n=n in le_oLimitI)
 apply simp
done

lemma normal_exp: "oSuc 0 < x \<Longrightarrow> normal ((**) x)"
 apply (frule_tac order_less_trans[OF less_oSuc])
 apply (rule normalI, simp, rename_tac y)
 apply (subgoal_tac "x ** y * 1 < x ** y * x", simp)
 apply (subst ordinal_times_left_cancel_less)
  apply simp
 apply simp
done

lemma ordinal_exp_monoR:
"\<lbrakk>0 < x; y \<le> y'\<rbrakk> \<Longrightarrow> x ** y \<le> x ** (y'::ordinal)"
by (rule continuous.monoD[OF continuous_exp])

lemma ordinal_exp_mono:
"\<lbrakk>0 < x'; x \<le> x'; y \<le> y'\<rbrakk> \<Longrightarrow> x ** y \<le> x' ** (y'::ordinal)"
by (rule order_trans[OF ordinal_exp_monoL ordinal_exp_monoR])

lemma ordinal_exp_strict_monoR:
"\<lbrakk>oSuc 0 < x; y < y'\<rbrakk> \<Longrightarrow> x ** y < x ** (y'::ordinal)"
by (rule normal.strict_monoD[OF normal_exp])

lemma ordinal_le_expR [simp]: "0 < y \<Longrightarrow> x \<le> x ** (y::ordinal)"
 apply (subgoal_tac "x ** oSuc 0 \<le> x ** y")
  apply (simp del: ordinal_exp_oSuc)
 apply (case_tac "x = 0", simp)
 apply (rule ordinal_exp_monoR, simp_all add: oSuc_leI)
done

lemma ordinal_exp_left_cancel [simp]:
"oSuc 0 < w \<Longrightarrow> (w ** x = w ** y) = (x = y)"
by (rule normal.cancel_eq[OF normal_exp])

lemma ordinal_exp_left_cancel_le [simp]:
"oSuc 0 < w \<Longrightarrow> (w ** x \<le> w ** y) = (x \<le> y)"
by (rule normal.cancel_le[OF normal_exp])

lemma ordinal_exp_left_cancel_less [simp]:
"oSuc 0 < w \<Longrightarrow> (w ** x < w ** y) = (x < y)"
by (rule normal.cancel_less[OF normal_exp])

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_02
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

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

fun count :: "Nat => Nat list => Nat" where
  "count z (nil2) = Z"
| "count z (cons2 z2 ys) =
     (if x z z2 then S (count z ys) else count z ys)"

fun t2 :: "Nat => Nat => Nat" where
  "t2 (Z) y2 = y2"
| "t2 (S z2) y2 = S (t2 z2 y2)"

theorem property0 :
  "t2 (count n xs) (count n ys) = count n (y xs ys)"
  find_proof DInd
  apply (induct n xs arbitrary: ys rule: TIP_prop_02.count.induct)
  apply auto
  done

theorem property0_5:
  "t2 (count n xs) (count n ys) = count n (y xs ys)"
  apply(induct xs arbitrary:n ys)
   apply(subst y.simps(1))
   apply(subst count.simps(1))
   apply(subst t2.simps(1))
   apply(rule HOL.refl)
  apply auto
  done

theorem property0' :
  "((t2 (count n xs) (count n ys)) = (count n (y xs ys)))"
  (*why not "induct ys"?*)
  apply(induct ys)
   apply(subst count.simps(1))
    (* Neither of the innermost recursively defined constant "count" in "(count n xs)" and
   "y" in "(y xs nil2)" has a simp rule applicable to these.*)
   apply(induct xs)
    apply auto[1]
   apply auto[1]
  oops

(*alternative proof*)
theorem property0'' :
  "((t2 (count n xs) (count n ys)) = (count n (y xs ys)))"
  apply (induct (*n*) xs arbitrary: n ys rule: count.induct)
    (*Why "count.induct" not "y.induct"?
     *Because "(induct rule: y.induct)" leads to a non-theorem.
     *Because "y" is under another "recursive" function ("count")?
     *No. "y.induct" can be useful as well. See property0'''' for more detail.*)
    (*"xs" in "induct xs" here is removable.*)
    (*Why "induct xs" (why induction on xs)?
     *Because two innermost recursive constants ("count" in "count n xs" and "y" in "y xs ys")
     *is recursively defined on "xs". *)
    (*Why "arbitrary: ys", "arbitrary: n", "arbitrary: ys n", or "arbitrary: n ys"?
     *Because of "n" and "ys" in "count n ys".
     *This "count" is also the innermost recursive constant, but we induct on "xs".*)
   apply auto
  done

theorem property0''' :
  "((t2 (count n xs) (count n ys)) = (count n (y xs ys)))"
  apply(induct rule:y.induct)
  nitpick
  oops

theorem property0'''' :
  "((t2 (count n xs) (count n ys)) = (count n (y xs ys)))"
  apply(induct xs ys arbitrary: n rule:y.induct)
  by auto

end


theory AlgebraicStructure
imports Main "HOL-Library.Monad_Syntax" "HOL-Library.State_Monad" HOL.Real "~~/src/HOL/ex/Sqrt"
begin

section \<open>monoid\<close>

class monoid =
  fixes mult :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<otimes>" 70)
  fixes neutral :: 'a ("\<one>")
  assumes assoc : "(x \<otimes> y) \<otimes> z = x \<otimes> (y \<otimes> z)"
     and  neutr : "x \<otimes> \<one> = x"
     and  neutl : "\<one> \<otimes> x = x"
begin

lemma "(w \<otimes> x) \<otimes> (y \<otimes> z) = w \<otimes> x \<otimes> y \<otimes> z"
  using assoc by auto

end

instantiation int :: monoid
begin
definition mult_int_def : "x \<otimes> y = (x :: int) + y"
definition neutral_int_def : "\<one> = (0::int)"

instance
  apply standard using neutral_int_def mult_int_def by auto
end

value "(1::int) \<otimes> 2"

instantiation nat :: monoid
begin
definition mult_nat_def : "x \<otimes> y = (x :: nat) + y"
definition neutral_nat_def : "\<one> = (0::nat)"

instance
  apply standard using neutral_nat_def mult_nat_def by auto
end

value "(1::nat) \<otimes> 2"

instantiation bool :: monoid
begin
definition mult_bool_def : "x \<otimes> y = ((x::bool) \<and> y)"
definition neutral_bool_def : "\<one> = True"

instance
  apply standard using mult_bool_def neutral_bool_def by auto
end

value "True \<otimes> True"
value "True \<otimes> False"
value "False \<otimes> False"

instantiation list :: (type) monoid
begin
definition mult_list_def : "(x :: 'a list) \<otimes> y = x @ y"
definition neutral_list_def : "\<one> = []"

instance
  apply standard using neutral_list_def mult_list_def by auto

end

value "[1::nat,2,3] \<otimes> [4,5,6]"
value "''abcde'' \<otimes> ''fghij''"

instantiation set :: (type) monoid
begin
definition mult_set_def : "(x :: 'a set) \<otimes> y = x \<union> y"
definition neutral_set_def : "\<one> = {}"

instance
  apply standard using mult_set_def neutral_set_def by auto
end

value "{1::int,2,3} \<otimes> {3,4,5,6}"

interpretation setintersect : monoid "(\<inter>)" UNIV
  unfolding class.monoid_def by auto

instantiation prod :: (monoid, monoid) monoid
begin
definition mult_prod_def : "x \<otimes> y = (fst x \<otimes> fst y, snd x \<otimes> snd y)"
definition neutral_prod_def : "\<one> = (\<one>,\<one>)"

instance
  apply standard using mult_prod_def neutral_prod_def neutr neutl
  apply (simp add: assoc)
  apply (simp add: mult_prod_def neutr neutral_prod_def)
  by (simp add: mult_prod_def neutl neutral_prod_def)

end

value "(''aaaa'',{1::int,2,3}) \<otimes> (''cccc'',{4,5,6})"

value "(''aaa'',''bbb'',''ccc'') \<otimes> (''ddd'',''eee'',''fff'') \<otimes> (''ggg'',''hhh'',''iii'')"

value "(''aa'',{1::int},1::nat) \<otimes> (''cc'',{2},2) \<otimes> (''ee'',{3},3)"

value "(''aaa'', 20::int, False,{1::int}) \<otimes> (''ddd'', 30::int, False,{2})"

value "foldl (\<otimes>) \<one> [''aa'',''bb'',''cc'']"

value "foldl (\<otimes>) \<one> [1::int,2,3,4,5]"

value "foldl (\<otimes>) \<one> [(''aa'',{1::int},1::nat),(''bb'',{2},2),(''cc'',{3},3),(''dd'',{4},4)]"

value "foldl (\<otimes>) \<one> [(1::int,''bb''),(2,''dd''),(3,''ff'')]"

(* count the elements and their sum in a list *)
value "foldl (\<otimes>) \<one> (map (\<lambda>x. (1::int,x)) [1::int,2,3,4,5])"

(* count the elements and their sum in a list *)
value "foldl (\<otimes>) \<one> (map (\<lambda>x. (1::int,x)) [''aa'',''bb'',''cc'',''dd''])"

interpretation fun_monoid: monoid comp id
  unfolding class.monoid_def by auto

section \<open>monad\<close>

subsection \<open>motivation example\<close>

definition eval :: int
where "eval \<equiv> let x = 1;
                  y = x + 5;
                  z = x + y;
                  z = z * 2
               in z div 2"

(*
definition bind_option :: "'a option \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> 'b option"
  where "bind_option a f \<equiv> (case a of Some x \<Rightarrow> f x | None \<Rightarrow> None)"

adhoc_overloading Monad_Syntax.bind bind_option
*)

subsection \<open>option monad\<close>

thm Option.bind.simps

definition returno :: "'a \<Rightarrow> 'a option" where
"returno a = Some a"

definition add :: "int option \<Rightarrow> int option \<Rightarrow> int option"
  where "add x y \<equiv> do {
                     mx \<leftarrow> x;
                     my \<leftarrow> y;
                     returno (mx + my)
                   }"
thm add_def
value "add (Some 2) None"

value "add (Some 3) (Some 5)"

definition adds :: "int option \<Rightarrow> int option"
where "adds x \<equiv> do {
                  a \<leftarrow> x;
                  b \<leftarrow> add (Some a) (Some 1);
                  c \<leftarrow> add (Some b) (Some 2);
                  d \<leftarrow> add (Some c) (Some 3);
                  returno d
                }"

thm adds_def
value "adds (Some 2)"

definition safe_div :: "int option \<Rightarrow> int option \<Rightarrow> int option"
  where "safe_div x y \<equiv>
    do {
      mx \<leftarrow> x;
      my \<leftarrow> y;
      if my \<noteq> 0 then returno (mx div my) else None
    }"
thm safe_div_def

value "safe_div (Some 5) (Some 0)"
value "safe_div (Some 6) (Some 2)"
value "safe_div (Some 5) None"
value "safe_div None (Some 5)"

definition comps :: "int option \<Rightarrow> int option"
  where "comps x \<equiv>
    do {
       a \<leftarrow> add x (Some (-3));
       b \<leftarrow> safe_div (Some 6) (Some a);
       c \<leftarrow> add (Some b) (Some (-6));
       d \<leftarrow> safe_div (Some 15) (Some c);
       returno d
     }"

value "comps (Some 3)"
value "comps (Some 4)"
value "comps (Some 5)"

subsection \<open>list monad\<close>

context begin

definition returnl :: "'a \<Rightarrow> 'a list"
where "returnl a \<equiv> [a]"

definition "sqr_even l \<equiv>
  do {
    x \<leftarrow> l;
    if x mod 2 = 0 then
      returnl (x * x)
    else returnl x
  }"

thm sqr_even_def
value "sqr_even [1..10]"

definition "list_double l \<equiv>
  do {
    x \<leftarrow> l;
    [x,2*x]
  }"

thm list_double_def
value "list_double [1..5]"

definition "prod1 xs ys \<equiv>
  do {
    x \<leftarrow> xs;
    y \<leftarrow> ys;
    returnl (x, y)
  }"

thm prod1_def
value "prod1 [a,b,c] [e,f,g]"

definition "prod2 xs ys \<equiv> concat (map (\<lambda>x. concat (map (\<lambda>y. [(x,y)]) ys)) xs)"

lemma "prod1 xs ys = prod2 xs ys"
  unfolding prod1_def List.bind_def prod2_def returnl_def by simp

definition list2 :: "string list \<Rightarrow> (nat \<times> string) list"
  where "list2 ss \<equiv> do {
                      x \<leftarrow> ss;
                      let y = x@''#'';
                      let z = y@''@'';
                      returnl (length x,z@z)
                    }"
thm list2_def
value "list2 [''aaa'',''bb'',''cccc'']"
thm List.bind_def

(*
double vlen(double * v) {
  double d = 0.0;
  int n;
  for (n = 0; n < 3; ++n)
    d += v[n] * v[n];
  return sqrt(d);
}
*)
definition vlen :: "real list \<Rightarrow> real"
  where "vlen l \<equiv> foldl plus 0.0 ((l \<bind> (\<lambda>x. [x * x]))\<bind> (\<lambda>x. [x + 1]))"
definition vlen2 :: "real list \<Rightarrow> real"
  where "vlen2 l \<equiv> foldl plus 0.0 (do {
                                     x \<leftarrow> l;
                                     let y = x * x;
                                     returnl (y + 1)
                                    })"

thm vlen_def
thm vlen2_def
value "vlen [1,2,3,5]"
value "vlen2 [1,2,3,5]"

definition list3 :: "real list \<Rightarrow> real list"
  where "list3 l \<equiv> ((l \<bind> (\<lambda>x. [x * x]))\<bind> (\<lambda>x. [x + 100]))\<bind> (\<lambda>x. [x + 1000])"

definition list32 :: "real list \<Rightarrow> real list"
  where "list32 l \<equiv> do {
                      x \<leftarrow> l;
                      let y = x * x;
                      let z = y + 100;
                      returnl (z + 1000)
                    }"

thm list3_def
thm list32_def
value "list3 [1,2,3,5]"
value "list32 [1,2,3,5]"

end

subsection \<open>set monad\<close>

definition returns :: "'a \<Rightarrow> 'a set"
where "returns a = {a}"

definition set1 :: "int set \<Rightarrow> (int \<times> string) set"
  where "set1 s \<equiv> do {
                     x \<leftarrow> s;
                     if x mod 2 = 0 then
                       returns (3 * x, ''aaa'')
                     else returns (0,'''')
                  }"

value "set1 {0..10}"

definition set2 :: "int set \<Rightarrow> (int \<times> string) set"
  where "set2 s \<equiv> (s \<bind> (\<lambda>x. if x mod 2 = 0 then {(3 * x, ''aaa'')} else {(0,'''')})) \<bind> (\<lambda>(x,y). {(x+1,y@''__'')})"

definition set22 :: "int set \<Rightarrow> (int \<times> string) set"
  where "set22 s \<equiv> do {
                     x \<leftarrow> s;
                     if x mod 2 = 0 then do {
                       let (x,y) = (3 * x, ''aaa'');
                       returns (x+1,y@''__'')
                     } else do {
                       let (x,y) = (0,'''');
                       returns (x+1,y@''__'')
                     }
                   }"
thm set2_def
thm set22_def
value "set2 {0..10}"
value "set22 {0..10}"

definition set3 :: "int set \<Rightarrow> (int \<times> string) set"
  where "set3 s \<equiv> (s \<bind> (\<lambda>x. {(x*2,''*2'')})) \<bind> (\<lambda>(x,y). {(x+1,y@''__'')})"

definition set32 :: "int set \<Rightarrow> (int \<times> string) set"
  where "set32 s \<equiv> do {
                     x \<leftarrow> s;
                     (x,y) \<leftarrow> {(x*2,''*2'')};
                     returns (x+1,y@''__'')
                   }"

value "set3 {0..10}"
value "set32 {0..10}"

subsection \<open>state monad\<close>

lemma "Pair a = (\<lambda>s. (a,s))" by auto

type_synonym 'v stack = "'v list"

definition pop :: "('v stack,'v option) state"
where "pop \<equiv> State (\<lambda>s. case s of [] \<Rightarrow> (None, []) |
                                  (x#xs) \<Rightarrow> (Some x,xs))"

definition push :: "'v \<Rightarrow> ('v stack,'v option) state"
where "push v \<equiv> State (\<lambda>s. case s of [] \<Rightarrow> (None, [v]) |
                                     (x#xs) \<Rightarrow> (None,v#x#xs))"

primrec pushn :: "'v list \<Rightarrow> ('v stack, 'v option) state"
where "pushn [] = State_Monad.return None" |
      "pushn (x#xs) = do {
                        push x;
                        pushn xs
                      }"

primrec popn :: "nat \<Rightarrow> ('v stack,('v option) list) state"
where "popn 0 = State_Monad.return []" |
      "popn (Suc n) = do {
                        a \<leftarrow> pop;
                        as \<leftarrow> popn n;
                        State_Monad.return (a#as)
                      }"

value "run_state (pushn [1::int,2,3,4,5]) []"

value "run_state (pushn [1::int,2,3,4,5]) [0,0,0]"

value "run_state (popn 5) [0::int,1,2,3,4,5,6]"

value "run_state (do {
                    pushn [1::int,2,3,4,5];
                    popn 4
                  }) []"

thm foldl.simps

definition stackops :: "(int stack,int option) state"
where "stackops \<equiv>
  do {
    State_Monad.return (0::int);
    push (1::int);
    push 2;
    push 3;
    push 4;
    State_Monad.return None
  }"
thm stackops_def
value "run_state stackops []"

definition swap :: "'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list"
where "swap l i j \<equiv> (let temp = l!i in (l[i := l!j])[j := temp])"

value "swap [0::nat,1,2,3,4] 0 4"

fun insert :: "('a::linorder) list \<Rightarrow> nat \<Rightarrow> (('a::linorder) list,('a::linorder) list) state"
where "insert l i =
  (if i \<noteq> 0 \<and> l!i < l!(i-1) then do {
    let l1 = swap l (i-1) i;
    insert l1 (i - 1)
  } else do {
    State_Monad.return l
  })"

value "run_state (insert [3::int,2,8,4,3] 1) []"

function isort :: "('a::linorder) list \<Rightarrow> nat \<Rightarrow> (('a::linorder) list,('a::linorder) list) state"
where "isort l i =
  (if i < length l then do {
    l' \<leftarrow> insert l i;
    isort l' (i + 1)
  } else do {
    State_Monad.return l
  })"
by auto
termination
apply (relation "measure (\<lambda>(l,i). length l - i)")
apply auto
 sorry

thm isort.simps

value "(run_state (isort ([1::int,0,2,8,4,3,6,2]) 1) [])"

subsection \<open>I/O monad\<close>

type_synonym Name = "string"
type_synonym IOStreams = "Name \<Rightarrow> string"
type_synonym IOState = "(IOStreams,string) state"

definition "nl \<equiv> CHR 0x0A"

definition newIO :: "Name \<Rightarrow> IOState"
where "newIO x \<equiv> State (\<lambda>s. (''OK'', s(x := ([]::string))))"

definition putChar :: "Name \<Rightarrow> char \<Rightarrow> IOState"
where "putChar x c \<equiv> State (\<lambda>s. ([c],s(x := s x @ [c])))"

definition putStr :: "Name \<Rightarrow> string \<Rightarrow> IOState"
where "putStr x c \<equiv> State (\<lambda>s. (c, s(x := s x @ c)))"

definition putStrLn :: "Name \<Rightarrow> string \<Rightarrow> IOState"
where "putStrLn x c \<equiv> putStr x (c@[nl])"

definition getChar :: "Name \<Rightarrow> IOState"
where "getChar x \<equiv> State (
          \<lambda>s. case s x of [] \<Rightarrow> ([],s) |
                         (y#xs) \<Rightarrow> ([y],s(x := xs)))"

primrec getline :: "string \<Rightarrow> (string \<times> string)"
where "getline [] = ([],[])" |
      "getline (x#xs) = (let (a,b) = getline xs in
                           if x = nl then ([],xs)
                           else (x#a,b))"

definition getLine :: "Name \<Rightarrow> IOState"
where "getLine x = State (
        \<lambda>s. let str = s x;
                (a,b) = getline str in
              (a, s(x := b)))"

definition init :: "IOStreams"
where "init = (\<lambda>x. [])"

definition printIO :: "Name \<Rightarrow> IOState \<Rightarrow> (string \<times> string)"
where "printIO x sm \<equiv> (fst (run_state sm init), (snd (run_state sm init)) x)"

value "printIO ''io1''
        (do {
            newIO ''io1'';
            putStrLn ''io1'' (''aaa'');
            putStrLn ''io1'' (''bbb'');
            putStrLn ''io1'' (''ccc'');
            putChar ''io1'' (CHR ''d'');
            x \<leftarrow> getChar ''io1'';
            State_Monad.return x
          })"

value "printIO ''io2''
        (do {
            newIO ''io1'';
            putStrLn ''io1'' (''aaa'');
            putStrLn ''io1'' (''bbb'');
            putStrLn ''io1'' (''ccc'');
            putChar ''io1'' (CHR ''d'');
            x \<leftarrow> getChar ''io1'';
            newIO ''io2'';
            putStrLn ''io2'' (x);
            putStrLn ''io2'' (''fff'');
            putStrLn ''io2'' (''ggg'');
            getLine ''io2'';
            getLine ''io2'';
            y \<leftarrow> getLine ''io2'';
            State_Monad.return y
          })"

value "printIO ''io2''
        (do {
            newIO ''io1'';
            putStrLn ''io1'' (''aaa'');
            putStrLn ''io1'' (''bbb'');
            putStrLn ''io1'' (''ccc'');
            putChar ''io1'' (CHR ''d'');
            getChar ''io1'';
            newIO ''io2'';
            putStrLn ''io2'' (''eee'');
            putStrLn ''io2'' (''fff'');
            putStrLn ''io2'' (''ggg'');
            x \<leftarrow> getLine ''io2'';
            State_Monad.return x
          })"

section \<open>functor\<close>

typedecl ('a, 'b, 'c, 'd) F
consts map_F :: "('a \<Rightarrow> 'a') \<Rightarrow> ('b' \<Rightarrow> 'b) \<Rightarrow> ('c \<Rightarrow> 'c') \<Rightarrow> ('a, 'b, 'c, 'd) F \<Rightarrow> ('a', 'b', 'c', 'd') F"
functor map_F sorry

typedecl 'a T
consts map_t :: "('a \<Rightarrow> 'a') \<Rightarrow> 'a T \<Rightarrow> 'a' T"
functor map_t sorry

primrec maplist2 :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list"
  where "maplist2 f [] = []" |
        "maplist2 f (x # xs) = f x # maplist2 f xs"

functor maplist2
proof
  fix f g x
  show "(maplist2 f \<circ> maplist2 g) x = maplist2 (f \<circ> g) x"
    apply(induct x)
      using maplist2.simps by auto
next
  {
    fix x
    have "(maplist2 id) x = id x"
      apply(induct x)
        using maplist2.simps by auto
  }
  then show "maplist2 id = id" by blast
qed

thm AlgebraicStructure.list.comp
thm list.comp

(*
functor map (* map function on list is a functor *)
 by auto
(* Duplicate fact declaration "AlgebraicStructure.list.comp" vs. "AlgebraicStructure.list.comp" *)
*)

primrec mapsome :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a option \<Rightarrow> 'b option"
  where "mapsome f None = None" |
        "mapsome f (Some a) = Some (f a)"

functor mapsome
proof
  fix f g x
  show "(mapsome f \<circ> mapsome g) x = mapsome (f \<circ> g) x"
    apply(induct x)
      using mapsome.simps by auto
next
  show "mapsome id = id"
    using mapsome.simps
    by (metis eq_id_iff not_None_eq)
qed

datatype 'a tree = Leaf 'a | Node "'a tree" "'a tree"

primrec maptree :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a tree \<Rightarrow> 'b tree"
  where "maptree f (Leaf a) = Leaf (f a)" |
        "maptree f (Node l r) = Node (maptree f l) (maptree f r)"

lemma lmmt1: "(maptree f \<circ> maptree g) x = (maptree (f \<circ> g)) x"
  apply(induct x)
  using maplist2.simps by auto

lemma lmmt2: "(maptree id) x = id x"
  apply(induct x)
  using maptree.simps by auto

functor maptree
proof
  fix f::"'b \<Rightarrow> 'c"
  fix g::"'a \<Rightarrow> 'b"
  fix x::"'a tree"
  show "(maptree f \<circ> maptree g) x = maptree (f \<circ> g) x"
    using lmmt1 by simp
next
  show "maptree id = id"
    using lmmt2 by blast
qed

(*
locale Functor =
  fixes fmap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a T \<Rightarrow> 'b T"
  assumes "fmap f \<circ> fmap g = fmap (f \<circ> g)"
*)

end


(*  Author:     Makarius

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

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

theory Hebrew
imports Main
begin

text \<open>The Hebrew Alef-Bet (א-ב).\<close>

datatype alef_bet =
    Alef    ("א")
  | Bet     ("ב")
  | Gimel   ("ג")
  | Dalet   ("ד")
  | He      ("ה")
  | Vav     ("ו")
  | Zayin   ("ז")
  | Het     ("ח")
  | Tet     ("ט")
  | Yod     ("י")
  | Kaf     ("כ")
  | Lamed   ("ל")
  | Mem     ("מ")
  | Nun     ("נ")
  | Samekh  ("ס")
  | Ayin    ("ע")
  | Pe      ("פ")
  | Tsadi   ("צ")
  | Qof     ("ק")
  | Resh    ("ר")
  | Shin    ("ש")
  | Tav     ("ת")

thm alef_bet.induct

text \<open>Interpreting Hebrew letters as numbers.\<close>

primrec mispar :: "alef_bet => nat"
where
  "mispar א = 1"
| "mispar ב = 2"
| "mispar ג = 3"
| "mispar ד = 4"
| "mispar ה = 5"
| "mispar ו = 6"
| "mispar ז = 7"
| "mispar ח = 8"
| "mispar ט = 9"
| "mispar י = 10"
| "mispar כ = 20"
| "mispar ל = 30"
| "mispar מ = 40"
| "mispar נ = 50"
| "mispar ס = 60"
| "mispar ע = 70"
| "mispar פ = 80"
| "mispar צ = 90"
| "mispar ק = 100"
| "mispar ר = 200"
| "mispar ש = 300"
| "mispar ת = 400"

thm mispar.simps

lemma "mispar ק + mispar ל + mispar ה = 135"
  by simp

end


(*  Title:      HOL/Algebra/Multiplicative_Group_Revised.thy
    Author:     Paulo Emílio de Vilhena
*)

theory Multiplicative_Group_Revised
  imports Cycles Generated_Groups Polynomials

begin

section \<open>Multiplicative Group\<close>

subsection \<open>Definitions\<close>

definition l_mult :: "_ \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("l'_mult\<index>")
  where "l_mult\<^bsub>G\<^esub> a = (\<lambda>b. if b \<in> carrier G then a \<otimes>\<^bsub>G\<^esub> b else b)"

definition ord :: "_ \<Rightarrow> 'a \<Rightarrow> nat"
  where "ord G a = least_power (l_mult\<^bsub>G\<^esub> a) \<one>\<^bsub>G\<^esub>"

subsection \<open>Basic Properties\<close>

lemma (in monoid) l_mult_one:
  shows "a \<in> carrier G \<Longrightarrow> (l_mult a) \<one> = a" and "(l_mult \<one>) a = a"
  unfolding l_mult_def by auto

lemma (in monoid) l_mult_mult:
  assumes "a \<in> carrier G" and "b \<in> carrier G" shows "(l_mult a) \<circ> (l_mult b) = (l_mult (a \<otimes> b))"
  using assms unfolding l_mult_def by (auto simp add: m_assoc)

lemma (in group) l_mult_inv:
  assumes "a \<in> carrier G" shows "((l_mult a) \<circ> (l_mult (inv a))) b = b"
  using assms l_mult_one(2) l_mult_mult[OF _ inv_closed] by simp

lemma (in monoid) exp_of_l_mult:
  assumes "a \<in> carrier G" shows "(l_mult a) ^^ n = (l_mult (a [^]\<^bsub>G\<^esub> n))"
  using assms
proof (induct n)
  case 0 thus ?case
    unfolding l_mult_def by auto
next
  case (Suc n)
  hence "(l_mult a) ^^ Suc n = (l_mult a) \<circ> (l_mult (a [^]\<^bsub>G\<^esub> n))"
    by (simp add: funpow_swap1)
  thus ?case
    using l_mult_mult[of a "a [^]\<^bsub>G\<^esub> n"] Suc(2) nat_pow_Suc2 by auto
qed

lemma (in group) l_mult_permutes:
  assumes "a \<in> carrier G" shows "(l_mult a) permutes (carrier G)"
proof (rule bij_imp_permutes)
  show "l_mult a b = b" if "b \<notin> carrier G" for b
    using that unfolding l_mult_def by simp
next
  show "bij_betw (l_mult a) (carrier G) (carrier G)"
  proof (rule bij_betw_byWitness[where ?f' = "l_mult (inv a)"])
    show "\<forall>b \<in> carrier G. l_mult (inv a) (l_mult a b) = b"
      using l_mult_inv[OF inv_closed[OF assms]] unfolding inv_inv[OF assms] by simp
    show "\<forall>b \<in> carrier G. l_mult a (l_mult (inv a) b) = b"
      using l_mult_inv[OF assms] by simp
    show "l_mult a ` carrier G \<subseteq> carrier G" and "l_mult (inv a) ` carrier G \<subseteq> carrier G"
      using assms inv_closed[OF assms] unfolding l_mult_def by auto
  qed
qed

lemma (in group) l_mult_permutation:
  assumes "finite (carrier G)" and "a \<in> carrier G" shows "permutation (l_mult a)"
  using assms(1) l_mult_permutes[OF assms(2)] unfolding permutation_permutes by auto

lemma (in group) ord_pow:
  assumes "finite (carrier G)" and "a \<in> carrier G"
  shows "a [^] (ord G a) = \<one>" and "(ord G a) > 0"
  using least_power_of_permutation[OF l_mult_permutation[OF assms], of \<one>] l_mult_one(1) assms(2)
  unfolding ord_def exp_of_l_mult[OF assms(2)] by auto

lemma (in group) ord_gt_one:
  assumes "finite (carrier G)" and "a \<in> carrier G - { \<one> }" shows "(ord G a) > 1"
proof -
  have "a = \<one>" if "ord G a = 1"
    using ord_pow[OF assms(1), of a] assms(2) unfolding that by simp
  hence "ord G a \<noteq> 1"
    using assms(2) by blast
  thus ?thesis
    using ord_pow[of a] assms by simp
qed

lemma (in group) ord_minimal:
  assumes "a \<in> carrier G" and "a [^] n = \<one>" shows "(ord G a) dvd n"
  using assms(1) l_mult_one exp_of_l_mult[of a n] unfolding ord_def assms(2)
  by (simp add: least_power_minimal)

lemma (in group) ord_dvd:
  assumes "finite (carrier G)" and "a \<in> carrier G" shows "(ord G a) dvd n \<longleftrightarrow> a [^] n = \<one>"
  using assms(2) l_mult_one(1) exp_of_l_mult
  unfolding ord_def least_power_dvd[OF l_mult_permutation[OF assms(1-2)]] by simp

end


(*
Boolean Expression Checkers Based on Binary Decision Trees
Author: Tobias Nipkow
*)

theory Boolean_Expression_Checkers
imports Main
begin

section{* Tautology (etc) Checking via Binary Decision Trees *}

subsection {* Boolean Expressions *}

text{* This is the interface to the tautology checker. If you have your own
type of boolean expressions you need to translate into this type first. *}

datatype 'a bool_expr =
  Const_bool_expr bool |
  Atom_bool_expr 'a |
  Neg_bool_expr "'a bool_expr" |
  And_bool_expr "'a bool_expr" "'a bool_expr" |
  Or_bool_expr "'a bool_expr" "'a bool_expr" |
  Imp_bool_expr "'a bool_expr" "'a bool_expr" |
  Iff_bool_expr "'a bool_expr" "'a bool_expr"

primrec val_bool_expr :: "'a bool_expr \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
"val_bool_expr (Const_bool_expr b) s = b" |
"val_bool_expr (Atom_bool_expr x)   s = s x" |
"val_bool_expr (Neg_bool_expr b)   s = (\<not> val_bool_expr b s)" |
"val_bool_expr (And_bool_expr b1 b2) s = (val_bool_expr b1 s \<and> val_bool_expr b2 s)" |
"val_bool_expr (Or_bool_expr b1 b2) s = (val_bool_expr b1 s \<or> val_bool_expr b2 s)" |
"val_bool_expr (Imp_bool_expr b1 b2) s = (val_bool_expr b1 s \<longrightarrow> val_bool_expr b2 s)" |
"val_bool_expr (Iff_bool_expr b1 b2) s = (val_bool_expr b1 s = val_bool_expr b2 s)"

subsection{* Binary Decision Trees *}

datatype 'a ifex = Trueif | Falseif | IF 'a "'a ifex" "'a ifex"

fun val_ifex :: "'a ifex \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
"val_ifex Trueif s = True" |
"val_ifex Falseif s = False" |
"val_ifex (IF n t1 t2) s = (if s n then val_ifex t1 s else val_ifex t2 s)"

subsection{* A Simple Minded Translation *}

text {* Simple minded normalisation, can create branches with repeated vars: *}

primrec normif0 :: "'a ifex \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex" where
"normif0 Trueif t1 t2 = t1" |
"normif0 Falseif t1 t2 = t2" |
"normif0 (IF x t1 t2) t3 t4 = IF x (normif0 t1 t3 t4) (normif0 t2 t3 t4)"

text {* The corresponding translation from boolean expressions to if-expressions: *}

primrec ifex0 :: "'a bool_expr \<Rightarrow> 'a ifex" where
"ifex0 (Const_bool_expr b) = (if b then Trueif else Falseif)" |
"ifex0 (Atom_bool_expr x)   = IF x Trueif Falseif" |
"ifex0 (Neg_bool_expr b)   = normif0 (ifex0 b) Falseif Trueif" |
"ifex0 (And_bool_expr b1 b2) = normif0 (ifex0 b1) (ifex0 b2) Falseif" |
"ifex0 (Or_bool_expr b1 b2) = normif0 (ifex0 b1) Trueif (ifex0 b2)" |
"ifex0 (Imp_bool_expr b1 b2) = normif0 (ifex0 b1) (ifex0 b2) Trueif" |
"ifex0 (Iff_bool_expr b1 b2) = (let t1 = ifex0 b1; t2 = ifex0 b2 in
   normif0 t1 t2 (normif0 t2 Falseif Trueif))"

lemma val_normif0:
  "val_ifex (normif0 t t1 t2) s = val_ifex (if val_ifex t s then t1 else t2) s"
by(induct t arbitrary: t1 t2) auto

theorem val_ifex0: "val_ifex (ifex0 b) = val_bool_expr b"
by(induct_tac b)(auto simp: val_normif0 Let_def)

subsection{* Translation to Reduced Binary Decision Trees *}

text {* An improved translation. *}

subsubsection{* Environment *}

text{* Environments are substitutions of values for variables: *}

type_synonym 'a env_bool = "('a * bool) list"

definition agree :: "('a \<Rightarrow> bool) \<Rightarrow> 'a env_bool \<Rightarrow> bool" where
"agree s env = (\<forall>x b. map_of env x = Some b \<longrightarrow> s x = b)"

lemma agree_Nil: "agree s []"
by(simp add: agree_def)

lemma agree_Cons: "distinct(map fst env) \<Longrightarrow> x \<notin> set(map fst env)
  \<Longrightarrow> agree s ((x,b) # env) = ((if b then s x else \<not> s x) \<and> agree s env)"
by(auto simp: agree_def image_iff)

lemma agreeDT:
  "\<lbrakk> agree s env; distinct (map fst env) \<rbrakk> \<Longrightarrow> (x,True) \<in> set env \<Longrightarrow> s x"
by(simp add: agree_def)

lemma agreeDF:
  "\<lbrakk> agree s env; distinct (map fst env) \<rbrakk> \<Longrightarrow> (x,False) \<in> set env \<Longrightarrow> \<not> s x"
by(simp add: agree_def)

subsubsection{* Translation and Normalisation *}

text {* A normalisation avoiding duplicate variables and collapsing
  @{term "If x t t"} to @{text t}. *}

definition mkIF :: "'a \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex" where
"mkIF x t1 t2 = (if t1=t2 then t1 else IF x t1 t2)"

fun reduce :: "'a env_bool \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex" where
"reduce env (IF x t1 t2) = (case map_of env x of
     None \<Rightarrow> mkIF x (reduce ((x,True)#env) t1) (reduce ((x,False)#env) t2) |
     Some b \<Rightarrow> reduce env (if b then t1 else t2))" |
"reduce _ t = t"

primrec normif :: "'a env_bool \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex \<Rightarrow> 'a ifex" where
"normif env Trueif t1 t2 = reduce env t1" |
"normif env Falseif t1 t2 = reduce env t2" |
"normif env (IF x t1 t2) t3 t4 =
  (case map_of env x of
     None \<Rightarrow> mkIF x (normif ((x,True)#env) t1 t3 t4) (normif ((x,False)#env) t2 t3 t4) |
     Some b \<Rightarrow> if b then normif env t1 t3 t4 else normif env t2 t3 t4)"

primrec ifex_of :: "'a bool_expr \<Rightarrow> 'a ifex" where
"ifex_of (Const_bool_expr b) = (if b then Trueif else Falseif)" |
"ifex_of (Atom_bool_expr x)   = IF x Trueif Falseif" |
"ifex_of (Neg_bool_expr b)   = normif [] (ifex_of b) Falseif Trueif" |
"ifex_of (And_bool_expr b1 b2) = normif [] (ifex_of b1) (ifex_of b2) Falseif" |
"ifex_of (Or_bool_expr b1 b2) = normif [] (ifex_of b1) Trueif (ifex_of b2)" |
"ifex_of (Imp_bool_expr b1 b2) = normif [] (ifex_of b1) (ifex_of b2) Trueif" |
"ifex_of (Iff_bool_expr b1 b2) = (let t1 = ifex_of b1; t2 = ifex_of b2 in
   normif [] t1 t2 (normif [] t2 Falseif Trueif))"

subsubsection{* Functional Correctness Proof *}

lemma val_mkIF: "val_ifex (mkIF x t1 t2) s = val_ifex (IF x t1 t2) s"
by(auto simp: mkIF_def Let_def)

theorem val_reduce: "agree s env \<Longrightarrow> distinct(map fst env) \<Longrightarrow>
  val_ifex (reduce env t) s = val_ifex t s"
apply(induct t arbitrary: s env)
apply(auto simp: map_of_eq_None_iff val_mkIF agree_Cons Let_def
  dest: agreeDT agreeDF split: option.splits)
done

lemma val_normif: "agree s env \<Longrightarrow> distinct(map fst env) \<Longrightarrow>
  val_ifex (normif env t t1 t2) s =
  val_ifex (if val_ifex t s then t1 else t2) s"
apply(induct t arbitrary: t1 t2 s env)
apply(auto simp: val_reduce val_mkIF agree_Cons map_of_eq_None_iff
  dest: agreeDT agreeDF split: option.splits)
done

theorem val_ifex: "val_ifex (ifex_of b) s = val_bool_expr b s"
by(induct_tac b)(auto simp: val_normif agree_Nil Let_def)

subsubsection{* A Tautology Checker for Arbitrary If-Expressions *}

text{* Not really needed because @{const ifex_of} produces reduced
expressions which can be checked very easily. *}

fun taut_test_rec :: "'a ifex \<Rightarrow> 'a env_bool \<Rightarrow> bool" where
"taut_test_rec Trueif env = True" |
"taut_test_rec Falseif env = False" |
"taut_test_rec (IF x t1 t2) env = (case map_of env x of
  Some b \<Rightarrow> taut_test_rec (if b then t1 else t2) env |
  None \<Rightarrow> taut_test_rec t1 ((x,True)#env) \<and> taut_test_rec t2 ((x,False)#env))"

lemma taut_test_rec: "distinct(map fst env)
  \<Longrightarrow> taut_test_rec t env = (\<forall>s. agree s env \<longrightarrow> val_ifex t s)"
proof(induct t arbitrary: env)
  case Trueif thus ?case by simp
next
  case Falseif
  have "agree (\<lambda>x. the(map_of env x)) env" by(auto simp: agree_def)
  thus ?case by(auto)
next
  case (IF x t1 t2) show ?case
  proof (cases "map_of env x")
    case None thus ?thesis using IF
      by (simp) (auto simp: map_of_eq_None_iff image_iff agree_Cons)
  next
    case Some thus ?thesis using IF
      by (simp add: agree_def)
  qed
qed

definition taut_test_ifex :: "'a ifex \<Rightarrow> bool" where
"taut_test_ifex t = taut_test_rec t []"

corollary taut_test_ifex: "taut_test_ifex t = (\<forall>s. val_ifex t s)"
using taut_test_rec[of "[]" t]
by (auto simp: val_ifex taut_test_ifex_def agree_Nil)

subsubsection{* Reduced If-Expressions *}

text{* Proof that the result of @{const ifex_of} is reduced.
An expression reduced iff no variable appears twice on any branch and
there is no subexpression @{term"IF x t t"}. *}

fun reduced :: "'a ifex \<Rightarrow> 'a set \<Rightarrow> bool" where
"reduced (IF x t1 t2) X =
  (x \<notin> X \<and> t1 \<noteq> t2 \<and> reduced t1 (insert x X) \<and> reduced t2 (insert x X))" |
"reduced _ _ = True"

lemma reduced_antimono: "X \<subseteq> Y \<Longrightarrow> reduced t Y \<Longrightarrow> reduced t X"
apply(induction t arbitrary: X Y)
by auto (metis insert_mono)+

lemma reduced_mkIF: "x \<notin> X \<Longrightarrow>
  reduced t1 (insert x X) \<Longrightarrow> reduced t2 (insert x X) \<Longrightarrow> reduced (mkIF x t1 t2) X"
by(auto simp: mkIF_def intro:reduced_antimono)

lemma reduced_reduce:
  "distinct(map fst env) \<Longrightarrow> reduced (reduce env t) (fst ` set env)"
proof(induction t arbitrary: env)
  case (IF x t1 t2)
  thus ?case using IF.IH(1)[of "(x, True) # env"] IF.IH(2)[of "(x, False) # env"]
    by(auto simp: map_of_eq_None_iff image_iff reduced_mkIF split: option.split)
qed auto

lemma reduced_normif:
  "distinct(map fst env) \<Longrightarrow> reduced (normif env t t1 t2) (fst ` set env)"
proof(induction t arbitrary: t1 t2 env)
  case (IF x s1 s2)
  thus ?case using IF.IH(1)[of "(x, True) # env"] IF.IH(2)[of "(x, False) # env"]
    by(auto simp: reduced_mkIF map_of_eq_None_iff split: option.split)
qed (auto simp: reduced_reduce)

theorem reduced_ifex: "reduced (ifex_of b) {}"
by(induct b)(auto simp: reduced_normif[of "[]", simplified] Let_def)

text{* Proof that reduced if-expressions are @{const Trueif}, @{const Falseif}
or can evaluate to both @{const True} and @{const False}. *}

lemma same_val_if_reduced:
  "reduced t X \<Longrightarrow> \<forall>x. x \<notin> X \<longrightarrow> s1 x = s2 x \<Longrightarrow> val_ifex t s1 = val_ifex t s2"
by(induction t arbitrary: X) auto

lemma reduced_IF_depends: "\<lbrakk> reduced t X; t \<noteq> Trueif; t \<noteq> Falseif \<rbrakk>
  \<Longrightarrow> \<exists>s1 s2. val_ifex t s1 \<noteq> val_ifex t s2"
proof(induction t arbitrary: X)
  case (IF x t1 t2)
  let ?t = "IF x t1 t2"
  have 1: "reduced t1 (insert x X)" using IF.prems(1) by simp
  have 2: "reduced t2 (insert x X)" using IF.prems(1) by simp
  show ?case
  proof(cases t1)
    case Trueif[simp]
    show ?thesis
    proof (cases t2)
      case Trueif thus ?thesis using IF.prems(1) by simp
    next
      case Falseif
      hence "val_ifex ?t (\<lambda>_. True) \<noteq> val_ifex ?t (\<lambda>_. False)" by simp
      thus ?thesis by blast
    next
      case IF
      then obtain s1 s2 where "val_ifex t2 s1 \<noteq> val_ifex t2 s2"
        using IF.IH(2)[OF 2] IF.prems(1) by auto
      hence "val_ifex ?t (s1(x:=False)) \<noteq> val_ifex ?t (s2(x:=False))"
        using same_val_if_reduced[OF 2, of "s1(x:=False)" s1]
          same_val_if_reduced[OF 2, of "s2(x:=False)" s2] by simp
      thus ?thesis by blast
    qed
  next
    case Falseif[simp]
    show ?thesis
    proof (cases t2)
      case Falseif thus ?thesis using IF.prems(1) by simp
    next
      case Trueif
      hence "val_ifex ?t (\<lambda>_. True) \<noteq> val_ifex ?t (\<lambda>_. False)" by simp
      thus ?thesis by blast
    next
      case IF
      then obtain s1 s2 where "val_ifex t2 s1 \<noteq> val_ifex t2 s2"
        using IF.IH(2)[OF 2] IF.prems(1) by auto
      hence "val_ifex ?t (s1(x:=False)) \<noteq> val_ifex ?t (s2(x:=False))"
        using same_val_if_reduced[OF 2, of "s1(x:=False)" s1]
          same_val_if_reduced[OF 2, of "s2(x:=False)" s2] by simp
      thus ?thesis by blast
    qed
  next
    case IF
    then obtain s1 s2 where "val_ifex t1 s1 \<noteq> val_ifex t1 s2"
      using IF.IH(1)[OF 1] IF.prems(1) by auto
    hence "val_ifex ?t (s1(x:=True)) \<noteq> val_ifex ?t (s2(x:=True))"
      using same_val_if_reduced[OF 1, of "s1(x:=True)" s1]
          same_val_if_reduced[OF 1, of "s2(x:=True)" s2] by simp
    thus ?thesis by blast
  qed
qed auto

subsection{* Tautology Checking *}

definition taut_test :: "'a bool_expr \<Rightarrow> bool" where
"taut_test b = (ifex_of b = Trueif)"

corollary taut_test: "taut_test b = (\<forall>s. val_bool_expr b s)"
unfolding taut_test_def using reduced_IF_depends[OF reduced_ifex, of b]
by (metis val_ifex val_ifex.simps)

subsection{* Satisfiability Checking *}

definition sat_test :: "'a bool_expr \<Rightarrow> bool" where
"sat_test b = (ifex_of b \<noteq> Falseif)"

corollary sat_test: "sat_test b = (\<exists>s. val_bool_expr b s)"
unfolding sat_test_def using reduced_IF_depends[OF reduced_ifex, of b]
by (metis val_ifex val_ifex.simps(1) val_ifex.simps(2))

subsection{* Equivalence Checking *}

definition equiv_test :: "'a bool_expr \<Rightarrow> 'a bool_expr \<Rightarrow> bool" where
"equiv_test b1 b2 = taut_test (Iff_bool_expr b1 b2)"

corollary equiv_test: "equiv_test b1 b2 = (\<forall>s. val_bool_expr b1 s = val_bool_expr b2 s)"
by(auto simp:equiv_test_def taut_test)

text{* Hide everything except the boolean expressions and the checkers. *}

hide_type (open) ifex env_bool
hide_const (open)  Trueif Falseif IF val_ifex normif0 ifex0 agree mkIF
  reduce normif ifex_of reduced taut_test_rec taut_test_ifex

end


theory examples
  imports labellings (* extensions*)
begin

nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=2] (*default settings*)

(************************************************************************)
(************************************************************************)
(* EXAMPLES *)
(************************************************************************)
(************************************************************************)

(* Example set-up from [BG2011], Figure 4 *)
locale ExFig4 begin
datatype Arg = A | B | C | D
  fun att :: \<open>Arg Rel\<close> where
    "att A B = True" |
    "att B C = True" |
    "att C D = True" |
    "att D C = True" |
    "att _ _ = False"

(* admissible labellings *)
lemma \<open>admissible att Lab\<close> nitpick[satisfy] oops
(* ask nitpick for all admissible labellings *)
lemma \<open>findFor2 att admissible Labs\<close> nitpick[satisfy, eval = "card Labs"] oops
(* this gives us: {(\<lambda>x. _)(A := In, B := Out, C := In, D := Out), (\<lambda>x. _)(A := In, B := Out, C := Out, D := In), (\<lambda>x. _)
       (A := In, B := Out, C := Undec, D := Undec), (\<lambda>x. _)(A := In, B := Undec, C := Out, D := In), (\<lambda>x. _)
       (A := In, B := Undec, C := Undec, D := Undec), (\<lambda>x. _)(A := Undec, B := Undec, C := Out, D := In), (\<lambda>x. _)
       (A := Undec, B := Undec, C := Undec, D := Undec)} *)
(* checked: these are exactly the 7 labellings given in [BG2011] *)
(* we can even ask nitpick to give us that number explicitly using eval *)

(* complete labellings *)
lemma \<open>complete att Lab\<close> nitpick[satisfy] oops
lemma \<open>findFor2 att complete Labs\<close> nitpick[satisfy, eval = "card Labs"] oops
(* checked: these are exactly the 3 labellings given in [BG2011] *)

(* grounded labellings *)
lemma \<open>grounded att Lab\<close> nitpick[satisfy] oops
lemma \<open>findFor2 att grounded Labs\<close> nitpick[satisfy,box=false, eval = "card Labs"] oops
(* checked: these is exactly the one labelling given in [BG2011] *)
(* comment: we have to disable boxing for nitpick to find the model *)

(* preferred labellings *)
lemma \<open>preferred att Lab\<close> nitpick[satisfy] oops
lemma \<open>findFor2 att preferred Labs\<close> nitpick[satisfy,box=false, eval = "card Labs"] oops
(* checked: these are exactly the two labellings given in [BG2011] *)
(* comment: we have to disable boxing for nitpick to find the model *)

(* stable labellings *)
lemma \<open>stable att Lab\<close> nitpick[satisfy] oops
lemma \<open>findFor2 att stable Labs\<close> nitpick[satisfy,box=false, eval = "card Labs"] oops
(* checked: these are exactly the two labellings given in [BG2011] *)
(* comment: we have to disable boxing for nitpick to find the model *)

(* semi-stable labellings *)
lemma \<open>semistable att Lab\<close> nitpick[satisfy] oops
lemma \<open>findFor2 att semistable Labs\<close> nitpick[satisfy,box=false, eval = "card Labs"] oops
(* checked: these are exactly the two labellings given in [BG2011] *)
(* comment: we have to disable boxing for nitpick to find the model *)

(* ideal labellings: Check this out in detail, the results are weird. But I did not spend time on
ideal labellings sofar. *)
lemma \<open>ideal att Lab\<close> oops
lemma \<open>findFor2 att ideal Labs\<close> oops
(*expected: same as grounded *)
end

(* Example set-up from [BG2011], Figure 5 *)
locale ExFig5 begin
datatype Arg = A | B | C | D
  fun att :: \<open>Arg Rel\<close> where
    "att A B = True" |
    "att B A = True" |
    "att A C = True" |
    "att B C = True" |
    "att C D = True" |
    "att _ _ = False"

(* admissible labellings *)
lemma \<open>admissible att Lab\<close> nitpick[satisfy] oops
(* ask nitpick for all  z admissible labellings *)
lemma \<open>findFor2 att admissible Labs\<close> nitpick[satisfy, eval = "card Labs"] oops
(* this gives us: Labs =
      {(\<lambda>x. _)(A := In, B := Out, C := Out, D := In), (\<lambda>x. _)(A := In, B := Out, C := Out, D := Undec), (\<lambda>x. _)
       (A := In, B := Out, C := Undec, D := Undec), (\<lambda>x. _)(A := Out, B := In, C := Out, D := In), (\<lambda>x. _)
       (A := Out, B := In, C := Out, D := Undec), (\<lambda>x. _)(A := Out, B := In, C := Undec, D := Undec), (\<lambda>x. _)
       (A := Undec, B := Undec, C := Undec, D := Undec)} *)
(* these are 7 labellings, as mentioned in [BG2011]; I havent checked them all. *)

(* complete labellings *)
lemma \<open>complete att Lab\<close> nitpick[satisfy] oops
lemma \<open>findFor2 att complete Labs\<close> nitpick[satisfy, eval = "card Labs"] oops
(* checked: these are exactly the 3 labellings given in [BG2011] *)

(* grounded labellings *)
lemma \<open>grounded2 att Lab\<close> nitpick[satisfy] oops
lemma \<open>findFor2 att grounded Labs\<close> nitpick[satisfy, box=false, eval = "card Labs"] oops
(* (comment: using the the definition above requires disabling boxing for nitpick to find a model)*)
lemma \<open>findFor2 att grounded2 Labs\<close> nitpick[satisfy, eval = "card Labs"] oops
(* checked: these is exactly the one labelling given in [BG2011] *)

(* preferred labellings *)
lemma \<open>preferred att Lab\<close> nitpick[satisfy] oops
lemma \<open>findFor2 att preferred Labs\<close> nitpick[satisfy, box=false, eval = "card Labs"] oops
(* checked: these are exactly the two labellings given in [BG2011] *)
(* (comment: we have to disable boxing for nitpick to find the model) *)

(* stable labellings *)
lemma \<open>stable att Lab\<close> nitpick[satisfy] oops
lemma \<open>findFor2 att stable Labs\<close> nitpick[satisfy,box=false, eval = "card Labs"] oops
(* checked: these are exactly the two labellings given in [BG2011] *)
(* comment: we have to disable boxing for nitpick to find the model *)

(* semi-stable labellings *)
lemma \<open>semistable att Lab\<close> nitpick[satisfy] oops
lemma \<open>findFor2 att semistable Labs\<close> nitpick[satisfy,box=false, eval = "card Labs"] oops
(* checked: these are exactly the two labellings given in [BG2011] *)
(* comment: we have to disable boxing for nitpick to find the model *)
end

(* Example set-up from [BG2011], Figure 6 *)
locale ExFig6 begin
datatype Arg = A | B | C
  fun att :: \<open>Arg Rel\<close> where
    "att A B = True" |
    "att B C = True" |
    "att C A = True" |
    "att _ _ = False"

(* admissible labellings *)
lemma \<open>admissible att Lab\<close> nitpick[satisfy] oops
(* ask nitpick for all admissible labellings *)
lemma \<open>findFor2 att admissible Labs\<close> nitpick[satisfy, eval = "card Labs"] oops
(* this gives us: Labs = {(\<lambda>x. _)(A := Undec, B := Undec, C := Undec)} *)
(* this is the one trivial labelling, as mentioned in [BG2011]. *)

(* complete labellings *)
lemma \<open>complete att Lab\<close> nitpick[satisfy] oops
lemma \<open>findFor2 att complete Labs\<close> nitpick[satisfy, eval = "card Labs"] oops
(* checked: this is the one trivial labelling, as mentioned in [BG2011].*)

(* grounded labellings *)
lemma \<open>grounded att Lab\<close> nitpick[satisfy] oops
lemma \<open>findFor2 att grounded2 Labs\<close> nitpick[satisfy, eval = "card Labs"] oops
(* checked: this is the one trivial labelling, as mentioned in [BG2011].*)

(* preferred labellings *)
lemma \<open>preferred att Lab\<close> nitpick[satisfy] oops
lemma \<open>findFor2 att preferred Labs\<close> nitpick[satisfy,box=false, eval = "card Labs"] oops
(* checked: this is the one trivial labelling, as mentioned in [BG2011].*)
(* comment: we have to disable boxing for nitpick to find the model *)

(* stable labellings *)
lemma \<open>findFor2 att stable Labs\<close> nitpick[satisfy,box=false, eval = "card Labs"] oops
(* checked: these are no stable labellings, see [BG2011] *)
(* comment: we have to disable boxing for nitpick to find the model *)

(* semi-stable labellings *)
lemma \<open>semistable att Lab\<close> nitpick[satisfy] oops
lemma \<open>findFor2 att semistable Labs\<close> nitpick[satisfy,box=false, eval = "card Labs"] oops
(* checked: this is the one trivial labelling, as mentioned in [BG2011].*)
(* comment: we have to disable boxing for nitpick to find the model *)
end

(******************************)
(* further tests with locales *)

(* Lab is an admissible labelling *)
locale ExFig4Admissible = ExFig4 +
  fixes Lab :: \<open>Arg Labelling\<close>
  assumes \<open>admissible att Lab\<close>
begin

(* Confirms what [BG2011] says: A can only be labelled legally In or Undec *)
(* lemma \<open>Lab(A) = In \<or> Lab(A) = Undec\<close> unfolding Defs *)
lemma \<open>in Lab A \<or> undec Lab A\<close> unfolding Defs
  using ExFig4Admissible_axioms ExFig4Admissible_def ExFig4.att.simps(14) Label.exhaust admissible_def legallyOut_def by (metis outset_def)
  (* by (metis ExFig4Admissible_axioms ExFig4Admissible_def ExFig4.att.simps(14) Label.exhaust admissible_def legallyOut_def) *)

(* Confirms what [BG2011] says: If A is labelled Undec, then B has to be labelled Undec as well *)
(* lemma \<open>Lab(A) = Undec \<Longrightarrow> Lab(B) = Undec\<close> unfolding Defs *)
lemma \<open>undec Lab A \<Longrightarrow> undec Lab B\<close> unfolding Defs
  using ExFig4Admissible_axioms ExFig4Admissible_def ExFig4.Arg.distinct(7) ExFig4.Arg.distinct(9) ExFig4.att.elims(2) ExFig4.att.simps(1) Label.distinct(3) Label.distinct(5) Label.exhaust admissible_def legallyIn_def legallyOut_def
  by (smt (z3) inset_def outset_def)
  (* by (metis (full_types) ExFig4Admissible_axioms ExFig4Admissible_def ExFig4.Arg.distinct(7) ExFig4.Arg.distinct(9) ExFig4.att.elims(2) ExFig4.att.simps(1) Label.distinct(3) Label.distinct(5) Label.exhaust admissible_def legallyIn_def legallyOut_def) *)
end

(* Small test: Test-setup as locale merging of admissible labelling with Figure locale. *)
locale AdmissibleLab =
  fixes Lab :: \<open>'a Labelling\<close>
  assumes \<open>admissible att Lab\<close>
(* saves a bit of writing work, but makes the tools slower, it seems (see below) *)
locale ExFig4Admissible2 = ExFig4 + AdmissibleLab Lab
  for Lab :: \<open>ExFig4.Arg Labelling\<close>
begin

(* A can only be labelled legally In or Undec *)
(* lemma \<open>Lab(A) = In \<or> Lab(A) = Undec\<close> unfolding Defs  *)
lemma \<open>in Lab A \<or> undec Lab A\<close> unfolding Defs
  using AdmissibleLab_axioms AdmissibleLab_def ExFig4.att.simps(14) Label.exhaust admissible_def legallyOut_def
  by (metis outset_def)
  (* by (metis AdmissibleLab_axioms AdmissibleLab_def ExFig4.att.simps(14) Label.exhaust admissible_def legallyOut_def) *)

(* If A is labelled Undec, then B has to be labelled Undec as well *)
(* lemma \<open>Lab(A) = Undec \<Longrightarrow> Lab(B) = Undec\<close> unfolding Defs  *)
lemma \<open>undec Lab A \<Longrightarrow> undec Lab B\<close> unfolding Defs
  using AdmissibleLab_axioms AdmissibleLab_def ExFig4.Arg.distinct(7) ExFig4.Arg.distinct(9) ExFig4.att.elims(2) ExFig4.att.simps(1) Label.distinct(3) Label.distinct(5) Label.exhaust admissible_def legallyIn_def legallyOut_def
  by (smt (z3) inset_def outset_def)
  (* by (metis (full_types) AdmissibleLab_axioms AdmissibleLab_def ExFig4.Arg.distinct(7) ExFig4.Arg.distinct(9) ExFig4.att.elims(2) ExFig4.att.simps(1) Label.distinct(3) Label.distinct(5) Label.exhaust admissible_def legallyIn_def legallyOut_def) *)

(* ask nitpick for all admissible labellings: MUCH slower, so I commented it out. Works though *)
lemma \<open>findFor2 att admissible Labs\<close> (* nitpick[satisfy]*) oops
(* this gives us: {(\<lambda>x. _)(A := In, B := Out, C := In, D := Out), (\<lambda>x. _)(A := In, B := Out, C := Out, D := In), (\<lambda>x. _)
       (A := In, B := Out, C := Undec, D := Undec), (\<lambda>x. _)(A := In, B := Undec, C := Out, D := In), (\<lambda>x. _)
       (A := In, B := Undec, C := Undec, D := Undec), (\<lambda>x. _)(A := Undec, B := Undec, C := Out, D := In), (\<lambda>x. _)
       (A := Undec, B := Undec, C := Undec, D := Undec)} *)
(* these are exactly the labellings given in [BG2011] *)
end
(* I will not be using sublocales for now, seems of little use *)

(******************************)
(* further tests with locales END *)
(******************************)

(*example set-ups copied from David Fuenmayor's extension-based version *)
(*Example 1/3/8
A mock argument between two persons I and A, whose countries are at
war, about who is responsible for blocking negotiation in their region.
I: My government cannot negotiate with your government because your
government doesn't even recognize my government.
A: Your government doesn't recognize my government either.
I: But your government is a terrorist government.

The exchange between I and A can be
represented by an argumentation framework (AR, attacks) as follows: AR =
{i\<^sub>1, i\<^sub>2, a} and attacks = {(i\<^sub>1, a), (a, i\<^sub>1), (i\<^sub>2, a)} with i\<^sub>1, and i\<^sub>2, denoting the first and
the second argument of I, respectively, and a denoting the argument of A.
It is not difficult to see that AF has exactly one preferred extension E = {i1, i2}*)
locale War_Example begin
  datatype \<alpha> = i\<^sub>1 | i\<^sub>2 | a
  fun attacks ::"\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>bool" where
    "attacks i\<^sub>1 a = True" |
    "attacks i\<^sub>2 a = True" |
    "attacks a i\<^sub>1 = True" |
    "attacks _ _ = False"

  (*Uses nitpick to find a preferred extension to the argument graph defined above*)
  lemma "preferred(attacks) Lab" nitpick[satisfy] oops
  (* Read-off labeling: Lab(i1) = Lab(i2) = In, Lab(a) = Out *)

  (*We can in fact get from nitpick all extensions in one shot*)
  lemma "findFor2 attacks preferred Labs" nitpick[satisfy,timeout=70,box=false] oops
end

(*Example 9 (Nixon diamond). The well-known Nixon diamond example can be
represented as an argumentation framework AF = (AR, attacks) with AR =
{A, B}, and attacks = {(A, B), (B, A)} where A represents the argument "Nixon
is anti-pacifist since he is a republican", and B represents the argument "Nixon is
a pacifist since he is a quaker". This argumentation framework has two preferred
extensions, one in which Nixon is a pacifist and one in which Nixon is a quaker.*)
locale Nixon_Example begin
datatype \<alpha> = A | B
fun attacks ::"\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>bool" where
  "attacks A B = True" |
  "attacks B A = True" |
  "attacks _ _ = False"

(* gives the expected results *)
lemma "preferred(attacks) Lab" nitpick[satisfy,timeout=90] oops
lemma "findFor2 attacks preferred Labs" nitpick[satisfy] oops
end

abbreviation "isTotal R \<equiv> \<forall>x y. x \<noteq> y \<longrightarrow> R x y \<or> R y x"
abbreviation "isAsymm R \<equiv> \<forall>x y. R x y \<longrightarrow> \<not>R y x"
abbreviation "isTrans R \<equiv> \<forall>x y z. R x y \<and> R y z \<longrightarrow> R x z"

(*Section 3.2
Example: Stable Marriage Problem (infinitistic version)*)
locale SMP =
  fixes prefM::"'m\<Rightarrow>'w\<Rightarrow>'w\<Rightarrow>bool"
    and prefW::"'w\<Rightarrow>'m\<Rightarrow>'m\<Rightarrow>bool"
assumes same_card:  "\<exists>g::'m\<Rightarrow>'w. bij g"
    and prefM_total: "\<forall>m. isTotal (prefM m)"
    and prefM_asym: "\<forall>m. isAsymm (prefM m)"
    and prefM_trans: "\<forall>m. isTrans (prefM m)"
    and prefW_total: "\<forall>w. isTotal (prefW w)"
    and prefW_asym: "\<forall>w. isAsymm (prefW w)"
    and prefW_trans: "\<forall>w. isTrans (prefW w)"
begin

abbreviation attacksM::"('m\<times>'w)\<Rightarrow>('m\<times>'w)\<Rightarrow>bool" (infix "\<rightarrow>\<^sub>m" 50)
  where "x \<rightarrow>\<^sub>m y \<equiv> (fst x = fst y) \<and> prefM (fst x) (snd x) (snd y)"

abbreviation attacksW::"('m\<times>'w)\<Rightarrow>('m\<times>'w)\<Rightarrow>bool" (infix "\<rightarrow>\<^sub>w" 50)
  where "x \<rightarrow>\<^sub>w y \<equiv> (snd x = snd y) \<and> prefW (snd x) (fst x) (fst y)"

abbreviation attacks::"('m\<times>'w)\<Rightarrow>('m\<times>'w)\<Rightarrow>bool" (infix "\<rightarrow>" 50) where "x \<rightarrow> y \<equiv> x \<rightarrow>\<^sub>m y \<or> x \<rightarrow>\<^sub>w y"

lemma "admissible(attacks) Lab" nitpick[satisfy,show_all] oops
lemma "findFor2 attacks preferred Labs"
  nitpick[satisfy,box=true] oops

lemma "complete(attacks) Lab" nitpick[satisfy] oops
lemma "stable(attacks) Lab" nitpick[satisfy,card 'm=3, card 'w=3] oops (*finds one - TODO: verify*)
lemma "findFor2 attacks stable Labs"
  nitpick[satisfy,box=true] oops
lemma "grounded(attacks) Lab"  oops  (* no result *)
lemma "preferred(attacks) Lab"  oops (* no result *)
lemma "findFor2 attacks preferred Labs" (* this works, on the contrary; why is that? *)
  nitpick[satisfy,box=true] oops
lemma "findFor2 attacks preferred Labs" (* this works, on the contrary; why is that? *)
  nitpick[satisfy,card 'w = 2, card 'm = 2,box=false] oops
(* result: Labs =
      {(\<lambda>x. _)
       ((m\<^sub>1, w\<^sub>1) := Out, (m\<^sub>1, w\<^sub>2) := In, (m\<^sub>2, w\<^sub>1) := In,
        (m\<^sub>2, w\<^sub>2) := Out)} *)

lemma "findFor2 attacks stable Labs" (* this works, on the contrary; why is that? *)
  nitpick[satisfy,card 'w = 2, card 'm = 2,box=true] oops
(* result: Labs =
      {(\<lambda>x. _)
       ((m\<^sub>1, w\<^sub>1) := In, (m\<^sub>1, w\<^sub>2) := Out, (m\<^sub>2, w\<^sub>1) := Out,
        (m\<^sub>2, w\<^sub>2) := In)} *)

end

(*Example SMP (finitistic variant for n=3)*)
datatype w = w1 | w2 | w3
datatype m = m1 | m2 | m3
type_synonym c = "m\<times>w" (*couples*)
locale SMP_finite =
 fixes prefM::"m\<Rightarrow>w\<Rightarrow>w\<Rightarrow>bool"
 and prefW::"w\<Rightarrow>m\<Rightarrow>m\<Rightarrow>bool"
assumes  prefM_total: "\<forall>m. isTotal (prefM m)"
                 and prefM_asym: "\<forall>m. isAsymm (prefM m)"
                 and prefM_trans: "\<forall>m. isTrans (prefM m)"
                 and prefW_total: "\<forall>w. isTotal (prefW w)"
                 and prefW_asym: "\<forall>w. isAsymm (prefW w)"
                 and prefW_trans: "\<forall>w. isTrans (prefW w)"
begin

abbreviation attacksM::"c\<Rightarrow>c\<Rightarrow>bool" (infix "\<rightarrow>\<^sub>m" 50)
  where "x \<rightarrow>\<^sub>m y \<equiv> (fst x = fst y) \<and> prefM (fst x) (snd x) (snd y)"

abbreviation attacksW::"c\<Rightarrow>c\<Rightarrow>bool" (infix "\<rightarrow>\<^sub>w" 50)
  where "x \<rightarrow>\<^sub>w y \<equiv> (snd x = snd y) \<and> prefW (snd x) (fst x) (fst y)"

abbreviation attacks::"c\<Rightarrow>c\<Rightarrow>bool" (infix "\<rightarrow>" 50) where "x \<rightarrow> y \<equiv> x \<rightarrow>\<^sub>m y \<or> x \<rightarrow>\<^sub>w y"

lemma "admissible(attacks) Lab" nitpick[satisfy] oops
(* gives us:  Lab =
      (\<lambda>x. _)
      ((m\<^sub>1, w\<^sub>1) := In, (m\<^sub>1, w\<^sub>2) := Undec, (m\<^sub>1, w\<^sub>3) := Undec,
       (m\<^sub>2, w\<^sub>1) := Out, (m\<^sub>2, w\<^sub>2) := Undec, (m\<^sub>2, w\<^sub>3) := In,
       (m\<^sub>3, w\<^sub>1) := Undec, (m\<^sub>3, w\<^sub>2) := In, (m\<^sub>3, w\<^sub>3) := Undec *)
lemma "preferred(attacks) Lab" (*nitpick[satisfy,timeout=60]*) oops
lemma "complete(attacks) Lab" nitpick[satisfy] oops
lemma "findFor2 attacks stable Labs" oops
(* doesnt work, scaling is a problem*)

end

end


theory P21 imports Main begin

datatype tree = Tp | Nd tree tree

fun tips :: "tree \<Rightarrow> nat" where
"tips Tp = 1" |
"tips (Nd l r) = tips l + tips r"

fun height :: "tree \<Rightarrow> nat" where
"height Tp = 0" |
"height (Nd l r) = 1 + max (height l) (height r)"

primrec cbt :: "nat \<Rightarrow> tree" where
"cbt 0 = Tp" |
"cbt (Suc n) = Nd (cbt n) (cbt n)"

fun iscbt :: "(tree \<Rightarrow> 'a) \<Rightarrow> tree \<Rightarrow> bool" where
"iscbt f Tp = True" |
"iscbt f (Nd l r) = (f l = f r \<and> iscbt f l \<and> iscbt f r)"

theorem "iscbt height t = iscbt tips t"
  apply (induct t)
   apply auto
  done

lemma [simp]: "tips t = size t + 1"
  apply (induct t)
  apply auto
  done

theorem "(iscbt tips t = iscbt size t)"
  apply (induct t)
   apply auto
  done

theorem "iscbt height (cbt n)"
  apply (induct n)
   apply auto
  done

theorem "iscbt height t \<Longrightarrow> t = cbt (height t)"
  apply (induct t)
   apply auto
  done

theorem "iscbt (\<lambda>t. False) \<noteq> (iscbt size)"
  apply (rule notI)
  apply (metis add_cancel_right_left iscbt.simps(1) iscbt.simps(2) nat.distinct(1)
        tree.size(3) tree.size(4))
  done

end


theory Simp_Demo
imports Main
begin

section{* How to simplify *}

text{* No assumption: *}
lemma "ys @ [] = []"
apply(simp)
oops (* abandon proof *)

text{* Simplification in assumption: *}
lemma "\<lbrakk> xs @ zs = ys @ xs; [] @ xs = [] @ [] \<rbrakk> \<Longrightarrow> ys = zs"
apply(simp)
done

text{* Using additional rules: *}
lemma "(a+b)*(a-b) = a*a - b*(b::int)"
apply(simp add: algebra_simps)
done

text{* Giving a lemma the simp-attribute: *}
declare ring_distribs [simp]

subsection{* Rewriting with definitions *}

definition sq :: "nat \<Rightarrow> nat" where
"sq n = n*n"

lemma "sq(n*n) = sq(n)*sq(n)"
apply(simp add: sq_def) --"Definition of function is implicitly called f_def"
done

subsection{* Case distinctions *}

text{* Automatic: *}
lemma "(A & B) = (if A then B else False)"
apply(simp)
done

lemma "if A then B else C"
apply(simp)
oops

text{* By hand (for case): *}
lemma "1 \<le> (case ns of [] \<Rightarrow> 1 | n#_ \<Rightarrow> Suc n)"
apply(simp split: list.split)
done

subsection {* Arithmetic *}

text{* A bit of linear arithmetic (no multiplication) is automatic: *}
lemma "\<lbrakk> (x::nat) \<le> y+z;  z+x < y \<rbrakk> \<Longrightarrow> x < y"
apply(simp)
done

subsection{* Tracing: *}

lemma "rev[x] = []"
using [[simp_trace]] apply(simp)
oops

text{* Method ``auto'' can be modified almost like ``simp'': instead of
``add'' use ``simp add'': *}

end


(*  Title:      HOL/Isar_Examples/Mutilated_Checkerboard.thy
    Author:     Markus Wenzel, TU Muenchen (Isar document)
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory (original scripts)
*)

section \<open>The Mutilated Checker Board Problem\<close>

theory Mutilated_Checkerboard
imports Main
begin

text \<open>The Mutilated Checker Board Problem, formalized inductively.
  See @{cite "paulson-mutilated-board"} for the original tactic script version.\<close>

subsection \<open>Tilings\<close>

inductive_set tiling :: "'a set set \<Rightarrow> 'a set set"
  for A :: "'a set set"
where
  empty: "{} \<in> tiling A"
| Un: "a \<in> A \<Longrightarrow> t \<in> tiling A \<Longrightarrow> a \<subseteq> - t \<Longrightarrow> a \<union> t \<in> tiling A"

text \<open>The union of two disjoint tilings is a tiling.\<close>

lemma tiling_Un:
  assumes "t \<in> tiling A"
    and "u \<in> tiling A"
    and "t \<inter> u = {}"
  shows "t \<union> u \<in> tiling A"
proof -
  let ?T = "tiling A"
  from \<open>t \<in> ?T\<close> and \<open>t \<inter> u = {}\<close>
  show "t \<union> u \<in> ?T"
  proof (induct t)
    case empty
    with \<open>u \<in> ?T\<close> show "{} \<union> u \<in> ?T" by simp
  next
    case (Un a t)
    show "(a \<union> t) \<union> u \<in> ?T"
    proof -
      have "a \<union> (t \<union> u) \<in> ?T"
        using \<open>a \<in> A\<close>
      proof (rule tiling.Un)
        from \<open>(a \<union> t) \<inter> u = {}\<close> have "t \<inter> u = {}" by blast
        then show "t \<union> u \<in> ?T" by (rule Un)
        from \<open>a \<subseteq> - t\<close> and \<open>(a \<union> t) \<inter> u = {}\<close>
        show "a \<subseteq> - (t \<union> u)" by blast
      qed
      also have "a \<union> (t \<union> u) = (a \<union> t) \<union> u"
        by (simp only: Un_assoc)
      finally show ?thesis .
    qed
  qed
qed

subsection \<open>Basic properties of ``below''\<close>

definition below :: "nat \<Rightarrow> nat set"
  where "below n = {i. i < n}"

lemma below_less_iff [iff]: "i \<in> below k \<longleftrightarrow> i < k"
  by (simp add: below_def)

lemma below_0: "below 0 = {}"
  by (simp add: below_def)

lemma Sigma_Suc1: "m = n + 1 \<Longrightarrow> below m \<times> B = ({n} \<times> B) \<union> (below n \<times> B)"
  by (simp add: below_def less_Suc_eq) blast

lemma Sigma_Suc2:
  "m = n + 2 \<Longrightarrow>
    A \<times> below m = (A \<times> {n}) \<union> (A \<times> {n + 1}) \<union> (A \<times> below n)"
  by (auto simp add: below_def)

lemmas Sigma_Suc = Sigma_Suc1 Sigma_Suc2

subsection \<open>Basic properties of ``evnodd''\<close>

definition evnodd :: "(nat \<times> nat) set \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) set"
  where "evnodd A b = A \<inter> {(i, j). (i + j) mod 2 = b}"

lemma evnodd_iff: "(i, j) \<in> evnodd A b \<longleftrightarrow> (i, j) \<in> A  \<and> (i + j) mod 2 = b"
  by (simp add: evnodd_def)

lemma evnodd_subset: "evnodd A b \<subseteq> A"
  unfolding evnodd_def by (rule Int_lower1)

lemma evnoddD: "x \<in> evnodd A b \<Longrightarrow> x \<in> A"
  by (rule subsetD) (rule evnodd_subset)

lemma evnodd_finite: "finite A \<Longrightarrow> finite (evnodd A b)"
  by (rule finite_subset) (rule evnodd_subset)

lemma evnodd_Un: "evnodd (A \<union> B) b = evnodd A b \<union> evnodd B b"
  unfolding evnodd_def by blast

lemma evnodd_Diff: "evnodd (A - B) b = evnodd A b - evnodd B b"
  unfolding evnodd_def by blast

lemma evnodd_empty: "evnodd {} b = {}"
  by (simp add: evnodd_def)

lemma evnodd_insert: "evnodd (insert (i, j) C) b =
    (if (i + j) mod 2 = b
      then insert (i, j) (evnodd C b) else evnodd C b)"
  by (simp add: evnodd_def)

subsection \<open>Dominoes\<close>

inductive_set domino :: "(nat \<times> nat) set set"
where
  horiz: "{(i, j), (i, j + 1)} \<in> domino"
| vertl: "{(i, j), (i + 1, j)} \<in> domino"

lemma dominoes_tile_row:
  "{i} \<times> below (2 * n) \<in> tiling domino"
  (is "?B n \<in> ?T")
proof (induct n)
  case 0
  show ?case by (simp add: below_0 tiling.empty)
next
  case (Suc n)
  let ?a = "{i} \<times> {2 * n + 1} \<union> {i} \<times> {2 * n}"
  have "?B (Suc n) = ?a \<union> ?B n"
    by (auto simp add: Sigma_Suc Un_assoc)
  also have "\<dots> \<in> ?T"
  proof (rule tiling.Un)
    have "{(i, 2 * n), (i, 2 * n + 1)} \<in> domino"
      by (rule domino.horiz)
    also have "{(i, 2 * n), (i, 2 * n + 1)} = ?a" by blast
    finally show "\<dots> \<in> domino" .
    show "?B n \<in> ?T" by (rule Suc)
    show "?a \<subseteq> - ?B n" by blast
  qed
  finally show ?case .
qed

lemma dominoes_tile_matrix:
  "below m \<times> below (2 * n) \<in> tiling domino"
  (is "?B m \<in> ?T")
proof (induct m)
  case 0
  show ?case by (simp add: below_0 tiling.empty)
next
  case (Suc m)
  let ?t = "{m} \<times> below (2 * n)"
  have "?B (Suc m) = ?t \<union> ?B m" by (simp add: Sigma_Suc)
  also have "\<dots> \<in> ?T"
  proof (rule tiling_Un)
    show "?t \<in> ?T" by (rule dominoes_tile_row)
    show "?B m \<in> ?T" by (rule Suc)
    show "?t \<inter> ?B m = {}" by blast
  qed
  finally show ?case .
qed

lemma domino_singleton:
  assumes "d \<in> domino"
    and "b < 2"
  shows "\<exists>i j. evnodd d b = {(i, j)}"  (is "?P d")
  using assms
proof induct
  from \<open>b < 2\<close> have b_cases: "b = 0 \<or> b = 1" by arith
  fix i j
  note [simp] = evnodd_empty evnodd_insert mod_Suc
  from b_cases show "?P {(i, j), (i, j + 1)}" by rule auto
  from b_cases show "?P {(i, j), (i + 1, j)}" by rule auto
qed

lemma domino_finite:
  assumes "d \<in> domino"
  shows "finite d"
  using assms
proof induct
  fix i j :: nat
  show "finite {(i, j), (i, j + 1)}" by (intro finite.intros)
  show "finite {(i, j), (i + 1, j)}" by (intro finite.intros)
qed

subsection \<open>Tilings of dominoes\<close>

lemma tiling_domino_finite:
  assumes t: "t \<in> tiling domino"  (is "t \<in> ?T")
  shows "finite t"  (is "?F t")
  using t
proof induct
  show "?F {}" by (rule finite.emptyI)
  fix a t assume "?F t"
  assume "a \<in> domino"
  then have "?F a" by (rule domino_finite)
  from this and \<open>?F t\<close> show "?F (a \<union> t)" by (rule finite_UnI)
qed

lemma tiling_domino_01:
  assumes t: "t \<in> tiling domino"  (is "t \<in> ?T")
  shows "card (evnodd t 0) = card (evnodd t 1)"
  using t
proof induct
  case empty
  show ?case by (simp add: evnodd_def)
next
  case (Un a t)
  let ?e = evnodd
  note hyp = \<open>card (?e t 0) = card (?e t 1)\<close>
    and at = \<open>a \<subseteq> - t\<close>
  have card_suc:
    "\<And>b. b < 2 \<Longrightarrow> card (?e (a \<union> t) b) = Suc (card (?e t b))"
  proof -
    fix b :: nat
    assume "b < 2"
    have "?e (a \<union> t) b = ?e a b \<union> ?e t b" by (rule evnodd_Un)
    also obtain i j where e: "?e a b = {(i, j)}"
    proof -
      from \<open>a \<in> domino\<close> and \<open>b < 2\<close>
      have "\<exists>i j. ?e a b = {(i, j)}" by (rule domino_singleton)
      then show ?thesis by (blast intro: that)
    qed
    also have "\<dots> \<union> ?e t b = insert (i, j) (?e t b)" by simp
    also have "card \<dots> = Suc (card (?e t b))"
    proof (rule card_insert_disjoint)
      from \<open>t \<in> tiling domino\<close> have "finite t"
        by (rule tiling_domino_finite)
      then show "finite (?e t b)"
        by (rule evnodd_finite)
      from e have "(i, j) \<in> ?e a b" by simp
      with at show "(i, j) \<notin> ?e t b" by (blast dest: evnoddD)
    qed
    finally show "?thesis b" .
  qed
  then have "card (?e (a \<union> t) 0) = Suc (card (?e t 0))" by simp
  also from hyp have "card (?e t 0) = card (?e t 1)" .
  also from card_suc have "Suc \<dots> = card (?e (a \<union> t) 1)"
    by simp
  finally show ?case .
qed

subsection \<open>Main theorem\<close>

definition mutilated_board :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) set"
  where
    "mutilated_board m n =
      below (2 * (m + 1)) \<times> below (2 * (n + 1))
        - {(0, 0)} - {(2 * m + 1, 2 * n + 1)}"

theorem mutil_not_tiling: "mutilated_board m n \<notin> tiling domino"
proof (unfold mutilated_board_def)
  let ?T = "tiling domino"
  let ?t = "below (2 * (m + 1)) \<times> below (2 * (n + 1))"
  let ?t' = "?t - {(0, 0)}"
  let ?t'' = "?t' - {(2 * m + 1, 2 * n + 1)}"

  show "?t'' \<notin> ?T"
  proof
    have t: "?t \<in> ?T" by (rule dominoes_tile_matrix)
    assume t'': "?t'' \<in> ?T"

    let ?e = evnodd
    have fin: "finite (?e ?t 0)"
      by (rule evnodd_finite, rule tiling_domino_finite, rule t)

    note [simp] = evnodd_iff evnodd_empty evnodd_insert evnodd_Diff
    have "card (?e ?t'' 0) < card (?e ?t' 0)"
    proof -
      have "card (?e ?t' 0 - {(2 * m + 1, 2 * n + 1)})
        < card (?e ?t' 0)"
      proof (rule card_Diff1_less)
        from _ fin show "finite (?e ?t' 0)"
          by (rule finite_subset) auto
        show "(2 * m + 1, 2 * n + 1) \<in> ?e ?t' 0" by simp
      qed
      then show ?thesis by simp
    qed
    also have "\<dots> < card (?e ?t 0)"
    proof -
      have "(0, 0) \<in> ?e ?t 0" by simp
      with fin have "card (?e ?t 0 - {(0, 0)}) < card (?e ?t 0)"
        by (rule card_Diff1_less)
      then show ?thesis by simp
    qed
    also from t have "\<dots> = card (?e ?t 1)"
      by (rule tiling_domino_01)
    also have "?e ?t 1 = ?e ?t'' 1" by simp
    also from t'' have "card \<dots> = card (?e ?t'' 0)"
      by (rule tiling_domino_01 [symmetric])
    finally have "\<dots> < \<dots>" . then show False ..
  qed
qed

end


subsection "Properties about values"

theory ValueProps
  imports Values
begin

inductive_cases fun_le_inv[elim]: "t1 \<lesssim> t2" and
  vfun_le_inv[elim!]: "VFun t1 \<sqsubseteq> VFun t2" and
  le_fun_nat_inv[elim!]: "VFun t2 \<sqsubseteq> VNat x1" and
  le_fun_cons_inv[elim!]: "(v1, v2) # t1 \<lesssim> t2" and
  le_any_nat_inv[elim!]: "v \<sqsubseteq> VNat n" and
  le_nat_any_inv[elim!]: "VNat n \<sqsubseteq> v" and
  le_fun_any_inv[elim!]: "VFun t \<sqsubseteq> v" and
  le_any_fun_inv[elim!]: "v \<sqsubseteq> VFun t"

lemma fun_le_cons: "(a # t1) \<lesssim> t2 \<Longrightarrow> t1 \<lesssim> t2"
  by (case_tac a) auto

function val_size :: "val \<Rightarrow> nat" and fun_size :: "func \<Rightarrow> nat" where
  "val_size (VNat n) = 0" |
  "val_size (VFun t) = 1 + fun_size t" |
  "fun_size [] = 0" |
  "fun_size ((v1,v2)#t) = 1 + val_size v1 + val_size v2 + fun_size t"
  by pat_completeness auto
termination val_size by size_change

lemma val_size_mem: "(a, b) \<in> set t \<Longrightarrow> val_size a + val_size b < fun_size t"
  by (induction t) auto
lemma val_size_mem_l: "(a, b) \<in> set t \<Longrightarrow> val_size a < fun_size t"
  by (induction t) auto
lemma val_size_mem_r: "(a, b) \<in> set t \<Longrightarrow> val_size b < fun_size t"
  by (induction t) auto

lemma val_fun_le_refl: "\<forall> v t. n = val_size v + fun_size t \<longrightarrow> v \<sqsubseteq> v \<and> t \<lesssim> t"
proof (induction n rule: nat_less_induct)
  case (1 n)
  show ?case apply clarify apply (rule conjI)
  proof -
    fix v::val and t::func assume n: "n = val_size v + fun_size t"
    show "v \<sqsubseteq> v"
    proof (cases v)
      case (VNat x1)
      then show ?thesis by auto
    next
      case (VFun t')
      let ?m = "val_size (VNat 0) + fun_size t'"
      from 1 n VFun have "t' \<lesssim> t'"
        apply (erule_tac x="?m" in allE) apply (erule impE)
         apply force apply (erule_tac x="VNat 0" in allE) apply (erule_tac x="t'" in allE)
        apply simp done
      from this VFun show ?thesis by force
    qed
  next
    fix v::val and t::func assume n: "n = val_size v + fun_size t"
    show "t \<lesssim> t"
      apply (rule fun_le) apply clarify
    proof -
      fix v1 v2 assume v12: "(v1,v2) \<in> set t"
      from 1 v12 have v11: "v1 \<sqsubseteq> v1"
        apply (erule_tac x="val_size v1 + fun_size []" in allE)
        apply (erule impE) using n apply simp apply (frule val_size_mem) apply force
        apply (erule_tac x=v1 in allE) apply (erule_tac x="[]" in allE) apply force done
      from 1 v12 have v22: "v2 \<sqsubseteq> v2"
        apply (erule_tac x="val_size v2 + fun_size []" in allE)
        apply (erule impE) using n apply simp apply (frule val_size_mem) apply force
        apply (erule_tac x=v2 in allE) apply (erule_tac x="[]" in allE) apply force done
      from v12 v11 v22
      show "\<exists> v3 v4. (v3,v4) \<in> set t \<and> v1 \<sqsubseteq> v3 \<and> v3 \<sqsubseteq> v1 \<and> v2 \<sqsubseteq> v4 \<and> v4 \<sqsubseteq> v2" by blast
      qed
  qed
qed

proposition val_le_refl[simp]: fixes v::val shows "v \<sqsubseteq> v" using val_fun_le_refl by auto

lemma fun_le_refl[simp]: fixes t::func shows "t \<lesssim> t" using val_fun_le_refl by auto

definition val_eq :: "val \<Rightarrow> val \<Rightarrow> bool" (infix "\<sim>" 52) where
  "val_eq v1 v2 \<equiv> (v1 \<sqsubseteq> v2 \<and> v2 \<sqsubseteq> v1)"

definition fun_eq :: "func \<Rightarrow> func \<Rightarrow> bool" (infix "\<sim>" 52) where
  "fun_eq t1 t2 \<equiv> (t1 \<lesssim> t2 \<and> t2 \<lesssim> t1)"

lemma vfun_eq[intro!]: "t \<sim> t' \<Longrightarrow> VFun t \<sim> VFun t'"
  apply (simp add: val_eq_def fun_eq_def)
  apply (rule conjI) apply (erule conjE) apply (rule vfun_le) apply assumption
  apply (erule conjE) apply (rule vfun_le) apply assumption
  done

lemma val_eq_refl[simp]: fixes v::val shows "v \<sim> v"
  by (simp add: val_eq_def)

lemma val_eq_symm: fixes v1::val and v2::val shows "v1 \<sim> v2 \<Longrightarrow> v2 \<sim> v1"
  unfolding val_eq_def by blast

lemma val_le_fun_le_trans:
   "\<forall> v2 t2. n = val_size v2 + fun_size t2 \<longrightarrow>
    (\<forall> v1 v3. v1 \<sqsubseteq> v2 \<longrightarrow> v2 \<sqsubseteq> v3 \<longrightarrow> v1 \<sqsubseteq> v3)
    \<and> (\<forall> t1 t3. t1 \<lesssim> t2 \<longrightarrow> t2 \<lesssim> t3 \<longrightarrow> t1 \<lesssim> t3)"
proof (induction n rule: nat_less_induct)
  case (1 n)
  show ?case apply clarify
  proof
    fix v2 t2 assume n: "n = val_size v2 + fun_size t2"
    show "\<forall>v1 v3. v1 \<sqsubseteq> v2 \<longrightarrow> v2 \<sqsubseteq> v3 \<longrightarrow> v1 \<sqsubseteq> v3" apply clarify
    proof -
      fix v1 v3 assume v12: "v1 \<sqsubseteq> v2" and v23: "v2 \<sqsubseteq> v3"
      show "v1 \<sqsubseteq> v3"
      proof (cases v2)
        case (VNat n)
        from VNat v12 have v1: "v1 = VNat n" by auto
        from VNat v23 have v3: "v3 = VNat n" by auto
        from v1 v3 show ?thesis by auto
      next
        case (VFun t2')
        from v12 VFun obtain t1 where t12: "t1 \<lesssim> t2'" and v1: "v1 = VFun t1" by auto
        from v23 VFun obtain t3 where t23: "t2' \<lesssim> t3" and v3: "v3 = VFun t3" by auto
        let ?m = "val_size (VNat 0) + fun_size t2'"
        from 1 n VFun have IH: "\<forall>t1 t3. t1 \<lesssim> t2' \<longrightarrow> t2' \<lesssim> t3 \<longrightarrow> t1 \<lesssim> t3"
          apply simp apply (erule_tac x="?m" in allE) apply (erule impE) apply force
          apply (erule_tac x="VNat 0" in allE)apply (erule_tac x="t2'" in allE)
          apply auto done
        from t12 t23 IH have "t1 \<lesssim> t3" by auto
        from this v1 v3 show ?thesis apply auto done
      qed
    qed
  next
    fix v5 t2 assume n: "n = val_size v5 + fun_size t2"
    show "\<forall>t1 t3. t1 \<lesssim> t2 \<longrightarrow> t2 \<lesssim> t3 \<longrightarrow> t1 \<lesssim> t3" apply clarify
    proof -
      fix t1 t3 v1 v2 assume t12: "t1 \<lesssim> t2" and t23: "t2 \<lesssim> t3" and v12: "(v1,v2) \<in> set t1"
      from v12 t12 obtain v1' v2' where v12p: "(v1',v2') \<in> set t2" and
          v1_v1p: "v1 \<sqsubseteq> v1'" and v11p: "v1' \<sqsubseteq> v1" and v22p: "v2 \<sqsubseteq> v2'" and v2p_v2: "v2' \<sqsubseteq> v2" by blast
      from v12p t23 obtain v1'' v2'' where v12pp: "(v1'',v2'') \<in> set t3" and
         v1p_v1pp: "v1' \<sqsubseteq> v1''" and v11pp: "v1'' \<sqsubseteq> v1'" and
         v22pp: "v2' \<sqsubseteq> v2''" and v2pp_v2p: "v2'' \<sqsubseteq> v2'" by blast

      from v12p have sv1p: "val_size v1' < fun_size t2" using val_size_mem_l by blast
      from v12 1 v11p v11pp n sv1p have v1pp_v1: "v1'' \<sqsubseteq> v1"
        apply (erule_tac x="val_size v1' + fun_size []" in allE)
        apply (erule impE) apply force apply (erule_tac x=v1' in allE)
        apply (erule_tac x="[]" in allE) apply (erule impE) apply force
        apply (erule conjE) apply blast done

      from v12p have sv2p: "val_size v2' < fun_size t2" using val_size_mem_r by blast
      from v12 1 v22p v22pp n sv2p have v2_v2pp: "v2 \<sqsubseteq> v2''"
        apply (erule_tac x="val_size v2' + fun_size []" in allE)
        apply (erule impE) apply force apply (erule_tac x=v2' in allE)
        apply (erule_tac x="[]" in allE) apply (erule impE) apply force
        apply (erule conjE) apply blast done

      from v12 1 v1_v1p v1p_v1pp n sv1p have v1_v1pp: "v1 \<sqsubseteq> v1''"
        apply (erule_tac x="val_size v1' + fun_size []" in allE)
        apply (erule impE) apply force apply (erule_tac x=v1' in allE)
        apply (erule_tac x="[]" in allE) apply (erule impE) apply force
        apply (erule conjE) apply blast done

      from v12 1 v2pp_v2p v2p_v2 n sv2p have v2pp_v2: "v2'' \<sqsubseteq> v2"
        apply (erule_tac x="val_size v2' + fun_size []" in allE)
        apply (erule impE) apply force apply (erule_tac x=v2' in allE)
        apply (erule_tac x="[]" in allE) apply (erule impE) apply force
        apply (erule conjE) apply blast done

      from v12pp v1pp_v1 v2_v2pp v1_v1pp v2pp_v2
      show " \<exists>v3 v4. (v3, v4) \<in> set t3 \<and> v1 \<sqsubseteq> v3 \<and> v3 \<sqsubseteq> v1 \<and> v2 \<sqsubseteq> v4 \<and> v4 \<sqsubseteq> v2" by blast
    qed
  qed
qed

proposition val_le_trans: fixes v2::val shows "\<lbrakk> v1 \<sqsubseteq> v2; v2 \<sqsubseteq> v3 \<rbrakk> \<Longrightarrow> v1 \<sqsubseteq> v3"
  using val_le_fun_le_trans by blast

lemma fun_le_trans: "\<lbrakk> t1 \<lesssim> t2; t2 \<lesssim> t3 \<rbrakk> \<Longrightarrow> t1 \<lesssim> t3"
  using val_le_fun_le_trans by blast

lemma val_eq_trans: fixes v1::val and v2::val and v3::val
  assumes v12: "v1 \<sim> v2" and v23: "v2 \<sim> v3" shows "v1 \<sim> v3"
  using v12 v23 apply (simp only: val_eq_def) using val_le_trans apply blast done

lemma fun_eq_refl[simp]: fixes t::func shows "t \<sim> t"
  by (simp add: fun_eq_def)

lemma fun_eq_trans: fixes t1::func and t2::func and t3::func
  assumes t12: "t1 \<sim> t2" and t23: "t2 \<sim> t3" shows "t1 \<sim> t3"
  using t12 t23 unfolding fun_eq_def apply clarify apply (rule conjI)
   apply (rule fun_le_trans) apply assumption apply assumption
  apply (rule fun_le_trans) apply assumption apply assumption
  done

lemma append_fun_le:
   "\<lbrakk> t1' \<lesssim> t1; t2' \<lesssim> t2 \<rbrakk> \<Longrightarrow> t1' @ t2' \<lesssim> t1 @ t2"
  apply (rule fun_le) apply clarify apply simp apply (erule fun_le_inv)+ apply blast done

lemma append_fun_equiv:
   "\<lbrakk> t1' \<sim> t1; t2' \<sim> t2 \<rbrakk> \<Longrightarrow> t1' @ t2' \<sim> t1 @ t2"
  apply (simp add: val_eq_def fun_eq_def) using append_fun_le apply blast done

lemma append_leq_symm: "t2 @ t1 \<lesssim> t1 @ t2"
  apply (rule fun_le) apply force done

lemma append_eq_symm: "t2 @ t1 \<sim> t1 @ t2"
  unfolding fun_eq_def val_eq_def apply (rule conjI)
  apply (rule append_leq_symm) apply (rule append_leq_symm) done

lemma le_nat_any[simp]: "VNat n \<sqsubseteq> v \<Longrightarrow> v = VNat n"
  by (cases v) auto

lemma le_nat_nat[simp]: "VNat n \<sqsubseteq> VNat n' \<Longrightarrow> n = n'"
  by auto

end