(*  Title:      HOL/Nitpick_Examples/Core_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Examples featuring Nitpick's functional core.
*)

section {* Examples Featuring Nitpick's Functional Core *}

theory Core_Nits
imports Main
begin

nitpick_params [verbose, card = 1-6, unary_ints, max_potential = 0,
                sat_solver = MiniSat_JNI, max_threads = 1, timeout = 240]

subsection {* Curry in a Hurry *}

lemma "(\<lambda>f x y. (curry o split) f x y) = (\<lambda>f x y. (\<lambda>x. x) f x y)"
nitpick [card = 1-12, expect = none]
by auto

lemma "(\<lambda>f p. (split o curry) f p) = (\<lambda>f p. (\<lambda>x. x) f p)"
nitpick [card = 1-12, expect = none]
by auto

lemma "split (curry f) = f"
nitpick [card = 1-12, expect = none]
by auto

lemma "curry (split f) = f"
nitpick [card = 1-12, expect = none]
by auto

lemma "split (\<lambda>x y. f (x, y)) = f"
nitpick [card = 1-12, expect = none]
by auto

subsection {* Representations *}

lemma "\<exists>f. f = (\<lambda>x. x) \<and> f y = y"
nitpick [expect = none]
by auto

lemma "(\<exists>g. \<forall>x. g (f x) = x) \<longrightarrow> (\<forall>y. \<exists>x. y = f x)"
nitpick [card 'a = 25, card 'b = 24, expect = genuine]
nitpick [card = 1-10, mono, expect = none]
oops

lemma "\<exists>f. f = (\<lambda>x. x) \<and> f y \<noteq> y"
nitpick [card = 1, expect = genuine]
oops

lemma "P (\<lambda>x. x)"
nitpick [card = 1, expect = genuine]
oops

lemma "{(a\<Colon>'a\<times>'a, b\<Colon>'b)}^-1 = {(b, a)}"
nitpick [card = 1-12, expect = none]
by auto

lemma "fst (a, b) = a"
nitpick [card = 1-20, expect = none]
by auto

lemma "\<exists>P. P = Id"
nitpick [card = 1-20, expect = none]
by auto

lemma "(a\<Colon>'a\<Rightarrow>'b, a) \<in> Id\<^sup>*"
nitpick [card = 1-2, expect = none]
by auto

lemma "(a\<Colon>'a\<times>'a, a) \<in> Id\<^sup>* \<union> {(a, b)}\<^sup>*"
nitpick [card = 1-4, expect = none]
by auto

lemma "(a, a) \<in> Id"
nitpick [card = 1-50, expect = none]
by (auto simp: Id_def)

lemma "((a\<Colon>'a, b\<Colon>'a), (a, b)) \<in> Id"
nitpick [card = 1-10, expect = none]
by (auto simp: Id_def)

lemma "(x\<Colon>'a\<times>'a) \<in> UNIV"
nitpick [card = 1-50, expect = none]
sorry

lemma "{} = A - A"
nitpick [card = 1-100, expect = none]
by auto

lemma "g = Let (A \<or> B)"
nitpick [card = 1, expect = none]
nitpick [card = 12, expect = genuine]
oops

lemma "(let a_or_b = A \<or> B in a_or_b \<or> \<not> a_or_b)"
nitpick [expect = none]
by auto

lemma "A \<subseteq> B"
nitpick [card = 100, expect = genuine]
oops

lemma "A = {b}"
nitpick [card = 100, expect = genuine]
oops

lemma "{a, b} = {b}"
nitpick [card = 50, expect = genuine]
oops

lemma "(a\<Colon>'a\<times>'a, a\<Colon>'a\<times>'a) \<in> R"
nitpick [card = 1, expect = genuine]
nitpick [card = 10, expect = genuine]
nitpick [card = 5, dont_box, expect = genuine]
oops

lemma "f (g\<Colon>'a\<Rightarrow>'a) = x"
nitpick [card = 3, dont_box, expect = genuine]
nitpick [card = 8, expect = genuine]
oops

lemma "f (a, b) = x"
nitpick [card = 10, expect = genuine]
oops

lemma "f (a, a) = f (c, d)"
nitpick [card = 10, expect = genuine]
oops

lemma "(x\<Colon>'a) = (\<lambda>a. \<lambda>b. \<lambda>c. if c then a else b) x x True"
nitpick [card = 1-10, expect = none]
by auto

lemma "\<exists>F. F a b = G a b"
nitpick [card = 2, expect = none]
by auto

lemma "f = split"
nitpick [card = 2, expect = genuine]
oops

lemma "(A\<Colon>'a\<times>'a, B\<Colon>'a\<times>'a) \<in> R \<Longrightarrow> (A, B) \<in> R"
nitpick [card = 15, expect = none]
by auto

lemma "(A, B) \<in> R \<or> (\<exists>C. (A, C) \<in> R \<and> (C, B) \<in> R) \<Longrightarrow>
       A = B \<or> (A, B) \<in> R \<or> (\<exists>C. (A, C) \<in> R \<and> (C, B) \<in> R)"
nitpick [card = 1-25, expect = none]
by auto

lemma "f = (\<lambda>x\<Colon>'a\<times>'b. x)"
nitpick [card = 8, expect = genuine]
oops

subsection {* Quantifiers *}

lemma "x = y"
nitpick [card 'a = 1, expect = none]
nitpick [card 'a = 100, expect = genuine]
oops

lemma "\<forall>x. x = y"
nitpick [card 'a = 1, expect = none]
nitpick [card 'a = 100, expect = genuine]
oops

lemma "\<forall>x\<Colon>'a \<Rightarrow> bool. x = y"
nitpick [card 'a = 1, expect = genuine]
nitpick [card 'a = 100, expect = genuine]
oops

lemma "\<exists>x\<Colon>'a \<Rightarrow> bool. x = y"
nitpick [card 'a = 1-15, expect = none]
by auto

lemma "\<exists>x y\<Colon>'a \<Rightarrow> bool. x = y"
nitpick [card = 1-15, expect = none]
by auto

lemma "\<forall>x. \<exists>y. f x y = f x (g x)"
nitpick [card = 1-4, expect = none]
by auto

lemma "\<forall>u. \<exists>v. \<forall>w. \<exists>x. f u v w x = f u (g u) w (h u w)"
nitpick [card = 1-4, expect = none]
by auto

lemma "\<forall>u. \<exists>v. \<forall>w. \<exists>x. f u v w x = f u (g u w) w (h u)"
nitpick [card = 3, expect = genuine]
oops

lemma "\<forall>u. \<exists>v. \<forall>w. \<exists>x. \<forall>y. \<exists>z.
       f u v w x y z = f u (g u) w (h u w) y (k u w y)"
nitpick [card = 1-2, expect = none]
sorry

lemma "\<forall>u. \<exists>v. \<forall>w. \<exists>x. \<forall>y. \<exists>z.
       f u v w x y z = f u (g u) w (h u w y) y (k u w y)"
nitpick [card = 1-2, expect = genuine]
oops

lemma "\<forall>u. \<exists>v. \<forall>w. \<exists>x. \<forall>y. \<exists>z.
       f u v w x y z = f u (g u w) w (h u w) y (k u w y)"
nitpick [card = 1-2, expect = genuine]
oops

lemma "\<forall>u\<Colon>'a \<times> 'b. \<exists>v\<Colon>'c. \<forall>w\<Colon>'d. \<exists>x\<Colon>'e \<times> 'f.
       f u v w x = f u (g u) w (h u w)"
nitpick [card = 1-2, expect = none]
sorry

lemma "\<forall>u\<Colon>'a \<times> 'b. \<exists>v\<Colon>'c. \<forall>w\<Colon>'d. \<exists>x\<Colon>'e \<times> 'f.
       f u v w x = f u (g u w) w (h u)"
nitpick [card = 1-2, dont_box, expect = genuine]
oops

lemma "\<forall>u\<Colon>'a \<Rightarrow> 'b. \<exists>v\<Colon>'c. \<forall>w\<Colon>'d. \<exists>x\<Colon>'e \<Rightarrow> 'f.
       f u v w x = f u (g u) w (h u w)"
nitpick [card = 1-2, dont_box, expect = none]
sorry

lemma "\<forall>u\<Colon>'a \<Rightarrow> 'b. \<exists>v\<Colon>'c. \<forall>w\<Colon>'d. \<exists>x\<Colon>'e \<Rightarrow> 'f.
       f u v w x = f u (g u w) w (h u)"
nitpick [card = 1-2, dont_box, expect = genuine]
oops

lemma "\<forall>x. if (\<forall>y. x = y) then False else True"
nitpick [card = 1, expect = genuine]
nitpick [card = 2-5, expect = none]
oops

lemma "\<forall>x\<Colon>'a\<times>'b. if (\<forall>y. x = y) then False else True"
nitpick [card = 1, expect = genuine]
nitpick [card = 2, expect = none]
oops

lemma "\<forall>x. if (\<exists>y. x = y) then True else False"
nitpick [expect = none]
sorry

lemma "(\<exists>x\<Colon>'a. \<forall>y. P x y) \<or> (\<exists>x\<Colon>'a \<times> 'a. \<forall>y. P y x)"
nitpick [card 'a = 1, expect = genuine]
oops

lemma "\<exists>x. if x = y then (\<forall>y. y = x \<or> y \<noteq> x)
           else (\<forall>y. y = (x, x) \<or> y \<noteq> (x, x))"
nitpick [expect = none]
by auto

lemma "\<exists>x. if x = y then (\<exists>y. y = x \<or> y \<noteq> x)
           else (\<exists>y. y = (x, x) \<or> y \<noteq> (x, x))"
nitpick [expect = none]
by auto

lemma "let x = (\<forall>x. P x) in if x then x else \<not> x"
nitpick [expect = none]
by auto

lemma "let x = (\<forall>x\<Colon>'a \<times> 'b. P x) in if x then x else \<not> x"
nitpick [expect = none]
by auto

subsection {* Schematic Variables *}

schematic_lemma "x = ?x"
nitpick [expect = none]
by auto

schematic_lemma "\<forall>x. x = ?x"
nitpick [expect = genuine]
oops

schematic_lemma "\<exists>x. x = ?x"
nitpick [expect = none]
by auto

schematic_lemma "\<exists>x\<Colon>'a \<Rightarrow> 'b. x = ?x"
nitpick [expect = none]
by auto

schematic_lemma "\<forall>x. ?x = ?y"
nitpick [expect = none]
by auto

schematic_lemma "\<exists>x. ?x = ?y"
nitpick [expect = none]
by auto

subsection {* Known Constants *}

lemma "x \<equiv> Pure.all \<Longrightarrow> False"
nitpick [card = 1, expect = genuine]
nitpick [card = 1, box "('a \<Rightarrow> prop) \<Rightarrow> prop", expect = genuine]
nitpick [card = 6, expect = genuine]
oops

lemma "\<And>x. f x y = f x y"
nitpick [expect = none]
oops

lemma "\<And>x. f x y = f y x"
nitpick [expect = genuine]
oops

lemma "Pure.all (\<lambda>x. Trueprop (f x y = f x y)) \<equiv> Trueprop True"
nitpick [expect = none]
by auto

lemma "Pure.all (\<lambda>x. Trueprop (f x y = f x y)) \<equiv> Trueprop False"
nitpick [expect = genuine]
oops

lemma "I = (\<lambda>x. x) \<Longrightarrow> Pure.all P \<equiv> Pure.all (\<lambda>x. P (I x))"
nitpick [expect = none]
by auto

lemma "x \<equiv> (op \<equiv>) \<Longrightarrow> False"
nitpick [card = 1, expect = genuine]
oops

lemma "P x \<equiv> P x"
nitpick [card = 1-10, expect = none]
by auto

lemma "P x \<equiv> Q x \<Longrightarrow> P x = Q x"
nitpick [card = 1-10, expect = none]
by auto

lemma "P x = Q x \<Longrightarrow> P x \<equiv> Q x"
nitpick [card = 1-10, expect = none]
by auto

lemma "x \<equiv> (op \<Longrightarrow>) \<Longrightarrow> False"
nitpick [expect = genuine]
oops

lemma "I \<equiv> (\<lambda>x. x) \<Longrightarrow> (op \<Longrightarrow> x) \<equiv> (\<lambda>y. (op \<Longrightarrow> x (I y)))"
nitpick [expect = none]
by auto

lemma "P x \<Longrightarrow> P x"
nitpick [card = 1-10, expect = none]
by auto

lemma "True \<Longrightarrow> True" "False \<Longrightarrow> True" "False \<Longrightarrow> False"
nitpick [expect = none]
by auto

lemma "True \<Longrightarrow> False"
nitpick [expect = genuine]
oops

lemma "x = Not"
nitpick [expect = genuine]
oops

lemma "I = (\<lambda>x. x) \<Longrightarrow> Not = (\<lambda>x. Not (I x))"
nitpick [expect = none]
by auto

lemma "x = True"
nitpick [expect = genuine]
oops

lemma "x = False"
nitpick [expect = genuine]
oops

lemma "x = undefined"
nitpick [expect = genuine]
oops

lemma "(False, ()) = undefined \<Longrightarrow> ((), False) = undefined"
nitpick [expect = genuine]
oops

lemma "undefined = undefined"
nitpick [expect = none]
by auto

lemma "f undefined = f undefined"
nitpick [expect = none]
by auto

lemma "f undefined = g undefined"
nitpick [card = 33, expect = genuine]
oops

lemma "\<exists>!x. x = undefined"
nitpick [card = 15, expect = none]
by auto

lemma "x = All \<Longrightarrow> False"
nitpick [card = 1, dont_box, expect = genuine]
oops

lemma "\<forall>x. f x y = f x y"
nitpick [expect = none]
oops

lemma "\<forall>x. f x y = f y x"
nitpick [expect = genuine]
oops

lemma "All (\<lambda>x. f x y = f x y) = True"
nitpick [expect = none]
by auto

lemma "All (\<lambda>x. f x y = f x y) = False"
nitpick [expect = genuine]
oops

lemma "x = Ex \<Longrightarrow> False"
nitpick [card = 1, dont_box, expect = genuine]
oops

lemma "\<exists>x. f x y = f x y"
nitpick [expect = none]
oops

lemma "\<exists>x. f x y = f y x"
nitpick [expect = none]
oops

lemma "Ex (\<lambda>x. f x y = f x y) = True"
nitpick [expect = none]
by auto

lemma "Ex (\<lambda>x. f x y = f y x) = True"
nitpick [expect = none]
by auto

lemma "Ex (\<lambda>x. f x y = f x y) = False"
nitpick [expect = genuine]
oops

lemma "Ex (\<lambda>x. f x y \<noteq> f x y) = False"
nitpick [expect = none]
by auto

lemma "I = (\<lambda>x. x) \<Longrightarrow> Ex P = Ex (\<lambda>x. P (I x))"
nitpick [expect = none]
by auto

lemma "x = y \<Longrightarrow> y = x"
nitpick [expect = none]
by auto

lemma "x = y \<Longrightarrow> f x = f y"
nitpick [expect = none]
by auto

lemma "x = y \<and> y = z \<Longrightarrow> x = z"
nitpick [expect = none]
by auto

lemma "I = (\<lambda>x. x) \<Longrightarrow> (op \<and>) = (\<lambda>x. op \<and> (I x))"
      "I = (\<lambda>x. x) \<Longrightarrow> (op \<and>) = (\<lambda>x y. x \<and> (I y))"
nitpick [expect = none]
by auto

lemma "(a \<and> b) = (\<not> (\<not> a \<or> \<not> b))"
nitpick [expect = none]
by auto

lemma "a \<and> b \<Longrightarrow> a" "a \<and> b \<Longrightarrow> b"
nitpick [expect = none]
by auto

lemma "(op \<longrightarrow>) = (\<lambda>x. op\<longrightarrow> x)" "(op\<longrightarrow> ) = (\<lambda>x y. x \<longrightarrow> y)"
nitpick [expect = none]
by auto

lemma "((if a then b else c) = d) = ((a \<longrightarrow> (b = d)) \<and> (\<not> a \<longrightarrow> (c = d)))"
nitpick [expect = none]
by auto

lemma "(if a then b else c) = (THE d. (a \<longrightarrow> (d = b)) \<and> (\<not> a \<longrightarrow> (d = c)))"
nitpick [expect = none]
by auto

lemma "fst (x, y) = x"
nitpick [expect = none]
by (simp add: fst_def)

lemma "snd (x, y) = y"
nitpick [expect = none]
by (simp add: snd_def)

lemma "fst (x\<Colon>'a\<Rightarrow>'b, y) = x"
nitpick [expect = none]
by (simp add: fst_def)

lemma "snd (x\<Colon>'a\<Rightarrow>'b, y) = y"
nitpick [expect = none]
by (simp add: snd_def)

lemma "fst (x, y\<Colon>'a\<Rightarrow>'b) = x"
nitpick [expect = none]
by (simp add: fst_def)

lemma "snd (x, y\<Colon>'a\<Rightarrow>'b) = y"
nitpick [expect = none]
by (simp add: snd_def)

lemma "fst (x\<Colon>'a\<times>'b, y) = x"
nitpick [expect = none]
by (simp add: fst_def)

lemma "snd (x\<Colon>'a\<times>'b, y) = y"
nitpick [expect = none]
by (simp add: snd_def)

lemma "fst (x, y\<Colon>'a\<times>'b) = x"
nitpick [expect = none]
by (simp add: fst_def)

lemma "snd (x, y\<Colon>'a\<times>'b) = y"
nitpick [expect = none]
by (simp add: snd_def)

lemma "I = (\<lambda>x. x) \<Longrightarrow> fst = (\<lambda>x. fst (I x))"
nitpick [expect = none]
by auto

lemma "fst (x, y) = snd (y, x)"
nitpick [expect = none]
by auto

lemma "(x, x) \<in> Id"
nitpick [expect = none]
by auto

lemma "(x, y) \<in> Id \<Longrightarrow> x = y"
nitpick [expect = none]
by auto

lemma "I = (\<lambda>x. x) \<Longrightarrow> Id = {x. I x \<in> Id}"
nitpick [expect = none]
by auto

lemma "{} = {x. False}"
nitpick [expect = none]
by (metis empty_def)

lemma "x \<in> {}"
nitpick [expect = genuine]
oops

lemma "{a, b} = {b}"
nitpick [expect = genuine]
oops

lemma "{a, b} \<noteq> {b}"
nitpick [expect = genuine]
oops

lemma "{a} = {b}"
nitpick [expect = genuine]
oops

lemma "{a} \<noteq> {b}"
nitpick [expect = genuine]
oops

lemma "{a, b, c} = {c, b, a}"
nitpick [expect = none]
by auto

lemma "UNIV = {x. True}"
nitpick [expect = none]
by (simp only: UNIV_def)

lemma "x \<in> UNIV \<longleftrightarrow> True"
nitpick [expect = none]
by (simp only: UNIV_def mem_Collect_eq)

lemma "x \<notin> UNIV"
nitpick [expect = genuine]
oops

lemma "I = (\<lambda>x. x) \<Longrightarrow> op \<in> = (\<lambda>x. (op \<in> (I x)))"
nitpick [expect = none]
apply (rule ext)
apply (rule ext)
by simp

lemma "insert = (\<lambda>x y. insert x (y \<union> y))"
nitpick [expect = none]
by simp

lemma "I = (\<lambda>x. x) \<Longrightarrow> trancl = (\<lambda>x. trancl (I x))"
nitpick [card = 1-2, expect = none]
by auto

lemma "rtrancl = (\<lambda>x. rtrancl x \<union> {(y, y)})"
nitpick [card = 1-3, expect = none]
apply (rule ext)
by auto

lemma "(x, x) \<in> rtrancl {(y, y)}"
nitpick [expect = none]
by auto

lemma "((x, x), (x, x)) \<in> rtrancl {}"
nitpick [card = 1-5, expect = none]
by auto

lemma "I = (\<lambda>x. x) \<Longrightarrow> op \<union> = (\<lambda>x. op \<union> (I x))"
nitpick [card = 1-5, expect = none]
by auto

lemma "a \<in> A \<Longrightarrow> a \<in> (A \<union> B)" "b \<in> B \<Longrightarrow> b \<in> (A \<union> B)"
nitpick [expect = none]
by auto

lemma "I = (\<lambda>x. x) \<Longrightarrow> op \<inter> = (\<lambda>x. op \<inter> (I x))"
nitpick [card = 1-5, expect = none]
by auto

lemma "a \<notin> A \<Longrightarrow> a \<notin> (A \<inter> B)" "b \<notin> B \<Longrightarrow> b \<notin> (A \<inter> B)"
nitpick [card = 1-5, expect = none]
by auto

lemma "x \<in> ((A\<Colon>'a set) - B) \<longleftrightarrow> x \<in> A \<and> x \<notin> B"
nitpick [card = 1-5, expect = none]
by auto

lemma "I = (\<lambda>x. x) \<Longrightarrow> op \<subset> = (\<lambda>x. op \<subset> (I x))"
nitpick [card = 1-5, expect = none]
by auto

lemma "A \<subset> B \<Longrightarrow> (\<forall>a \<in> A. a \<in> B) \<and> (\<exists>b \<in> B. b \<notin> A)"
nitpick [card = 1-5, expect = none]
by auto

lemma "A \<subseteq> B \<Longrightarrow> \<forall>a \<in> A. a \<in> B"
nitpick [card = 1-5, expect = none]
by auto

lemma "A \<subseteq> B \<Longrightarrow> A \<subset> B"
nitpick [card = 5, expect = genuine]
oops

lemma "A \<subset> B \<Longrightarrow> A \<subseteq> B"
nitpick [expect = none]
by auto

lemma "I = (\<lambda>x\<Colon>'a set. x) \<Longrightarrow> uminus = (\<lambda>x. uminus (I x))"
nitpick [card = 1-7, expect = none]
by auto

lemma "A \<union> - A = UNIV"
nitpick [expect = none]
by auto

lemma "A \<inter> - A = {}"
nitpick [expect = none]
by auto

lemma "A = -(A\<Colon>'a set)"
nitpick [card 'a = 10, expect = genuine]
oops

lemma "finite A"
nitpick [expect = none]
oops

lemma "finite A \<Longrightarrow> finite B"
nitpick [expect = none]
oops

lemma "All finite"
nitpick [expect = none]
oops

subsection {* The and Eps *}

lemma "x = The"
nitpick [card = 5, expect = genuine]
oops

lemma "\<exists>x. x = The"
nitpick [card = 1-3]
by auto

lemma "P x \<and> (\<forall>y. P y \<longrightarrow> y = x) \<longrightarrow> The P = x"
nitpick [expect = none]
by auto

lemma "P x \<and> P y \<and> x \<noteq> y \<longrightarrow> The P = z"
nitpick [expect = genuine]
oops

lemma "P x \<and> P y \<and> x \<noteq> y \<longrightarrow> The P = x \<or> The P = y"
nitpick [card = 2, expect = none]
nitpick [card = 3-5, expect = genuine]
oops

lemma "P x \<Longrightarrow> P (The P)"
nitpick [card = 1-2, expect = none]
nitpick [card = 8, expect = genuine]
oops

lemma "(\<forall>x. \<not> P x) \<longrightarrow> The P = y"
nitpick [expect = genuine]
oops

lemma "I = (\<lambda>x. x) \<Longrightarrow> The = (\<lambda>x. The (I x))"
nitpick [card = 1-5, expect = none]
by auto

lemma "x = Eps"
nitpick [card = 5, expect = genuine]
oops

lemma "\<exists>x. x = Eps"
nitpick [card = 1-3, expect = none]
by auto

lemma "P x \<and> (\<forall>y. P y \<longrightarrow> y = x) \<longrightarrow> Eps P = x"
nitpick [expect = none]
by auto

lemma "P x \<and> P y \<and> x \<noteq> y \<longrightarrow> Eps P = z"
nitpick [expect = genuine]
apply auto
oops

lemma "P x \<Longrightarrow> P (Eps P)"
nitpick [card = 1-8, expect = none]
by (metis exE_some)

lemma "\<forall>x. \<not> P x \<longrightarrow> Eps P = y"
nitpick [expect = genuine]
oops

lemma "P (Eps P)"
nitpick [expect = genuine]
oops

lemma "Eps (\<lambda>x. x \<in> P) \<in> (P\<Colon>nat set)"
nitpick [expect = genuine]
oops

lemma "\<not> P (Eps P)"
nitpick [expect = genuine]
oops

lemma "\<not> (P \<Colon> nat \<Rightarrow> bool) (Eps P)"
nitpick [expect = genuine]
oops

lemma "P \<noteq> bot \<Longrightarrow> P (Eps P)"
nitpick [expect = none]
sorry

lemma "(P \<Colon> nat \<Rightarrow> bool) \<noteq> bot \<Longrightarrow> P (Eps P)"
nitpick [expect = none]
sorry

lemma "P (The P)"
nitpick [expect = genuine]
oops

lemma "(P \<Colon> nat \<Rightarrow> bool) (The P)"
nitpick [expect = genuine]
oops

lemma "\<not> P (The P)"
nitpick [expect = genuine]
oops

lemma "\<not> (P \<Colon> nat \<Rightarrow> bool) (The P)"
nitpick [expect = genuine]
oops

lemma "The P \<noteq> x"
nitpick [expect = genuine]
oops

lemma "The P \<noteq> (x\<Colon>nat)"
nitpick [expect = genuine]
oops

lemma "P x \<Longrightarrow> P (The P)"
nitpick [expect = genuine]
oops

lemma "P (x\<Colon>nat) \<Longrightarrow> P (The P)"
nitpick [expect = genuine]
oops

lemma "P = {x} \<Longrightarrow> (THE x. x \<in> P) \<in> P"
nitpick [expect = none]
oops

lemma "P = {x\<Colon>nat} \<Longrightarrow> (THE x. x \<in> P) \<in> P"
nitpick [expect = none]
oops

consts Q :: 'a

lemma "Q (Eps Q)"
nitpick [expect = genuine]
oops

lemma "(Q \<Colon> nat \<Rightarrow> bool) (Eps Q)"
nitpick [expect = none] (* unfortunate *)
oops

lemma "\<not> (Q \<Colon> nat \<Rightarrow> bool) (Eps Q)"
nitpick [expect = genuine]
oops

lemma "\<not> (Q \<Colon> nat \<Rightarrow> bool) (Eps Q)"
nitpick [expect = genuine]
oops

lemma "(Q\<Colon>'a \<Rightarrow> bool) \<noteq> bot \<Longrightarrow> (Q\<Colon>'a \<Rightarrow> bool) (Eps Q)"
nitpick [expect = none]
sorry

lemma "(Q\<Colon>nat \<Rightarrow> bool) \<noteq> bot \<Longrightarrow> (Q\<Colon>nat \<Rightarrow> bool) (Eps Q)"
nitpick [expect = none]
sorry

lemma "Q (The Q)"
nitpick [expect = genuine]
oops

lemma "(Q\<Colon>nat \<Rightarrow> bool) (The Q)"
nitpick [expect = genuine]
oops

lemma "\<not> Q (The Q)"
nitpick [expect = genuine]
oops

lemma "\<not> (Q\<Colon>nat \<Rightarrow> bool) (The Q)"
nitpick [expect = genuine]
oops

lemma "The Q \<noteq> x"
nitpick [expect = genuine]
oops

lemma "The Q \<noteq> (x\<Colon>nat)"
nitpick [expect = genuine]
oops

lemma "Q x \<Longrightarrow> Q (The Q)"
nitpick [expect = genuine]
oops

lemma "Q (x\<Colon>nat) \<Longrightarrow> Q (The Q)"
nitpick [expect = genuine]
oops

lemma "Q = (\<lambda>x\<Colon>'a. x = a) \<Longrightarrow> (Q\<Colon>'a \<Rightarrow> bool) (The Q)"
nitpick [expect = none]
sorry

lemma "Q = (\<lambda>x\<Colon>nat. x = a) \<Longrightarrow> (Q\<Colon>nat \<Rightarrow> bool) (The Q)"
nitpick [expect = none]
sorry

nitpick_params [max_potential = 1]

lemma "(THE j. j > Suc 2 \<and> j \<le> 3) \<noteq> 0"
nitpick [card nat = 2, expect = potential]
nitpick [card nat = 6, expect = potential] (* unfortunate *)
oops

lemma "(THE j. j > Suc 2 \<and> j \<le> 4) = x \<Longrightarrow> x \<noteq> 0"
nitpick [card nat = 2, expect = potential]
nitpick [card nat = 6, expect = none]
sorry

lemma "(THE j. j > Suc 2 \<and> j \<le> 4) = x \<Longrightarrow> x = 4"
nitpick [card nat = 2, expect = potential]
nitpick [card nat = 6, expect = none]
sorry

lemma "(THE j. j > Suc 2 \<and> j \<le> 5) = x \<Longrightarrow> x = 4"
nitpick [card nat = 6, expect = genuine]
oops

lemma "(THE j. j > Suc 2 \<and> j \<le> 5) = x \<Longrightarrow> x = 4 \<or> x = 5"
nitpick [card nat = 6, expect = genuine]
oops

lemma "(SOME j. j > Suc 2 \<and> j \<le> 3) \<noteq> 0"
nitpick [card nat = 2, expect = potential]
nitpick [card nat = 6, expect = genuine]
oops

lemma "(SOME j. j > Suc 2 \<and> j \<le> 4) = x \<Longrightarrow> x \<noteq> 0"
nitpick [card nat = 2, expect = potential]
nitpick [card nat = 6, expect = none]
oops

lemma "(SOME j. j > Suc 2 \<and> j \<le> 4) = x \<Longrightarrow> x = 4"
nitpick [card nat = 2, expect = potential]
nitpick [card nat = 6, expect = none]
sorry

lemma "(SOME j. j > Suc 2 \<and> j \<le> 5) = x \<Longrightarrow> x = 4"
nitpick [card nat = 6, expect = genuine]
oops

lemma "(SOME j. j > Suc 2 \<and> j \<le> 5) = x \<Longrightarrow> x = 4 \<or> x = 5"
nitpick [card nat = 6, expect = none]
sorry

nitpick_params [max_potential = 0]

subsection {* Destructors and Recursors *}

lemma "(x\<Colon>'a) = (case True of True \<Rightarrow> x | False \<Rightarrow> x)"
nitpick [card = 2, expect = none]
by auto

lemma "x = (case (x, y) of (x', y') \<Rightarrow> x')"
nitpick [expect = none]
sorry

end


(* Author: Maximilian Schäffeler *)
section \<open>Bounded Linear Functions\<close>
theory Blinfun_Util
  imports
    "HOL-Analysis.Bounded_Linear_Function"
    Bounded_Functions
begin

subsection \<open>Composition\<close>

lemma blinfun_compose_id[simp]:
  "id_blinfun o\<^sub>L f = f"
  "f o\<^sub>L id_blinfun = f"
  by (auto intro!: blinfun_eqI)

lemma blinfun_compose_assoc: "F o\<^sub>L G o\<^sub>L H = F o\<^sub>L (G o\<^sub>L H)"
  using blinfun_apply_inject by fastforce

lemma blinfun_compose_diff_right: "f o\<^sub>L (g - h) = (f o\<^sub>L g) - (f o\<^sub>L h)"
  by (auto intro!: blinfun_eqI simp: blinfun.bilinear_simps)

subsection \<open>Power\<close>

overloading
  blinfunpow \<equiv> "compow :: nat \<Rightarrow> ('a::real_normed_vector \<Rightarrow>\<^sub>L 'a) \<Rightarrow> ('a \<Rightarrow>\<^sub>L 'a)"
begin

primrec blinfunpow :: "nat \<Rightarrow> ('a::real_normed_vector \<Rightarrow>\<^sub>L 'a) \<Rightarrow> ('a \<Rightarrow>\<^sub>L 'a)"
  where
    "blinfunpow 0 f = id_blinfun"
  | "blinfunpow (Suc n) f = f o\<^sub>L blinfunpow n f"

end

lemma bounded_pow_blinfun[intro]:
  assumes "bounded (range (F::nat \<Rightarrow> 'a::real_normed_vector \<Rightarrow>\<^sub>L 'a))"
  shows "bounded (range (\<lambda>t. (F t)^^(Suc n)))"
  using assms proof -
  assume "bounded (range F)"
  then obtain b where bh: "\<And>x. norm (F x) \<le> b"
    by (auto simp: bounded_iff)
  hence "norm ((F x)^^(Suc n)) \<le> b^(Suc n)" for x
    using bh
    by (induction n) (auto intro!: order.trans[OF norm_blinfun_compose] simp: mult_mono')
  thus ?thesis
    by (auto intro!: boundedI)
qed

lemma blincomp_scaleR_right: "(a *\<^sub>R (F :: 'a :: real_normed_vector \<Rightarrow>\<^sub>L 'a)) ^^ t = a^t *\<^sub>R F^^t"
  by (induction t) (auto intro: blinfun_eqI simp: blinfun.scaleR_left blinfun.scaleR_right)
lemma summable_inv_Q:
  fixes Q :: "'a :: banach \<Rightarrow>\<^sub>L 'a"
  assumes onorm_le: "norm (id_blinfun - Q) < 1"
  shows "summable (\<lambda>n. (id_blinfun - Q)^^n)"
  using onorm_le norm_blinfun_compose
  by (force intro!: summable_ratio_test)

lemma blinfunpow_assoc: "(F::'a::real_normed_vector \<Rightarrow>\<^sub>L 'a) ^^ (Suc n) =(F ^^n) o\<^sub>L F"
  by (induction n) (auto simp: blinfun_compose_assoc[symmetric])

lemma norm_blinfunpow_le: "norm ((f :: 'b :: real_normed_vector \<Rightarrow>\<^sub>L 'b) ^^ n) \<le> norm f ^ n"
  by (induction n) (auto simp: norm_blinfun_id_le intro!: order.trans[OF norm_blinfun_compose] mult_left_mono)

lemma blinfunpow_nonneg:
  assumes "\<And>v. 0 \<le> v \<Longrightarrow> 0 \<le> blinfun_apply (f :: ('b :: {ord, real_normed_vector} \<Rightarrow>\<^sub>L 'b)) v"
  shows "0 \<le> v \<Longrightarrow> 0 \<le> (f^^n) v"
  by(induction n) (auto simp: assms)

lemma blinfunpow_mono:
  assumes "\<And>u v. u \<le> v \<Longrightarrow> (f :: 'b :: {ord, real_normed_vector} \<Rightarrow>\<^sub>L 'b) u \<le> f v"
  shows "u \<le> v \<Longrightarrow> (f^^n) u \<le> (f^^n) v"
  by (induction n) (auto simp: assms)

lemma banach_blinfun:
  fixes C :: "'b :: {real_normed_vector, complete_space} \<Rightarrow>\<^sub>L 'b"
  assumes "norm C < 1"
  shows "\<exists>!v. C v = v" "\<And>v. (\<lambda>n. (C ^^ n) v) \<longlonglongrightarrow> (THE v. C v = v)"
  using assms
proof -
  obtain v where "C v = v" "\<forall>v'. C v' = v' \<longrightarrow> v' = v"
    using assms banach_fix_type[of "norm C" "blinfun_apply C"]
    by (metis blinfun.zero_right less_irrefl mult.left_neutral mult_less_le_imp_less
        norm_blinfun norm_conv_dist norm_ge_zero zero_less_dist_iff)
  obtain l where "(\<forall>v u. norm (C (v - u)) \<le> l * dist v u)" "0 \<le> l" "l < 1"
    by (metis assms dist_norm norm_blinfun norm_imp_pos_and_ge)
  hence 1: "dist (C v) (C u) \<le> l * dist v u" for v u
    by (simp add: blinfun.diff_right dist_norm)
  have 2: "dist ((C ^^ n) v0) v \<le> l ^ n * dist v0 v" for n v0
    using \<open>0 \<le> l\<close>
    by (induction n) (auto simp: mult.assoc
        intro!: mult_mono' order.trans[OF 1[of _ v , unfolded \<open>C v = v\<close>]])
  have "(\<lambda>n. l ^ n) \<longlonglongrightarrow> 0"
    by (simp add: LIMSEQ_realpow_zero \<open>0 \<le> l\<close> \<open>l < 1\<close>)
  hence k: "\<And>v0. (\<lambda>n. l ^ n * dist v0 v) \<longlonglongrightarrow> 0"
    by (auto simp add: tendsto_mult_left_zero)
  have "(\<lambda>n. dist ((C ^^ n) v0) v) \<longlonglongrightarrow> 0" for v0
    using k 2 order_trans abs_ge_self
    by (subst Limits.tendsto_0_le[where ?K = 1, where ?f = "(\<lambda>n. l ^ n * dist v0 v)"])
      (fastforce intro: eventuallyI)+
  hence "\<And>v0. (\<lambda>n. (C ^^ n) v0) \<longlonglongrightarrow> v"
    using tendsto_dist_iff
    by blast
  thus "(\<lambda>n. (C ^^ n) v0) \<longlonglongrightarrow> (THE v. C v = v)" for v0
    using theI'[of "\<lambda>x. C x = x"] \<open>C v = v\<close> \<open>\<forall>v'. C v' = v' \<longrightarrow> v' = v\<close>
    by blast
next
  show "norm C < 1 \<Longrightarrow> \<exists>!v. blinfun_apply C v = v"
    by (auto intro!: banach_fix_type[OF _ assms]
        simp: dist_norm norm_blinfun blinfun.diff_right[symmetric])
qed

subsection \<open>Geometric Sum\<close>

lemma inv_one_sub_Q:
  fixes Q :: "'a :: banach \<Rightarrow>\<^sub>L 'a"
  assumes onorm_le: "norm (id_blinfun - Q) < 1"
  shows "(Q o\<^sub>L (\<Sum>i. (id_blinfun - Q)^^i)) = id_blinfun"
    and "(\<Sum>i. (id_blinfun - Q)^^i) o\<^sub>L Q = id_blinfun"
proof -
  obtain b where bh: "b < 1"  "norm (id_blinfun - Q) < b"
    using onorm_le dense
    by blast
  have "0 < b"
    using le_less_trans[OF norm_ge_zero bh(2)] .
  have norm_le_aux: "norm ((id_blinfun - Q)^^Suc n) \<le> b^(Suc n)" for n
  proof (induction n)
    case 0
    thus ?case
      using bh
      by simp
  next
    case (Suc n)
    thus ?case
    proof -
      have "norm ((id_blinfun - Q) ^^ Suc (Suc n)) \<le> norm (id_blinfun - Q) * norm((id_blinfun - Q) ^^ Suc n)"
        using norm_blinfun_compose
        by auto
      thus ?thesis
        using Suc.IH \<open>0 < b\<close> bh order.trans
        by (fastforce simp: mult_mono')
    qed
  qed
  have "(Q o\<^sub>L (\<Sum>i\<le>n. (id_blinfun - Q)^^i)) = (id_blinfun - (id_blinfun - Q)^^(Suc n))" for n
    by (induction n)  (auto simp: bounded_bilinear.diff_left bounded_bilinear.add_right
        bounded_bilinear_blinfun_compose)
  hence "\<And>n. norm (id_blinfun - (Q o\<^sub>L (\<Sum>i\<le>n. (id_blinfun - Q)^^i))) \<le> b^Suc n"
    using norm_le_aux
    by auto
  hence l2: "(\<lambda>n. (id_blinfun - (Q o\<^sub>L (\<Sum>i\<le>n. (id_blinfun - Q)^^i)))) \<longlonglongrightarrow> 0"
    using \<open>0 < b\<close> bh
    by (subst Lim_transform_bound[where g="\<lambda>n. b^Suc n"]) (auto intro!: tendsto_eq_intros)
  have "summable (\<lambda>n. (id_blinfun - Q)^^n)"
    using onorm_le norm_blinfun_compose
    by (force intro!: summable_ratio_test)
  hence "(\<lambda>n. \<Sum>i\<le>n.  (id_blinfun - Q)^^i) \<longlonglongrightarrow> (\<Sum>i. (id_blinfun - Q)^^i)"
    using summable_LIMSEQ'
    by blast
  hence "(\<lambda>n. Q o\<^sub>L (\<Sum>i\<le>n. (id_blinfun - Q)^^i)) \<longlonglongrightarrow> (Q o\<^sub>L (\<Sum>i. (id_blinfun - Q)^^i))"
    using bounded_bilinear_blinfun_compose
    by (subst Limits.bounded_bilinear.tendsto[where prod = "(o\<^sub>L)"]) auto
  hence "(\<lambda>n. id_blinfun - (Q o\<^sub>L (\<Sum>i\<le>n. (id_blinfun - Q)^^i))) \<longlonglongrightarrow>
    id_blinfun - (Q o\<^sub>L (\<Sum>i. (id_blinfun - Q)^^i))"
    by (subst Limits.tendsto_diff) auto
  thus "(Q o\<^sub>L (\<Sum>i. (id_blinfun - Q)^^i)) = id_blinfun"
    using LIMSEQ_unique l2 by fastforce

  have "((\<Sum>i\<le>n. (id_blinfun - Q)^^i) o\<^sub>L Q) = (id_blinfun - (id_blinfun - Q)^^(Suc n))" for n
  proof (induction n)
    case (Suc n)
    have "sum ((^^) (id_blinfun - Q)) {..Suc n} o\<^sub>L Q =
        (sum ((^^) (id_blinfun - Q)) {..n} o\<^sub>L Q) + ((id_blinfun - Q) ^^Suc n o\<^sub>L Q)"
      by (simp add: bounded_bilinear.add_left bounded_bilinear_blinfun_compose)
    also have "\<dots> = id_blinfun - (((id_blinfun - Q)^^(Suc n) o\<^sub>L id_blinfun) -
        ((id_blinfun - Q) ^^Suc n o\<^sub>L Q))"
      using Suc.IH
      by auto
    also have "\<dots> = id_blinfun - (((id_blinfun - Q)^^(Suc n) o\<^sub>L (id_blinfun - Q)))"
      by (auto intro!: blinfun_eqI simp: blinfun.diff_right blinfun.diff_left blinfun.minus_left)
    also have "\<dots> = id_blinfun - (((id_blinfun - Q)^^(Suc (Suc n))))"
      using blinfunpow_assoc
      by metis
    finally show ?case
      by auto
  qed simp
  hence "\<And>n. norm (id_blinfun - ((\<Sum>i\<le>n. (id_blinfun - Q)^^i) o\<^sub>L Q)) \<le> b^Suc n"
    using norm_le_aux by auto
  hence l2: "(\<lambda>n. id_blinfun - ((\<Sum>i\<le>n. (id_blinfun - Q)^^i) o\<^sub>L Q)) \<longlonglongrightarrow> 0"
    using \<open>0 < b\<close> bh
    by (subst Lim_transform_bound[where g="\<lambda>n. b^Suc n"]) (auto intro!: tendsto_eq_intros)
  have "summable (\<lambda>n. (id_blinfun - Q)^^n)"
    using local.onorm_le norm_blinfun_compose
    by (force intro!: summable_ratio_test)
  hence "(\<lambda>n. \<Sum>i\<le>n.  (id_blinfun - Q)^^i) \<longlonglongrightarrow> (\<Sum>i. (id_blinfun - Q)^^i)"
    using summable_LIMSEQ' by blast
  hence "(\<lambda>n. (\<Sum>i\<le>n. (id_blinfun - Q)^^i) o\<^sub>L Q) \<longlonglongrightarrow> ((\<Sum>i. (id_blinfun - Q)^^i) o\<^sub>L Q)"
    using bounded_bilinear_blinfun_compose
    by (subst Limits.bounded_bilinear.tendsto[where prod = "(o\<^sub>L)"]) auto
  hence "(\<lambda>n. id_blinfun - ((\<Sum>i\<le>n. (id_blinfun - Q)^^i) o\<^sub>L Q)) \<longlonglongrightarrow>
    id_blinfun - ((\<Sum>i. (id_blinfun - Q)^^i) o\<^sub>L Q)"
    by (subst Limits.tendsto_diff) auto
  thus "((\<Sum>i. (id_blinfun - Q)^^i) o\<^sub>L Q) = id_blinfun"
    using LIMSEQ_unique l2 by fastforce
qed

lemma inv_norm_le:
  fixes Q :: "'a :: banach \<Rightarrow>\<^sub>L 'a"
  assumes "norm Q  < 1"
  shows "(id_blinfun-Q) o\<^sub>L (\<Sum>i. Q^^i) = id_blinfun"
    "(\<Sum>i. Q^^i) o\<^sub>L (id_blinfun-Q) = id_blinfun"
  using inv_one_sub_Q[of "id_blinfun - Q"] assms
  by auto

lemma inv_norm_le':
  fixes Q :: "'a :: banach \<Rightarrow>\<^sub>L 'a"
  assumes "norm Q  < 1"
  shows "(id_blinfun-Q) ((\<Sum>i. Q^^i) x) = x"
    "(\<Sum>i. Q^^i) ((id_blinfun-Q) x) = x"
  using inv_norm_le assms
  by (auto simp del: blinfun_apply_blinfun_compose
      simp: inv_norm_le blinfun_apply_blinfun_compose[symmetric])

subsection \<open>Inverses\<close>

definition "is_inverse\<^sub>L X Y \<longleftrightarrow> X o\<^sub>L Y = id_blinfun \<and> Y o\<^sub>L X = id_blinfun"

abbreviation "invertible\<^sub>L X \<equiv> \<exists>X'. is_inverse\<^sub>L X X'"

lemma is_inverse\<^sub>L_I[intro]:
  assumes "X o\<^sub>L Y = id_blinfun" "Y o\<^sub>L X = id_blinfun"
  shows "is_inverse\<^sub>L X Y"
  using assms
  unfolding is_inverse\<^sub>L_def
  by auto

lemma is_inverse\<^sub>L_D[dest]:
  assumes "is_inverse\<^sub>L X Y"
  shows "X o\<^sub>L Y = id_blinfun" "Y o\<^sub>L X = id_blinfun"
  using assms
  unfolding is_inverse\<^sub>L_def
  by auto

lemma invertible\<^sub>L_D[dest]:
  assumes "invertible\<^sub>L f"
  obtains g where "f o\<^sub>L g = id_blinfun" "g o\<^sub>L f = id_blinfun"
  using assms
  by auto

lemma invertible\<^sub>L_I[intro]:
  assumes "f o\<^sub>L g = id_blinfun" "g o\<^sub>L f = id_blinfun"
  shows "invertible\<^sub>L f"
  using assms
  by auto

lemma is_inverse\<^sub>L_comm: "is_inverse\<^sub>L X Y \<longleftrightarrow> is_inverse\<^sub>L Y X"
  by auto

lemma is_inverse\<^sub>L_unique: "is_inverse\<^sub>L f g \<Longrightarrow> is_inverse\<^sub>L f h \<Longrightarrow> g = h"
  unfolding is_inverse\<^sub>L_def
  using blinfun_compose_assoc  blinfun_compose_id(1)
  by metis

lemma is_inverse\<^sub>L_ex1: "is_inverse\<^sub>L f g \<Longrightarrow> \<exists>!h. is_inverse\<^sub>L f h"
  using is_inverse\<^sub>L_unique
  by auto

lemma is_inverse\<^sub>L_ex1': "\<exists>x. is_inverse\<^sub>L f x \<Longrightarrow> \<exists>!x. is_inverse\<^sub>L f x"
  using is_inverse\<^sub>L_ex1
  by auto

definition "inv\<^sub>L f = (THE g. is_inverse\<^sub>L f g)"

lemma inv\<^sub>L_eq:
  assumes "is_inverse\<^sub>L f g"
  shows "inv\<^sub>L f = g"
  unfolding inv\<^sub>L_def
  using assms is_inverse\<^sub>L_ex1
  by (auto intro!: the_equality)

lemma inv\<^sub>L_I:
  assumes "f o\<^sub>L g = id_blinfun" "g o\<^sub>L f = id_blinfun"
  shows "g = inv\<^sub>L f"
  using assms inv\<^sub>L_eq
  unfolding is_inverse\<^sub>L_def
  by auto

lemma inv_app1 [simp]: "invertible\<^sub>L X \<Longrightarrow> (inv\<^sub>L X) o\<^sub>L X = id_blinfun"
  using is_inverse\<^sub>L_ex1' inv\<^sub>L_eq
  by blast

lemma inv_app2[simp]: "invertible\<^sub>L X \<Longrightarrow> X o\<^sub>L (inv\<^sub>L X)  = id_blinfun"
  using is_inverse\<^sub>L_ex1' inv\<^sub>L_eq
  by blast

lemma inv_app1'[simp]: "invertible\<^sub>L X \<Longrightarrow> inv\<^sub>L X (X v) = v"
  using inv_app1 blinfun_apply_blinfun_compose id_blinfun.rep_eq
  by metis

lemma inv_app2'[simp]: "invertible\<^sub>L X \<Longrightarrow> X (inv\<^sub>L X v) = v"
  using inv_app2 blinfun_apply_blinfun_compose id_blinfun.rep_eq
  by metis

lemma inv\<^sub>L_inv\<^sub>L[simp]: "invertible\<^sub>L X \<Longrightarrow> inv\<^sub>L (inv\<^sub>L X) = X"
  by (metis inv\<^sub>L_eq is_inverse\<^sub>L_comm)

lemma inv\<^sub>L_cancel_iff:
  assumes "invertible\<^sub>L f"
  shows "f x = y \<longleftrightarrow> x = inv\<^sub>L f y"
  by (auto simp add: assms)

lemma invertible\<^sub>L_inf_sum:
  assumes "norm (X :: 'b :: banach \<Rightarrow>\<^sub>L 'b) < 1"
  shows "invertible\<^sub>L (id_blinfun - X)"
  using Blinfun_Util.inv_norm_le[OF assms] assms
  by blast

lemma inv\<^sub>L_inf_sum:
  fixes X :: "'b :: banach \<Rightarrow>\<^sub>L _"
  assumes "norm X < 1"
  shows "inv\<^sub>L (id_blinfun - X) = (\<Sum>i. X ^^ i)"
  using Blinfun_Util.inv_norm_le[OF assms] assms
  by (auto simp: inv\<^sub>L_I[symmetric])

lemma is_inverse\<^sub>L_compose:
  assumes "invertible\<^sub>L f" "invertible\<^sub>L g"
  shows "is_inverse\<^sub>L (f o\<^sub>L g) (inv\<^sub>L g o\<^sub>L inv\<^sub>L f)"
  by (auto intro!: blinfun_eqI is_inverse\<^sub>L_I[of _ "inv\<^sub>L g o\<^sub>L inv\<^sub>L f"]
      simp: inv_app2'[OF assms(1)] inv_app2'[OF assms(2)] inv_app1'[OF assms(1)] inv_app1'[OF assms(2)])

lemma invertible\<^sub>L_compose: "invertible\<^sub>L f \<Longrightarrow> invertible\<^sub>L g \<Longrightarrow> invertible\<^sub>L (f o\<^sub>L g)"
  using is_inverse\<^sub>L_compose
  by blast

lemma inv\<^sub>L_compose:
  assumes "invertible\<^sub>L f" "invertible\<^sub>L g"
  shows"inv\<^sub>L (f o\<^sub>L g) = (inv\<^sub>L g) o\<^sub>L (inv\<^sub>L f)"
  using assms inv\<^sub>L_eq is_inverse\<^sub>L_compose
  by blast

lemma inv\<^sub>L_id_blinfun[simp]: "inv\<^sub>L id_blinfun = id_blinfun"
  by (metis blinfun_compose_id(2) inv\<^sub>L_I)

subsection \<open>Norm\<close>
lemma bounded_range_subset:
  "bounded (range f :: real set) \<Longrightarrow> bounded (f ` X')"
  by (auto simp: bounded_iff)

lemma bounded_const: "bounded ((\<lambda>_. x) ` X)"
  by (meson finite_imp_bounded finite.emptyI finite_insert finite_subset image_subset_iff insert_iff)

lift_definition bfun_pos :: "('d \<Rightarrow>\<^sub>b real) \<Rightarrow> ('d \<Rightarrow>\<^sub>b real)" is "\<lambda>f i. if f i < 0 then -f i else f i"
  using bounded_const bounded_range_subset by (auto simp: bfun_def)

lemma bfun_pos_zero[simp]: "bfun_pos f = 0 \<longleftrightarrow> f = 0"
  by (auto intro!: bfun_eqI simp: bfun_pos.rep_eq split: if_splits)

lift_definition bfun_nonneg :: "('d \<Rightarrow>\<^sub>b real) \<Rightarrow> ('d \<Rightarrow>\<^sub>b real)" is "\<lambda>f i. if f i \<le> 0 then 0 else f i"
  using bounded_const bounded_range_subset by (auto simp: bfun_def)

lemma bfun_nonneg_split: "bfun_nonneg x - bfun_nonneg (- x) = x"
  by (auto simp: bfun_nonneg.rep_eq)

lemma blinfun_split: "blinfun_apply f x = f (bfun_nonneg x) - f (bfun_nonneg (- x))"
  using bfun_nonneg_split
  by (metis blinfun.diff_right)

lemma bfun_nonneg_pos: "bfun_nonneg x + bfun_nonneg (-x) = bfun_pos x"
  by (auto simp: bfun_nonneg.rep_eq bfun_pos.rep_eq)

lemma bfun_nonneg: "0 \<le> bfun_nonneg f"
  by (auto simp: bfun_nonneg.rep_eq)

lemma bfun_pos_eq_nonneg: "bfun_pos n = bfun_nonneg n + bfun_nonneg (-n)"
  by (auto simp: bfun_pos.rep_eq bfun_nonneg.rep_eq)

lemma blinfun_mono_norm_pos:
  fixes f :: "('c \<Rightarrow>\<^sub>b real) \<Rightarrow>\<^sub>L ('d \<Rightarrow>\<^sub>b real)"
  assumes "\<And>v :: 'c \<Rightarrow>\<^sub>b real. v \<ge> 0 \<Longrightarrow> f v \<ge> 0"
  shows "norm (f n) \<le> norm (f (bfun_pos n))"
proof -
  have *: "\<bar>f n i\<bar> \<le> \<bar>f (bfun_pos n) i\<bar>" for i
    by (auto simp: blinfun_split[of f n] bfun_nonneg_pos[symmetric] blinfun.add_right abs_real_def)
      (metis add_nonneg_nonneg assms bfun_nonneg leD less_eq_bfun_def zero_bfun.rep_eq)+
  thus "norm (f n) \<le> norm ((f (bfun_pos n)))"
    unfolding norm_bfun_def' using *
    by (auto intro!: cSUP_mono bounded_imp_bdd_above abs_le_norm_bfun boundedI[of _ "norm ((f (bfun_pos n)))"])
qed

lemma norm_bfun_pos[simp]: "norm (bfun_pos f) = norm f"
proof -
  have "norm (bfun_pos f) = (\<Squnion>i. \<bar>bfun_pos f i\<bar>)"
    by (auto simp add: norm_bfun_def')
  also have "\<dots> = (\<Squnion>i. \<bar>f i\<bar>)"
    by (rule SUP_cong[OF refl]) (auto simp: bfun_pos.rep_eq)
  finally show ?thesis by (auto simp add: norm_bfun_def')
qed

lemma norm_blinfun_mono_eq_nonneg:
  fixes f :: "('c \<Rightarrow>\<^sub>b real) \<Rightarrow>\<^sub>L ('d \<Rightarrow>\<^sub>b real)"
  assumes "\<And>v :: 'c \<Rightarrow>\<^sub>b real. v \<ge> 0 \<Longrightarrow> f v \<ge> 0"
  shows "norm f = (\<Squnion>v \<in> {v. v \<ge> 0}. norm (f v) / norm v)"
  unfolding norm_blinfun.rep_eq onorm_def
proof (rule antisym, rule cSUP_mono)
  have *: "norm (blinfun_apply f v) / norm v \<le> norm f" for v
    using norm_blinfun[of f]
    by (cases "v = 0") (auto simp: pos_divide_le_eq)
  thus "bdd_above ((\<lambda>v. norm (f v) / norm v) ` {v. 0 \<le> v})"
    by (auto intro!: bounded_imp_bdd_above boundedI)
  show "\<exists>m\<in>{v. 0 \<le> v}. norm (f n) / norm n \<le> norm (f m) / norm m" for n
    using blinfun_mono_norm_pos[OF assms]
    by (cases "norm (bfun_pos n) = 0")
      (auto intro!: frac_le exI[of _ "bfun_pos n"] simp: less_eq_bfun_def bfun_pos.rep_eq)
  show "(\<Squnion>v\<in>{v. 0 \<le> v}. norm (f v) / norm v) \<le> (\<Squnion>x. norm (f x) / norm x)"
    using *
    by (auto intro!: cSUP_mono bounded_imp_bdd_above boundedI)
qed auto

lemma norm_blinfun_normalized_le: "norm (blinfun_apply f v) / norm v \<le> norm f"
  by (simp add: blinfun.bounded_linear_right le_onorm norm_blinfun.rep_eq)

lemma norm_blinfun_mono_eq_nonneg':
  fixes f :: "('c \<Rightarrow>\<^sub>b real) \<Rightarrow>\<^sub>L ('d \<Rightarrow>\<^sub>b real)"
  assumes "\<And>v :: 'c \<Rightarrow>\<^sub>b real. 0 \<le> v \<Longrightarrow> 0 \<le> f v"
  shows "norm f = (\<Squnion>x \<in> {x. norm x = 1 \<and> x \<ge> 0}. norm (f x))"
proof (subst norm_blinfun_mono_eq_nonneg[OF assms])
  show "(\<Squnion>v\<in>{v. 0 \<le> v}. norm (f v) / norm v) =
    (\<Squnion>x\<in>{x. norm x = 1 \<and> 0 \<le> x}. norm (f x))"
  proof (rule antisym, rule cSUP_mono)
    show "{v::'c \<Rightarrow>\<^sub>b real. 0 \<le> v} \<noteq> {}" by auto
    show "bdd_above ((\<lambda>x. norm (f x)) ` {x. norm x = 1 \<and> 0 \<le> x})"
      by (fastforce intro: order.trans[OF norm_blinfun[of f]] bounded_imp_bdd_above boundedI)
    show "\<exists>m\<in>{x. norm x = 1 \<and> 0 \<le> x}. norm (f n) / norm n \<le> norm (f m)" if "n \<in> {v. 0 \<le> v}" for n
    proof (cases "norm (bfun_pos n) = 0")
      case True
      then show ?thesis by (auto intro!: exI[of _ 1])
    next
      case False
      then show ?thesis
        using that
        by (auto simp: scaleR_nonneg_nonneg blinfun.scaleR_right intro!: exI[of _ "(1/norm n) *\<^sub>R n"])
    qed
    show "(\<Squnion>x\<in>{x. norm x = 1 \<and> 0 \<le> x}. norm (f x)) \<le> (\<Squnion>v\<in>{v. 0 \<le> v}. norm (f v) / norm v)"
    proof (rule cSUP_mono)
      show "{x::'c \<Rightarrow>\<^sub>b real. norm x = 1 \<and> 0 \<le> x} \<noteq> {}"
        by (auto intro!: exI[of _ 1])
    qed (fastforce intro!: norm_blinfun_normalized_le bounded_imp_bdd_above boundedI)+
  qed
qed auto

lemma norm_blinfun_mono_le_norm_one:
  fixes f :: "('c \<Rightarrow>\<^sub>b real) \<Rightarrow>\<^sub>L ('d \<Rightarrow>\<^sub>b real)"
  assumes "\<And>v :: 'c \<Rightarrow>\<^sub>b real. v \<ge> 0 \<Longrightarrow> f v \<ge> 0"
  assumes "norm x = 1" "0 \<le> x"
  shows "norm (f x) \<le> norm (f 1)"
proof -
  have **: "0 \<le> 1 - x"
    using assms
    by (auto simp: less_eq_bfun_def intro: order.trans[OF le_norm_bfun])
  show ?thesis
    unfolding norm_bfun_def'
  proof (intro cSUP_mono)
    show"bdd_above (range (\<lambda>x. norm (apply_bfun (blinfun_apply f 1) x)))"
      using order.trans abs_le_norm_bfun norm_blinfun
      by (fastforce intro!: bounded_imp_bdd_above boundedI)
    show "\<exists>m\<in>UNIV. norm (f x n) \<le> norm (f 1 m)" for n
      using assms(1) assms(3) assms(1)[of "1 - x"] **
      unfolding less_eq_bfun_def zero_bfun.rep_eq abs_real_def
      by (auto simp: blinfun.diff_right linorder_class.not_le[symmetric])
  qed auto
qed

lemma norm_blinfun_mono_eq_one:
  fixes f :: "('c \<Rightarrow>\<^sub>b real) \<Rightarrow>\<^sub>L ('d \<Rightarrow>\<^sub>b real)"
  assumes "\<And>v :: 'c \<Rightarrow>\<^sub>b real. v \<ge> 0 \<Longrightarrow> f v \<ge> 0"
  shows "norm f = norm (f 1)"
proof -
  have "(\<Squnion>x\<in>{x. norm x = 1 \<and> 0 \<le> x}. norm (f x)) = norm (f 1)"
  proof (rule antisym, rule cSUP_least)
    show "{x::'c \<Rightarrow>\<^sub>b real. norm x = 1 \<and> 0 \<le> x} \<noteq> {}"
      by (auto intro!: exI[of _ 1])
  next
    show "\<And>x. x \<in> {x. norm x = 1 \<and> 0 \<le> x} \<Longrightarrow> norm (f x) \<le> norm (f 1)"
      by (simp add: assms norm_blinfun_mono_le_norm_one)
  next
    show "norm (f 1) \<le> (\<Squnion>x\<in>{x. norm x = 1 \<and> 0 \<le> x}. norm (f x))"
      by (rule cSUP_upper) (fastforce intro!: bdd_aboveI2 order.trans[OF norm_blinfun])+
  qed
  thus ?thesis
    using norm_blinfun_mono_eq_nonneg'[OF assms]
    by auto
qed

subsection \<open>Miscellaneous\<close>

lemma bounded_linear_apply_bfun: "bounded_linear (\<lambda>x. apply_bfun x i)"
  using norm_le_norm_bfun
  by (fastforce intro: bounded_linear_intro[of _ 1])

lemma lim_blinfun_apply: "convergent X \<Longrightarrow> (\<lambda>n. blinfun_apply (X n) u) \<longlonglongrightarrow> lim X u"
  using blinfun.bounded_bilinear_axioms
  by (auto simp: convergent_LIMSEQ_iff intro: Limits.bounded_bilinear.tendsto)

lemma bounded_apply_blinfun:
  assumes "bounded ((F :: 'c \<Rightarrow> 'd::real_normed_vector \<Rightarrow>\<^sub>L 'b::real_normed_vector) ` S)"
  shows "bounded ((\<lambda>b. blinfun_apply (F b) x) ` S)"
proof -
  obtain b where "\<forall>x\<in>S. norm (F x) \<le> b"
    by (meson \<open>bounded (F ` S)\<close> bounded_pos image_eqI)
  thus "bounded ((\<lambda>b. (F b) x) ` S)"
    by (auto simp: mult_right_mono mult.commute[of _ b]
        intro!: boundedI[of _ "norm x * b"] dual_order.trans[OF _ norm_blinfun])
qed

lemma tendsto_blinfun_apply: "(\<lambda>n. X n) \<longlonglongrightarrow> L  \<Longrightarrow> (\<lambda>n. blinfun_apply (X n) u) \<longlonglongrightarrow> L u"
  using blinfun.bounded_bilinear_axioms
  by (auto simp: convergent_LIMSEQ_iff intro: Limits.bounded_bilinear.tendsto)

definition "nonneg_blinfun (Q :: _::{ordered_real_normed_vector} \<Rightarrow>\<^sub>L _::{ordered_ab_group_add, ordered_real_normed_vector}) \<equiv> (\<forall>v\<ge>0. blinfun_apply Q v \<ge> 0)"

definition "blinfun_le Q R = nonneg_blinfun (R - Q)"

lemma nonneg_blinfun_nonneg[dest]: "nonneg_blinfun Q \<Longrightarrow> 0 \<le> v \<Longrightarrow> 0 \<le> Q v"
  unfolding nonneg_blinfun_def
  by auto

lemma nonneg_blinfun_mono[dest]: "nonneg_blinfun Q \<Longrightarrow> u \<le> v \<Longrightarrow> Q u \<le> Q v"
  using nonneg_blinfun_nonneg[of Q "v - u", unfolded blinfun.diff_right]
  by auto

lemma nonneg_id_blinfun: "nonneg_blinfun id_blinfun"
  by (auto simp: nonneg_blinfun_def)

lemma blinfun_nonneg_eq:
  assumes "\<forall>v \<ge> 0. blinfun_apply (f::('c \<Rightarrow>\<^sub>b real) \<Rightarrow>\<^sub>L ('c \<Rightarrow>\<^sub>b real)) v = blinfun_apply g v"
  shows "f = g"
proof (rule blinfun_eqI)
  fix v :: "'c \<Rightarrow>\<^sub>b real"
  define v1 where "v1 = Bfun (\<lambda>x. max (v x) 0)"
  define v2 where "v2 = Bfun (\<lambda>x. - min (v x) 0)"
  have in_bfun[simp]: "(\<lambda>x. max (v x) 0) \<in> bfun" "(\<lambda>x. - min (v x) 0) \<in> bfun"
    by (auto simp: le_norm_bfun minus_min_eq_max abs_le_norm_bfun abs_le_D2 intro!: boundedI[of _ "norm v"])
  have eq_v: "v = v1 - v2"
    unfolding v1_def v2_def
    by (auto simp: Bfun_inverse)
  have nonneg: "0 \<le> v1" "0 \<le> v2"
    unfolding less_eq_bfun_def
    by (auto simp: v1_def v2_def Bfun_inverse)
  show " blinfun_apply f v = blinfun_apply g v"
    unfolding eq_v
    using nonneg assms
    by (auto simp: blinfun.diff_right)
qed

lemma bfun_zero_le_one: "0 \<le> (1 :: 'c \<Rightarrow>\<^sub>b real)"
  by (simp add: less_eq_bfunI)

lemma norm_nonneg_blinfun_one:
  assumes "nonneg_blinfun (X :: ('c \<Rightarrow>\<^sub>b real) \<Rightarrow>\<^sub>L ('c \<Rightarrow>\<^sub>b real))"
  shows "norm X = norm (blinfun_apply X 1)"
  using assms unfolding nonneg_blinfun_def
  by (auto simp: norm_blinfun_mono_eq_one)

lemma blinfun_apply_mono: "nonneg_blinfun X \<Longrightarrow> 0 \<le> v \<Longrightarrow> blinfun_le X Y \<Longrightarrow> X v \<le> Y v"
  by (simp add: blinfun.diff_left blinfun_le_def nonneg_blinfun_def)

lemma nonneg_blinfun_scaleR[intro]:  "nonneg_blinfun B \<Longrightarrow> 0 \<le> c \<Longrightarrow> nonneg_blinfun (c *\<^sub>R B)"
  by (simp add: nonneg_blinfun_def scaleR_blinfun.rep_eq scaleR_nonneg_nonneg)

lemma nonneg_blinfun_compose[intro]: "nonneg_blinfun B \<Longrightarrow> nonneg_blinfun C \<Longrightarrow> nonneg_blinfun (C o\<^sub>L B)"
  by (simp add: nonneg_blinfun_def)

lemma matrix_le_norm_mono:
  assumes "nonneg_blinfun (C :: ('c \<Rightarrow>\<^sub>b real) \<Rightarrow>\<^sub>L ('c \<Rightarrow>\<^sub>b real))"
    and "nonneg_blinfun (D - C)"
  shows "norm C \<le> norm D"
proof -
  have "nonneg_blinfun D"
    using assms
    by (metis add_nonneg_nonneg diff_add_cancel nonneg_blinfun_def plus_blinfun.rep_eq)
  have zero_le: "0 \<le> C 1" "0 \<le> D 1"
    using assms zero_le_one  \<open>nonneg_blinfun D\<close>
    by (auto simp add: less_eq_bfunI nonneg_blinfun_nonneg)
  hence "C 1 \<le> D 1"
    using assms(2) unfolding nonneg_blinfun_def blinfun.diff_left
    by (simp add: less_eq_bfun_def)
  thus ?thesis
    using assms \<open>nonneg_blinfun D\<close> zero_le le_norm_bfun
    by (fastforce simp: norm_nonneg_blinfun_one norm_bfun_def' less_eq_bfun_def intro!: bdd_above.I2 cSUP_mono)
qed

lemma bounded_subset: "Y \<subseteq> X \<Longrightarrow> bounded (f ` X) \<Longrightarrow> bounded (f ` Y)"
  by (auto simp: bounded_def)

lemma bounded_subset_range: "bounded (range f) \<Longrightarrow> bounded (f ` Y)"
  using bounded_subset subset_UNIV by metis

lift_definition bfun_if :: "('b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow>\<^sub>b 'c::metric_space) \<Rightarrow> ('b \<Rightarrow>\<^sub>b 'c) \<Rightarrow> ('b \<Rightarrow>\<^sub>b 'c)" is "\<lambda>b u v s. if b s then u s else v s"
  using bounded_subset_range
  by (auto simp: bfun_def)

lemma bfun_if_add: "bfun_if b (w + z) (u + v) = bfun_if b w u + bfun_if b z v"
  by (auto simp: bfun_if.rep_eq)

lemma bfun_if_zero_add: "bfun_if b 0 (u + v) = bfun_if b 0 u + bfun_if b 0 v"
  by (auto simp: bfun_if.rep_eq)

lemma bfun_if_zero_le: "0 \<le> v \<Longrightarrow> bfun_if b 0 v \<le> v"
  by (metis (no_types, lifting) bfun_if.rep_eq le_less less_eq_bfun_def)

lemma bfun_if_eq: "(\<And>i. P i \<Longrightarrow> apply_bfun v i = apply_bfun u i) \<Longrightarrow> (\<And>i. \<not>P i \<Longrightarrow> v i = apply_bfun w i) \<Longrightarrow> bfun_if P u w = v"
  by (auto simp: bfun_if.rep_eq)

lemma bfun_if_scaleR: "c *\<^sub>R bfun_if b v1 v2 = bfun_if b (c *\<^sub>R v1) (c *\<^sub>R v2)"
  by (auto simp: bfun_if.rep_eq)

lemma summable_blinfun_apply:
  assumes "summable (f :: nat \<Rightarrow> 'a::real_normed_vector \<Rightarrow>\<^sub>L 'a)"
  shows "summable (\<lambda>n. f n v)"
  using assms tendsto_blinfun_apply
  unfolding summable_def sums_def blinfun.sum_left[symmetric]
  by auto

lemma blinfun_apply_suminf:
  assumes "summable (f :: nat \<Rightarrow> 'a::real_normed_vector \<Rightarrow>\<^sub>L 'a)"
  shows "(\<Sum>k. blinfun_apply (f k) v) = (\<Sum>k. f k) v"
  using bounded_linear.suminf[OF blinfun.bounded_linear_left assms]
  by auto
end


theory Word_Next
imports Main
  "~~/src/HOL/Word/Word"
  "../Word_Lib/Word_Lemmas"
begin

section\<open>Increment and Decrement Machine Words Without Wrap-Around\<close>

text\<open>Previous and next words addresses, without wrap around.\<close>
definition word_next :: "'a::len word \<Rightarrow> 'a::len word" where
  "word_next a \<equiv> if a = max_word then max_word else a + 1"
definition word_prev :: "'a::len word \<Rightarrow> 'a::len word" where
  "word_prev a \<equiv> if a = 0 then 0 else a - 1"

text\<open>Examples:\<close>

lemma word_Suc_leq: fixes k::"'a::len word" shows "k \<noteq> max_word \<Longrightarrow> x < k + 1 \<longleftrightarrow> x \<le> k"
  using Word_Lemmas.less_x_plus_1 word_le_less_eq by auto

lemma word_Suc_le: fixes k::"'a::len word" shows "x \<noteq> max_word \<Longrightarrow> x + 1 \<le> k \<longleftrightarrow> x < k"
  by (meson not_less word_Suc_leq)

lemma word_lessThan_Suc_atMost: fixes k::"'a::len word" shows "k \<noteq> max_word \<Longrightarrow> {..< k + 1} = {..k}"
  by(simp add: lessThan_def atMost_def word_Suc_leq)

lemma word_atLeastLessThan_Suc_atLeastAtMost:
  fixes l::"'a::len word" shows "u \<noteq> max_word \<Longrightarrow> {l..< u + 1} = {l..u}"
  by (simp add: atLeastAtMost_def atLeastLessThan_def word_lessThan_Suc_atMost)

lemma word_atLeastAtMost_Suc_greaterThanAtMost: fixes l::"'a::len word"
  shows "m \<noteq> max_word \<Longrightarrow> {m<..u} = {m + 1..u}"
  by(simp add: greaterThanAtMost_def greaterThan_def atLeastAtMost_def atLeast_def word_Suc_le)

lemma word_atLeastLessThan_Suc_atLeastAtMost_union:
  fixes l::"'a::len word"
  assumes "m \<noteq> max_word" and "l \<le> m" and "m \<le> u"
  shows "{l..m} \<union> {m+1..u} = {l..u}"
  proof -
  from ivl_disj_un_two(8)[OF assms(2) assms(3)] have "{l..u} = {l..m} \<union> {m<..u}" by blast
  with assms show ?thesis by(simp add: word_atLeastAtMost_Suc_greaterThanAtMost)
  qed

lemma word_adjacent_union:
  "word_next e = s' \<Longrightarrow> s \<le> e \<Longrightarrow> s' \<le> e' \<Longrightarrow> {s..e} \<union> {s'..e'} = {s .. e'}"
  by (metis Un_absorb2 atLeastatMost_subset_iff ivl_disj_un_two(7) max_word_max
            word_atLeastLessThan_Suc_atLeastAtMost word_le_less_eq word_next_def word_not_le)

end


section \<open>Alternating Function Iteration\<close>

theory Alternate
imports Main
begin

  primrec alternate :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> ('a \<Rightarrow> 'a)" where
    "alternate f g 0 = id" | "alternate f g (Suc k) = alternate g f k \<circ> f"

  lemma alternate_Suc[simp]: "alternate f g (Suc k) = (if even k then f else g) \<circ> alternate f g k"
  proof (induct k arbitrary: f g)
    case (0)
    show ?case by simp
  next
    case (Suc k)
    have "alternate f g (Suc (Suc k)) = alternate g f (Suc k) \<circ> f" by auto
    also have "\<dots> = (if even k then g else f) \<circ> (alternate g f k \<circ> f)" unfolding Suc by auto
    also have "\<dots> = (if even (Suc k) then f else g) \<circ> alternate f g (Suc k)" by auto
    finally show ?case by this
  qed

  declare alternate.simps(2)[simp del]

  lemma alternate_antimono:
    assumes "\<And> x. f x \<le> x" "\<And> x. g x \<le> x"
    shows "antimono (alternate f g)"
  proof
    fix k l :: nat
    assume 1: "k \<le> l"
    obtain n where 2: "l = k + n" using le_Suc_ex 1 by auto
    have 3: "alternate f g (k + n) \<le> alternate f g k"
    proof (induct n)
      case (0)
      show ?case by simp
    next
      case (Suc n)
      have "alternate f g (k + Suc n) \<le> alternate f g (k + n)" using assms by (auto intro: le_funI)
      also have "\<dots> \<le> alternate f g k" using Suc by this
      finally show ?case by this
    qed
    show "alternate f g l \<le> alternate f g k" using 3 unfolding 2 by this
  qed

end


theory P12 imports Main begin

lemma I: "A \<longrightarrow> A"
  apply (rule impI)
  apply assumption
  done

lemma "A \<and> B \<longrightarrow> B \<and> A"
  apply (rule impI)
  apply (rule conjI)
   apply (erule conjE)
   apply assumption
  apply (erule conjE)
  apply assumption
  done

lemma "(A \<and> B) \<longrightarrow> (A \<or> B)"
  apply (rule impI)
  apply (rule disjI1)
  apply (erule conjE)
  apply assumption
  done

lemma "((A \<or> B) \<or> C) \<longrightarrow> A \<or> (B \<or> C)"
  apply (rule impI)
  apply (erule disjE)
   apply (erule disjE)
    apply (rule disjI1)
    apply assumption
   apply (rule disjI2)
   apply (rule disjI1)
   apply assumption
  apply (rule disjI2)
  apply (rule disjI2)
  apply assumption
  done

lemma "(A \<or> A) = (A \<and> A)"
  apply (rule iffI)
   apply (erule disjE)
  apply (rule conjI)
   apply assumption+
  apply (rule conjI)
    apply assumption+
  apply (rule disjI1)
  apply (erule conjE)
  apply assumption
  done

lemma S: "(A \<longrightarrow> B \<longrightarrow> C) \<longrightarrow> (A \<longrightarrow> B) \<longrightarrow> A \<longrightarrow> C"
  apply (rule impI)+
  apply (erule impE)+
    apply assumption+
  apply (erule mp)
  apply (erule impE)
   apply assumption+
  done

lemma "(A \<longrightarrow> B) \<longrightarrow> (B \<longrightarrow> C) \<longrightarrow> A \<longrightarrow> C"
  apply (rule impI)+
  apply (erule mp)
  apply (erule impE)
   apply assumption+
  done

lemma "\<not>\<not> A \<longrightarrow> A"
  apply (rule impI)
  apply (rule classical)
  apply (erule notE)
  apply assumption
  done

lemma "A \<longrightarrow> \<not> \<not> A"
  apply (rule impI)
  apply (rule notI)
  apply (rule classical)
  apply (erule notE)
  apply assumption
  done

lemma "(\<not> A \<longrightarrow> B) \<longrightarrow> (\<not> B\<longrightarrow> A)"
  apply (rule impI)+
  apply (rule classical)
  apply (erule notE)
  apply (erule impE)
   apply assumption+
  done

lemma "((A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A"
  apply (rule impI)+
  apply (rule classical)
  apply (erule impE)
   apply (rule impI)
   apply (erule notE)
   apply assumption+
  done

lemma "A \<or> \<not> A"
  apply (rule classical)
  apply (rule disjI1)
  apply (rule classical)
  apply (erule notE)
  apply (rule disjI2)
  apply assumption
  done

lemma "(\<not> (A \<and> B)) = (\<not> A \<or> \<not> B)"
  apply (rule iffI)

  apply (rule classical)
  apply (erule notE)
  apply (rule conjI)
  apply (rule classical)
  apply (erule notE)
  apply (rule disjI1)
  apply assumption
  apply (rule classical)
  apply (erule notE)
  apply (rule disjI2)
   apply assumption

  apply (rule notI)
  apply (erule conjE)
  apply (erule disjE)
   apply (erule notE)
   apply assumption
  apply (erule notE)
  apply assumption
  done

end


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


theory hw13tmpl
imports Main
begin

fun push :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"push x xs = x # xs"

fun pop :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"pop n xs = drop n xs"

text \<open>You may assume\<close>

definition t_push :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"t_push x xs = 1"

definition t_pop :: "nat \<Rightarrow> 'a list \<Rightarrow> nat" where
"t_pop n xs = min n (length xs)"

definition \<Phi> :: "'a list \<Rightarrow> int" where
"\<Phi> bs = int(length bs)"

lemma \<Phi>_non_neg: "\<Phi> bs \<ge> 0"
by(simp add: \<Phi>_def)

definition "init = []"

lemma \<Phi>_init: "\<Phi> init = 0"
by(simp add: \<Phi>_def init_def)

lemma push_const: "int(t_push x xs)  + \<Phi>(push x xs) - \<Phi> xs = 2"
apply(induction xs rule: push.induct)
  apply (auto simp add: \<Phi>_def t_push_def)
  done

lemma pop_const: "int(t_pop n xs) + \<Phi>(pop n xs) - \<Phi> xs = 0"
  apply(induction xs rule: pop.induct)
  apply (auto simp add: \<Phi>_def t_pop_def)
  done

end


(*
  Copyright (c) 2014-2019 by Clemens Ballarin
  This file is licensed under the 3-clause BSD license.
*)

theory Set_Theory imports "HOL-Library.FuncSet" begin

hide_const map
hide_const partition

no_notation divide (infixl "'/" 70)
no_notation inverse_divide (infixl "'/" 70)

text \<open>
  Each statement in the formal text is annotated with the location of the originating statement
  in Jacobson's text @{cite Jacobson1985}.  Each fact that Jacobson states explicitly is marked
  as @{command theorem} unless it is translated to a @{command sublocale} declaration.
  Literal quotations from Jacobson's text are reproduced in double quotes.

  Auxiliary results needed for the formalisation that cannot be found in Jacobson's text are marked
  as @{command lemma} or are @{command interpretation}s.  Such results are annotated with the
  location of a related statement.  For example, the introduction rule of a constant is annotated
  with the location of the definition of the corresponding operation.
\<close>

section \<open>Concepts from Set Theory.  The Integers\<close>

subsection \<open>The Cartesian Product Set.  Maps\<close>

text \<open>Maps as extensional HOL functions\<close>
text \<open>p 5, ll 21--25\<close>
locale map =
  fixes \<alpha> and S and T
  assumes graph [intro, simp]: "\<alpha> \<in> S \<rightarrow>\<^sub>E T"
begin

text \<open>p 5, ll 21--25\<close>
lemma map_closed [intro, simp]:
  "a \<in> S \<Longrightarrow> \<alpha> a \<in> T"
using graph by fast

text \<open>p 5, ll 21--25\<close>
lemma map_undefined [intro, simp]:
  "a \<notin> S \<Longrightarrow> \<alpha> a = undefined"
using graph by fast

end (* map *)

text \<open>p 7, ll 7--8\<close>
locale surjective_map = map + assumes surjective [intro]: "\<alpha> ` S = T"

text \<open>p 7, ll 8--9\<close>
locale injective_map = map + assumes injective [intro, simp]: "inj_on \<alpha> S"

text \<open>Enables locale reasoning about the inverse @{term "restrict (inv_into S \<alpha>) T"} of @{term \<alpha>}.\<close>
text \<open>p 7, ll 9--10\<close>
locale bijective =
  fixes \<alpha> and S and T
  assumes bijective [intro, simp]: "bij_betw \<alpha> S T"

text \<open>
  Exploit existing knowledge about @{term bij_betw} rather than extending @{locale surjective_map}
  and @{locale injective_map}.
\<close>
text \<open>p 7, ll 9--10\<close>
locale bijective_map = map + bijective begin

text \<open>p 7, ll 9--10\<close>
sublocale surjective_map by unfold_locales (simp add: bij_betw_imp_surj_on)

text \<open>p 7, ll 9--10\<close>
sublocale injective_map using bij_betw_def by unfold_locales fast

text \<open>p 9, ll 12--13\<close>
sublocale inverse: map "restrict (inv_into S \<alpha>) T" T S
  by unfold_locales (simp add: inv_into_into surjective)

text \<open>p 9, ll 12--13\<close>
sublocale inverse: bijective "restrict (inv_into S \<alpha>) T" T S
  by unfold_locales (simp add: bij_betw_inv_into surjective)

end (* bijective_map *)

text \<open>p 8, ll 14--15\<close>
abbreviation "identity S \<equiv> (\<lambda>x \<in> S. x)"

context map begin

text \<open>p 8, ll 18--20; p 9, ll 1--8\<close>
theorem bij_betw_iff_has_inverse:
  "bij_betw \<alpha> S T \<longleftrightarrow> (\<exists>\<beta> \<in> T \<rightarrow>\<^sub>E S. compose S \<beta> \<alpha> = identity S \<and> compose T \<alpha> \<beta> = identity T)"
    (is "_ \<longleftrightarrow> (\<exists>\<beta> \<in> T \<rightarrow>\<^sub>E S. ?INV \<beta>)")
proof
  let ?inv = "restrict (inv_into S \<alpha>) T"
  assume "bij_betw \<alpha> S T"
  then have "?INV ?inv" and "?inv \<in> T \<rightarrow>\<^sub>E S"
    by (simp_all add: compose_inv_into_id bij_betw_imp_surj_on compose_id_inv_into bij_betw_imp_funcset bij_betw_inv_into)
  then show "\<exists>\<beta> \<in> T \<rightarrow>\<^sub>E S. ?INV \<beta>" ..
next
  assume "\<exists>\<beta> \<in> T \<rightarrow>\<^sub>E S. ?INV \<beta>"
  then obtain \<beta> where "\<alpha> \<in> S \<rightarrow> T" "\<beta> \<in> T \<rightarrow> S" "\<And>x. x \<in> S \<Longrightarrow> \<beta> (\<alpha> x) = x" "\<And>y. y \<in> T \<Longrightarrow> \<alpha> (\<beta> y) = y"
    by (metis PiE_restrict compose_eq graph restrict_PiE restrict_apply)
  then show "bij_betw \<alpha> S T" by (rule bij_betwI)
qed

end (* map *)

subsection \<open>Equivalence Relations.  Factoring a Map Through an Equivalence Relation\<close>

text \<open>p 11, ll 6--11\<close>
locale equivalence =
  fixes S and E
  assumes closed [intro, simp]: "E \<subseteq> S \<times> S"
    and reflexive [intro, simp]: "a \<in> S \<Longrightarrow> (a, a) \<in> E"
    and symmetric [sym]: "(a, b) \<in> E \<Longrightarrow> (b, a) \<in> E"
    and transitive [trans]: "\<lbrakk> (a, b) \<in> E; (b, c) \<in> E \<rbrakk> \<Longrightarrow> (a, c) \<in> E"
begin

text \<open>p 11, ll 6--11\<close>
lemma left_closed [intro]: (* inefficient as a simp rule *)
  "(a, b) \<in> E \<Longrightarrow> a \<in> S"
  using closed by blast

text \<open>p 11, ll 6--11\<close>

end (* equivalence *)

text \<open>p 11, ll 16--20\<close>
locale partition =
  fixes S and P
  assumes subset: "P \<subseteq> Pow S"
    and non_vacuous: "{} \<notin> P"
    and complete: "\<Union>P = S"
    and disjoint: "\<lbrakk> A \<in> P; B \<in> P; A \<noteq> B \<rbrakk> \<Longrightarrow> A \<inter> B = {}"

context equivalence begin

text \<open>p 11, ll 24--26\<close>
definition "Class = (\<lambda>a \<in> S. {b \<in> S. (b, a) \<in> E})"

text \<open>p 11, ll 24--26\<close>
lemma Class_closed [dest]:
  "\<lbrakk> a \<in> Class b; b \<in> S \<rbrakk> \<Longrightarrow> a \<in> S"
  unfolding Class_def by auto

text \<open>p 11, ll 24--26\<close>
lemma Class_closed2 [intro, simp]:
  "a \<in> S \<Longrightarrow> Class a \<subseteq> S"
  unfolding Class_def by auto

text \<open>p 11, ll 24--26\<close>
lemma Class_undefined [intro, simp]:
  "a \<notin> S \<Longrightarrow> Class a = undefined"
  unfolding Class_def by simp

text \<open>p 11, ll 24--26\<close>
lemma ClassI [intro, simp]:
  "(a, b) \<in> E \<Longrightarrow> a \<in> Class b"
  unfolding Class_def by (simp add: left_closed right_closed)

text \<open>p 11, ll 24--26\<close>
lemma Class_revI [intro, simp]:
  "(a, b) \<in> E \<Longrightarrow> b \<in> Class a"
  by (blast intro: symmetric)

text \<open>p 11, ll 24--26\<close>
lemma ClassD [dest]:
  "\<lbrakk> b \<in> Class a; a \<in> S \<rbrakk> \<Longrightarrow> (b, a) \<in> E"
  unfolding Class_def by simp

text \<open>p 11, ll 30--31\<close>
theorem Class_self [intro, simp]:
  "a \<in> S \<Longrightarrow> a \<in> Class a"
  unfolding Class_def by simp

text \<open>p 11, l 31; p 12, l 1\<close>
theorem Class_Union [simp]:
  "(\<Union>a\<in>S. Class a) = S"
  by blast

text \<open>p 11, ll 2--3\<close>
theorem Class_subset:
  "(a, b) \<in> E \<Longrightarrow> Class a \<subseteq> Class b"
proof
  fix a and b and c
  assume "(a, b) \<in> E" and "c \<in> Class a"
  then have "(c, a) \<in> E" by auto
  also note `(a, b) \<in> E`
  finally have "(c, b) \<in> E" by simp
  then show "c \<in> Class b" by auto
qed

text \<open>p 11, ll 3--4\<close>
theorem Class_eq:
  "(a, b) \<in> E \<Longrightarrow> Class a = Class b"
  by (auto intro!: Class_subset intro: symmetric)

text \<open>p 12, ll 1--5\<close>
theorem Class_equivalence:
  "\<lbrakk> a \<in> S; b \<in> S \<rbrakk> \<Longrightarrow> Class a = Class b \<longleftrightarrow> (a, b) \<in> E"
proof
  fix a and b
  assume "a \<in> S" "b \<in> S" "Class a = Class b"
  then have "a \<in> Class a" by auto
  also note `Class a = Class b`
  finally show "(a, b) \<in> E" by (fast intro: `b \<in> S`)
qed (rule Class_eq)

text \<open>p 12, ll 5--7\<close>
theorem not_disjoint_implies_equal:
  assumes not_disjoint: "Class a \<inter> Class b \<noteq> {}"
  assumes closed: "a \<in> S" "b \<in> S"
  shows "Class a = Class b"
proof -
  from not_disjoint and closed obtain c where witness: "c \<in> Class a \<inter> Class b" by fast
  with closed have "(a, c) \<in> E" by (blast intro: symmetric)
  also from witness and closed have "(c, b) \<in> E" by fast
  finally show ?thesis by (rule Class_eq)
qed

text \<open>p 12, ll 7--8\<close>
definition "Partition = {Class a | a. a \<in> S}"

text \<open>p 12, ll 7--8\<close>
lemma Class_in_Partition [intro, simp]:
  "a \<in> S \<Longrightarrow> Class a \<in> Partition"
  unfolding Partition_def by fast

text \<open>p 12, ll 7--8\<close>
theorem partition:
  "partition S Partition"
proof
  fix A and B
  assume closed: "A \<in> Partition" "B \<in> Partition"
  then obtain a and b where eq: "A = Class a" "B = Class b" and ab: "a \<in> S" "b \<in> S"
  unfolding Partition_def by auto
  assume distinct: "A \<noteq> B"
  then show "A \<inter> B = {}"
  proof (rule contrapos_np)
    assume not_disjoint: "A \<inter> B \<noteq> {}"
    then show "A = B" by (simp add: eq) (metis not_disjoint_implies_equal ab)
  qed
qed (auto simp: Partition_def)

end (* equivalence *)

context partition begin

text \<open>p 12, ll 9--10\<close>
theorem block_exists:
  "a \<in> S \<Longrightarrow> \<exists>A. a \<in> A \<and> A \<in> P"
  using complete by blast

text \<open>p 12, ll 9--10\<close>
theorem block_unique:
  "\<lbrakk> a \<in> A; A \<in> P; a \<in> B; B \<in> P \<rbrakk> \<Longrightarrow> A = B"
  using disjoint by blast

text \<open>p 12, ll 9--10\<close>
lemma block_closed [intro]: (* inefficient as a simp rule *)
  "\<lbrakk> a \<in> A; A \<in> P \<rbrakk> \<Longrightarrow> a \<in> S"
  using complete by blast

text \<open>p 12, ll 9--10\<close>
lemma element_exists:
  "A \<in> P \<Longrightarrow> \<exists>a \<in> S. a \<in> A"
  by (metis non_vacuous block_closed all_not_in_conv)

text \<open>p 12, ll 9--10\<close>
definition "Block = (\<lambda>a \<in> S. THE A. a \<in> A \<and> A \<in> P)"

text \<open>p 12, ll 9--10\<close>
lemma Block_closed [intro, simp]:
  assumes [intro]: "a \<in> S" shows "Block a \<in> P"
proof -
  obtain A where "a \<in> A" "A \<in> P" using block_exists by blast
  then show ?thesis
    apply (auto simp: Block_def)
    apply (rule theI2)
      apply (auto dest: block_unique)
    done
qed

text \<open>p 12, ll 9--10\<close>
lemma Block_undefined [intro, simp]:
  "a \<notin> S \<Longrightarrow> Block a = undefined"
  unfolding Block_def by simp

text \<open>p 12, ll 9--10\<close>
lemma Block_self:
  "\<lbrakk> a \<in> A; A \<in> P \<rbrakk> \<Longrightarrow> Block a = A"
  apply (simp add: Block_def block_closed)
  apply (rule the_equality)
   apply (auto dest: block_unique)
  done

text \<open>p 12, ll 10--11\<close>
definition "Equivalence = {(a, b) . \<exists>A \<in> P. a \<in> A \<and> b \<in> A}"

text \<open>p 12, ll 11--12\<close>
theorem equivalence: "equivalence S Equivalence"
proof
  show "Equivalence \<subseteq> S \<times> S" unfolding Equivalence_def using subset by auto
next
  fix a
  assume "a \<in> S"
  then show "(a, a) \<in> Equivalence" unfolding Equivalence_def using complete by auto
next
  fix a and b
  assume "(a, b) \<in> Equivalence"
  then show "(b, a) \<in> Equivalence" unfolding Equivalence_def by auto
next
  fix a and b and c
  assume "(a, b) \<in> Equivalence" "(b, c) \<in> Equivalence"
  then show "(a, c) \<in> Equivalence" unfolding Equivalence_def using disjoint by auto
qed

text \<open>Temporarily introduce equivalence associated to partition.\<close>
text \<open>p 12, ll 12--14\<close>
interpretation equivalence S Equivalence by (rule equivalence)

text \<open>p 12, ll 12--14\<close>
theorem Class_is_Block:
  assumes "a \<in> S" shows "Class a = Block a"
proof -
  from `a \<in> S` and block_exists obtain A where block: "a \<in> A \<and> A \<in> P" by blast
  show ?thesis
    apply (simp add: Block_def Class_def)
    apply (rule theI2)
      apply (rule block)
     apply (metis block block_unique)
    apply (auto dest: block_unique simp: Equivalence_def)
    done
qed

text \<open>p 12, l 14\<close>
lemma Class_equals_Block:
  "Class = Block"
proof
  fix x show "Class x = Block x"
  by (cases "x \<in> S") (auto simp: Class_is_Block)
qed

text \<open>p 12, l 14\<close>
theorem partition_of_equivalence:
  "Partition = P"
  by (auto simp add: Partition_def Class_equals_Block) (metis Block_self element_exists)

end (* partition *)

context equivalence begin

text \<open>p 12, ll 14--17\<close>
interpretation partition S Partition by (rule partition)

text \<open>p 12, ll 14--17\<close>
theorem equivalence_of_partition:
  "Equivalence = E"
  unfolding Equivalence_def unfolding Partition_def by auto (metis ClassD Class_closed Class_eq)

end (* equivalence *)

text \<open>p 12, l 14\<close>
sublocale partition \<subseteq> equivalence S Equivalence
  rewrites "equivalence.Partition S Equivalence = P" and "equivalence.Class S Equivalence = Block"
    apply (rule equivalence)
   apply (rule partition_of_equivalence)
  apply (rule Class_equals_Block)
  done

text \<open>p 12, ll 14--17\<close>
sublocale equivalence \<subseteq> partition S Partition
  rewrites "partition.Equivalence Partition = E" and "partition.Block S Partition = Class"
    apply (rule partition)
   apply (rule equivalence_of_partition)
  apply (metis equivalence_of_partition partition partition.Class_equals_Block)
  done

text \<open>Unfortunately only effective on input\<close>
text \<open>p 12, ll 18--20\<close>
notation equivalence.Partition (infixl "'/" 75)

context equivalence begin

text \<open>p 12, ll 18--20\<close>
lemma representant_exists [dest]: "A \<in> S / E \<Longrightarrow> \<exists>a\<in>S. a \<in> A \<and> A = Class a"
  by (metis Block_self element_exists)

text \<open>p 12, ll 18--20\<close>
lemma quotient_ClassE: "A \<in> S / E \<Longrightarrow> (\<And>a. a \<in> S \<Longrightarrow> P (Class a)) \<Longrightarrow> P A"
  using representant_exists by blast

end (* equivalence *)

text \<open>p 12, ll 21--23\<close>
sublocale equivalence \<subseteq> natural: surjective_map Class S "S / E"
  by unfold_locales force+

text \<open>Technical device to achieve Jacobson's syntax; context where @{text \<alpha>} is not a parameter.\<close>
text \<open>p 12, ll 25--26\<close>
locale fiber_relation_notation = fixes S :: "'a set" begin

text \<open>p 12, ll 25--26\<close>
definition Fiber_Relation ("E'(_')") where "Fiber_Relation \<alpha> = {(x, y). x \<in> S \<and> y \<in> S \<and> \<alpha> x = \<alpha> y}"

end (* fiber_relation_notation *)

text \<open>
  Context where classes and the induced map are defined through the fiber relation.
  This will be the case for monoid homomorphisms but not group homomorphisms.
\<close>
text \<open>Avoids infinite interpretation chain.\<close>
text \<open>p 12, ll 25--26\<close>
locale fiber_relation = map begin

text \<open>Install syntax\<close>
text \<open>p 12, ll 25--26\<close>
sublocale fiber_relation_notation .

text \<open>p 12, ll 26--27\<close>
sublocale equivalence where E = "E(\<alpha>)"
  unfolding Fiber_Relation_def by unfold_locales auto

text \<open>``define $\bar{\alpha}$ by $\bar{\alpha}(\bar{a}) = \alpha(a)$''\<close>
text \<open>p 13, ll 8--9\<close>
definition "induced = (\<lambda>A \<in> S / E(\<alpha>). THE b. \<exists>a \<in> A. b = \<alpha> a)"

text \<open>p 13, l 10\<close>
theorem Fiber_equality:
  "\<lbrakk> a \<in> S; b \<in> S \<rbrakk> \<Longrightarrow> Class a = Class b \<longleftrightarrow> \<alpha> a = \<alpha> b"
  unfolding Class_equivalence unfolding Fiber_Relation_def by simp

text \<open>p 13, ll 8--9\<close>
theorem induced_Fiber_simp [simp]:
  assumes [intro, simp]: "a \<in> S" shows "induced (Class a) = \<alpha> a"
proof -
  have "(THE b. \<exists>a\<in>Class a. b = \<alpha> a) = \<alpha> a"
    by (rule the_equality) (auto simp: Fiber_equality [symmetric] Block_self block_closed)
  then show ?thesis unfolding induced_def by simp
qed

text \<open>p 13, ll 10--11\<close>
interpretation induced: map induced "S / E(\<alpha>)" T
proof (unfold_locales, rule)
  fix A
  assume [intro, simp]: "A \<in> S / E(\<alpha>)"
  obtain a where a: "a \<in> S" "a \<in> A" using element_exists by auto
  have "(THE b. \<exists>a\<in>A. b = \<alpha> a) \<in> T"
    apply (rule theI2)
    using a apply (auto simp: Fiber_equality [symmetric] Block_self block_closed)
    done
  then show "induced A \<in> T" unfolding induced_def by simp
qed (simp add: induced_def)

text \<open>p 13, ll 12--13\<close>
sublocale induced: injective_map induced "S / E(\<alpha>)" T
  apply unfold_locales
  apply (rule inj_onI)
  apply (metis Fiber_equality Block_self element_exists induced_Fiber_simp)
  done

text \<open>p 13, ll 16--19\<close>
theorem factorization_lemma:
  "a \<in> S \<Longrightarrow> compose S induced Class a = \<alpha> a"
  by (simp add: compose_eq)

text \<open>p 13, ll 16--19\<close>
theorem factorization [simp]: "compose S induced Class = \<alpha>"
  by (rule ext) (simp add: compose_def)

text \<open>p 14, ll 2--4\<close>
theorem uniqueness:
  assumes map: "\<beta> \<in> S / E(\<alpha>) \<rightarrow>\<^sub>E T"
    and factorization: "compose S \<beta> Class = \<alpha>"
  shows "\<beta> = induced"
proof
  fix A
  show "\<beta> A = induced A"
  proof (cases "A \<in> S / E(\<alpha>)")
    case True
    then obtain a where [simp]: "A = Class a" "a \<in> S" by fast
    then have "\<beta> (Class a) = \<alpha> a" by (metis compose_eq factorization)
    also have "\<dots> = induced (Class a)" by simp
    finally show ?thesis by simp
  qed (simp add: induced_def PiE_arb [OF map])
qed

end (* fiber_relation *)

end