theory ConcreteSemantics4
  imports Main
begin

section "4 Logic and Proof Beyond Equality"

subsection "4.1 Formulas"
(* = has a higher precedence than the other logical operators. *)
(* where  <-> has the same low precedence as --> *)

(* 論理的には同じでも、==>の方がIsabelleのFrameworkの中の話だから、証明が楽になるよ *)
(* The implication ==> is part of the Isabelle framework.
It structures theorems and proof states, separating assumptions from conclusions *)
(* The implication --> is part of the logic HOL and can occur inside the formulas that make up the assumptions and conclusion. *)

subsection "4.2 Sets"

(*
UNIV is the set of all elements of some type.
Set comprehension is written {x. P} rather than {x | P}.
*)

(*
\<union> union
\<inter> inter

\<Union> and Union,
\<Inter> and Inter.

UN x:A. B and INT x:A. B where x may occur in B.
If A is UNIV you can write UN x. B and INT x. B.
*)

(*
set :: 'a list => 'a set
    converts a list to the set of its elements

finite :: 'a set => bool
     is true iff its argument is finite

card :: 'a set => nat
    is the cardinality of a finite set and is 0 for all infinite sets

f ‘ A = {y:  \E x \in A. y = f x }
     is the image of a function over a set
*)

subsubsection "Exercises"

(* Exercise 4.1. *)

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

(* Define a function
    set :: 'a tree => 'a set
that returns the elements in a tree *)
fun set :: "'a tree => 'a set" where
"set Tip = {}" |
"set (Node L a R) = {a} \<union> (set L) \<union> (set R)"

(* and a function
    ord :: int tree => bool
that tests if an int tree is ordered *)

(*
左の部分木が小さいと仮定する
左の部分木の最大値は親のより小さく
右の部分木の最小値はと親のより大きい
さらに、
左の部分木は整列しており
右の部分木は整列している
*)

(*
intのような無限なタイプはenumerableではないから、集合を使った実装ではエラーが起きる。
Infinite types, such as int and nat, are not enumerable, and we cannot
check for function equality (for the chosen translation above).

The solution to enable execution of this proposition even with an
infinite type is to choose a different representation for functions (and
sets).
Different on-going discussions and effort by the developers will soon
enable that this is possible, but right now, we are at the unlucky stage
that none of them are fully automatic and could be applied by quickcheck
behind the scenes.

NB: I am still not happy with the error message. It is the honest truth,
why quickcheck cannot execute the proposition, but admittedly users
might struggle understanding its explanation.
ref: https://lists.cam.ac.uk/pipermail/cl-isabelle-users/2011-September/msg00036.html

fun root_is_smaller :: "int * int tree => bool" where
"root_is_smaller(_, Tip) = True" |
"root_is_smaller(a, T) =
    (let setOfElements = {a. \<forall> x \<in> set T. a \<le> x } in
        \<forall> x \<in> setOfElements. a \<le> x)"

fun root_is_greater :: "int * int tree => bool" where
"root_is_greater(_, Tip) = True" |
"root_is_greater(a, T) =     (let setOfElements = {a. \<forall> x \<in> set T. a \<ge> x } in
        \<forall> x \<in> setOfElements. a \<ge> x)"
*)

(*
以下の2つの条件を使えば、
- 右の枝が常に大きい
- 左の枝が常に大きい

比較する最大の値は取れるのでは

以下のようなケースで整列していないことを示す必要がある
value "ord (Node (Node (Node Tip 0 Tip) 1 (Node Tip 2 Tip)) 3 (Node (Node Tip 2 Tip) 5 Tip))"

条件をよく考えればいかでOKだった
    a \<ge> (getRightestLeafFromTree a L) \<and>
    a \<le> (getLeftestLeafFromTree a R))"
*)

fun getRightestLeafFromTree :: "int => int tree => int" where
"getRightestLeafFromTree i Tip = i" |
"getRightestLeafFromTree _ (Node L a R) = getRightestLeafFromTree a R"

fun getLeftestLeafFromTree :: "int => int tree => int" where
"getLeftestLeafFromTree i Tip = i" |
"getLeftestLeafFromTree _ (Node L a R) = getLeftestLeafFromTree a L"

fun ord :: "int tree => bool" where
"ord Tip = True" |
"ord (Node L a R) =
    (ord L \<and>
    ord R \<and>
    a \<ge> (getRightestLeafFromTree a L) \<and>
    a \<le> (getLeftestLeafFromTree a R))"

(* value "ord (Node (Node Tip 2 Tip) 1 (Node Tip 3 Tip))"
value "ord (Node (Node (Node Tip 0 Tip) 2 (Node Tip 1 Tip)) 3 (Node Tip 5 Tip))"
value "ord (Node (Node (Node Tip 3 Tip) 1 (Node Tip 2 Tip)) 3 (Node Tip 5 Tip))"
value "ord (Node (Node (Node Tip 0 Tip) 1 (Node Tip 2 Tip)) 3 (Node (Node Tip 2 Tip) 5 Tip))"
value "ord (Node (Node (Node Tip 0 Tip) 1 (Node Tip 2 Tip)) 3 (Node (Node Tip 4 Tip) 5 Tip))" *)

(* Define a function ins
- that inserts an element into an ordered int tree
- while maintaining the order of the tree
- If the element is already in the tree, the same tree should be returned.
*)

(*
以下のように書くと遅いが
"ins x (Node left y right) = (if x = y then (Node left y right)
        else if x < y then Node (ins x left) y right
        else Node left x (ins y right))"

こう書くと早い
"ins a (Node xt b yt) = (if (a = b) then (Node xt b yt) else
                        (if (a < b) then (Node (ins a xt) b yt) else
                        (Node xt b (ins a yt)) ))"

なんで？
-> 普通に実装を間違えていた "Node left x (ins y right))"d / "Node left y (ins x right))"
*)
fun ins :: "int => int tree => int tree" where
"ins x Tip = Node Tip x Tip" |
"ins x (Node left y right) = (if x = y then (Node left y right)
        else if x < y then Node (ins x left) y right
        else Node left y (ins x right))"

(* value "ins 2 (Node (Node (Node Tip 0 Tip) 1 (Node Tip 2 Tip)) 3 (Node (Node Tip 4 Tip) 5 Tip))"
value "(Node (Node (Node Tip 0 Tip) 1 (Node Tip 2 Tip)) 3 (Node (Node Tip 4 Tip) 5 Tip))
= (ins 2 (Node (Node (Node Tip 0 Tip) 1 (Node Tip 2 Tip)) 3 (Node (Node Tip 4 Tip) 5 Tip)))"
value "ins 2 (Node (Node (Node Tip 0 Tip) 1 (Node Tip 3 Tip)) 4 (Node (Node Tip 5 Tip) 7 Tip))"
value "ins 6 (Node (Node (Node Tip 0 Tip) 1 (Node Tip 3 Tip)) 4 (Node (Node Tip 5 Tip) 7 Tip))" *)

(* Prove correctness of ins:
set (ins x t) = {x} \union set t and ord t => ord (ins i t)
. *)

(*
証明に時間がかかっているので単純化しないといけない
-> insの実装を間違えていたことが原因
*)
lemma "set (ins x t) = {x} \<union> set t"
apply(induction t)
(* sledgehammer *)
apply(auto)
done

(*
apply(induction t)
apply(auto)
by (metis getRightestLeafFromTree.simps(1) getRightestLeafFromTree.simps(2) less_trans linorder_neqE_linordered_idom ord.cases)
*)
lemma insPreservesRightIsGreater : "(getRightestLeafFromTree i1 t) < y
                                    ==> i1 < y
                                    ==> i2 < y
                                    ==> (getRightestLeafFromTree i1 (ins i2 t)) < y"
apply(induction t arbitrary: i1)
apply(auto)
done
(* by (metis getRightestLeafFromTree.simps(1) getRightestLeafFromTree.simps(2) less_trans linorder_neqE_linordered_idom ord.cases) *)

lemma insPreservesLefIsSmaller : "(getLeftestLeafFromTree i1 t) > y
                                    ==> i1 > y
                                    ==> i2 > y
                                    ==> (getLeftestLeafFromTree i1 (ins i2 t)) > y"
apply(induction t arbitrary: i1)
apply(auto)
done

(* (2 subgoals):
 1. \<And>t1 x2 t2.
       ord (ins i t1) \<Longrightarrow>
       ord (ins i t2) \<Longrightarrow>
       ord t1 \<Longrightarrow>
       ord t2 \<Longrightarrow>
       getRightestLeafFromTree x2 t1 \<le> x2 \<Longrightarrow>
       x2 \<le> getLeftestLeafFromTree x2 t2 \<Longrightarrow>
       i < x2 \<Longrightarrow> getRightestLeafFromTree x2 (ins i t1) \<le> x2
 2. \<And>t1 x2 t2.
       ord (ins i t1) \<Longrightarrow>
       ord (ins i t2) \<Longrightarrow>
       ord t1 \<Longrightarrow>
       ord t2 \<Longrightarrow>
       getRightestLeafFromTree x2 t1 \<le> x2 \<Longrightarrow>
       x2 \<le> getLeftestLeafFromTree x2 t2 \<Longrightarrow>
       \<not> i < x2 \<Longrightarrow> i \<noteq> x2 \<Longrightarrow> x2 \<le> getLeftestLeafFromTree x2 (ins i t2) *)
lemma "ord t ==> ord (ins i t)"
apply(induction t)
apply(auto)
(* sledgehammer *)
apply (smt insPreservesRightIsGreater )
(* sledgehammer *)
by (smt insPreservesLefIsSmaller)

subsection "4.3 Proof Automation"

(*
The key characteristics of both `simp` and `auto` are
- They show you where they got stuck, giving you an idea how to continue.
  - simpは証明がどこでスタックするかを見せ、どう続けるかのideaを与えてくれる
- They perform the obvious steps but are highly incomplete.
  - autoは明らかなステップながらもかなり未達成なものをおこなう
*)
(*
Proof Methodがcompleteであるのは、全ての真なるformulasを証明できる場合である。
HOLおよびtheoryにはcompleteなproof methodはない。
IsabelleのProof Methodsはいかに未達成かで異なる。
*)

(*
fastforceについて
- 最初のsubgoalについてのみ実施する。
- slow versionのforceでは成功するが、fastforceでは失敗することがある
*)

lemma "\<lbrakk> \<forall> xs \<in> A. \<exists> ys. xs = ys @ ys; us \<in> A \<rbrakk> \<Longrightarrow> \<exists>n. length us = n + n"
by fastforce

(*
`blast`について
- 複雑な論理的なゴールに対する選択
- is (in principle) a complete proof procedure for first-order formulas, a fragment of HOL. In practice there is a search bound.
  - HOLの断片である、一階の論理式に対しては、completeなproof procedureであり
  - 実践上は探索範囲の束縛がある。
- does no rewriting and knows very little about equality.
  - 書き換えることはなく、等式については少し知っている
- covers logic, sets and relations.
  - 論理、集合、関係についてはカヴァーしている
- either succeeds or fails.
  - 失敗するか成功するかのいずれかである

論理と集合に関する強さと、等式に関する証明の弱さにより、
前のproof methodsを補完する。
*)

lemma "\<lbrakk> \<forall> x y. T x y \<or> T y x; \<forall> x y. A x y \<and> A y x \<longrightarrow> x = y;
        \<forall> x y. T x y \<longrightarrow> A x y \<rbrakk> \<Longrightarrow> \<forall> x y. A x y \<longrightarrow> T x y "
by blast

subsubsection "4.3.1 Sledgehammer"

(* text と異なり、metisがsuggestされなかった。*)
lemma "\<lbrakk> xs @ ys = ys @ xs; length xs = length ys \<rbrakk> \<Longrightarrow> xs = ys"
(* sledgehammer *)
(* using append_eq_append_conv by blast *)
by (metis append_eq_conv_conj )

(*
Isabelleは外部のツールを信用しておらず、チェック可能な証明を要求する。
  append_eq_conv_conjを合わせて、metisがやっていることがこれ

simpやすでで補題を知っている友人を使うのとは異なり、
metisを手動で使うことは長ったらしくて退屈
  代わりにsledgehammerがやってくれる
*)

(*
sledgehammerは存在している証明を発見してくれる、という保証はない
また、sledgehammerが他のproof methodsより優れているわけでもない、比較可能なものではない

だから、sledgehammerを使う前に、simpやautoを使うことを勧める
*)

subsubsection "4.3.2 Arithmetic"

(*
arithmetic formulas: 変数、数、各種演算子(+, -, =, <, <=)、あと一般的な論理結合子を含む式のこと
- これは、線形算術(linear arithmetic)と呼ばれる。
  - 数とのかけ算 `2*n` は許されている

このような式は `arith` で証明される

また、natural numbersのみではなく、integersやreal numbersにも対応している

他にも
- min
- max
*)

lemma "\<lbrakk> (a::nat) \<le> x + b; 2*x < c \<rbrakk> \<Longrightarrow> 2*a + 1 \<le> 2*b + c"
(* apply(auto)
done *)
by arith

(*
autoやsimpも多くの線形算術を証明することはできるが、それはarithの早い(その点で弱い)バージョンによる
だから、必ずしも明示的に呼ぶ必要はない。
*)

subsubsection "4.3.3 Trying Them All"

(*
上記の自動証明手法の全てを使いたいのだったら
`try`
と打ち込めばいい。

軽量バージョンの
`try0`
はsledgehammerを呼ばない。

`try0 simp: ... intro: ...`
とすれば、特定のsimpification や introduction ruleを追加することもできる。
*)

subsection "4.4 Single Step Proofs"

(*
ある自動証明の手法で失敗したら、proof ruleの段階的(stepwise)な適用が必要になる

たとえば、A /\ B　の証明で失敗したら、これを二つに、AとBに分けたい。
これは conjunction introduction (conjI)によってなされる。
*)

subsubsection "4.4.1 Instantiating Unknowns"

(*
定理を証明し終えたら、Isabelleはそこに表れる自由変数xをunknownsと呼ばれる ?xに置き換える
*)

(*
- conjI [of "a=b" "False"] instantiates the unknowns in conjI from left to right
  - `th[of string1 ... stringn]` instantiates the unknowns in the theorem `th` from left to right
  with the terms string1 to stringn
  - 全部のunknownsのインスタンスを生成する必要がない場合、 `conjI[of _ "False"]`と、 `_` を使うことでスキップすることができる
- Unification is the process of making two terms syntactically equal by suitable instantiations of unknowns
  - For example, unifying `?P ^ ?Q` with `a = b ^ False` instantiates `?P` with `a = b` and `?Q` with `False`
  - 明示的に名前を付けて初期化することもできる `conjI[where ?P = "a=b" and ?Q = "Flase"]`と。
*)

subsubsection "4.4.2 Rule Application"

(*
Rule application とは、証明の状態に対して、前に戻るルール(rule backwards)を適用することである

例:
1. ... ==> A /\ B
という証明状態(proof state)に`conjI`を使うと、2つのサブゴール
sub1. ... ==> A
sub2. ... ==> B
が作られる。

\<lbrakk> A1; ...; An \<rbrakk> \<Longrightarrow> A
という規則をあるサブゴール
... ==> C
に適用することは2つのStepを踏んで進む
1. AとCをUnifyし、ルールの中のunknownsのインスタンスを生成する
2. サブゴールCを新たなサブゴールA1からAnまでと置き換える
*)

(*
rule xyzを適用するコマンド：
  aply(rule xyz)

これは、rule xyzでの(backchaining)と、呼ばれもする。
*)

subsubsection "4.4.3 Introduction Rules"

(*
introduction rules:
  They explain under which premises some logical construct can be introduced
  導入規則は、どの前提において、論理構成子が導入されたのかを説明してくれる

eg.
- conjI
- impI
- allI
- iffI

these rules are helpful in locating where and why automation fails.
  自動証明がどこでどうして失敗したのかを示すのに役立つ
*)

(*
Isabelleは色々な導入規則をしっているから、以下のコマンドの入力によって、
現在のサブゴールに対して適切な規則を自動で選ぶ：
  apply rule
*)

(*
`intro`を使えば、自分の定理をintroduction ruleに追加することができる

けれどintro attributeには注意を払わなくてはいけない、
  なぜなら、探索空間を増やし、非決定に導くから。

使うときは, `blast` もしくはそれに近いものを呼び出す中でのみ使うことが推奨される。
*)

lemma "\<lbrakk> (a::nat) \<le> b; b \<le> c; c \<le> d; d \<le> e \<rbrakk> \<Longrightarrow> a \<le> e"
(* apply(auto) *)
by(blast intro: le_trans)

subsubsection "4.4.4 Forward Proof"

(* Forward proof は古い定理から新しい定理を導出すること
- 他のルールへのルールの適用(Application of rules to other rules) は前向きに動作する;前提から結論へ
- 証明状態へのルールの適用(application of rules to proof states)は後ろ向きに動作する;結論から前提へ
*)

(*
すでに`conjI`でも見てたが、`of`がそれ。
  これは自由変数に対して適用する。
`OF`は定理に対して適用する

Given
- a theorem `A ==> B` called r and
- a theorem `A'` called `r'`
,

-> the theorem `r [OF r']` is the result of applying `r` to `r'` ,
  where `r` should be viewed as a function taking a theorem `A` and returning `B`.

More precisely,
- `A` and `A'` are unified(AとA'が統一されていて(これがなされていないと失敗する)),
- thus instantiating the unknowns in `B`(Bの中のunknownsのインスタンスを生成して),
- and the result(`r [OF r']`) is the instantiated `B`(結果が、Bのインスタンスを生成したものになる).
*)

(* 使い方：
r が \<lbrakk> A1, ... , An \<rbrakk> => A という形の時
m \<le> n で、r1からrmまでが定理であるとして、
これらに対して、それらを、unifyして、証明することで
  r [OF r1 ... rm]
が得られる。

例:
  thm conjI [OF refl[of "a"] refl[of "b"]]

なお、
- refl は `?t = ?t` の定理
- thm は結果のみを出すだけのコマンド

これによって、a = a \<and> b = b が得られる。
*)

(*
Forward reasoningは証明状態(proof states)に関連しても意味をなす

modifier の `dest` を使えば、特定のルールを前進に使うように、proof methodに指令するようにできる

modifier `dest: r` allows proof search to reason forward with r,
  i.e., to replace an assumption A', where A' unifies with A,
  with the correspondingly instantiated B
*)

lemma "Suc(Suc(Suc a)) \<le> b ==> a \<le> b"
by(blast dest: Suc_leD)

(*
この例について

blastは複雑な論理式に対して適用する

Suc_leDでbackchainすることもできるが、
前提が結論より複雑だから、backchainすることは非決定を導く
*)

subsection "4.5 Inductive Definitions"

(* they are the key construct in the definition of operational semantics in the second part of the book *)

subsubsection "4.5.1 An Example: Even Numbers"

(* The operative word “inductive” means that these are the only even numbers *)
(* In Isabelle we give the two rules the names `ev0` and `evSS` *)

inductive ev :: "nat => bool" where
ev0: "ev 0"|
(* evSS: "ev n ==> ev(n + 2)" *)
evSS: "ev n ==> ev(Suc(Suc n))"

(* Rule Induction *)

(* 全ての偶数が特定の性質を有していることの証明が難しい例 *)

fun evn :: "nat => bool" where
"evn 0 = True" |
"evn (Suc 0) = False" |
"evn (Suc (Suc n)) = evn n"

(* prove ev m => evn m.

これはRule Inductionの(帰納法を使うという意味で)特殊なケース

we want to prove a property P n for all even n.
But if we assume ev n, then there must be some derivation of this assumption using the two defining rules for ev:
- Case ev0: P 0
- Case evSS: \<lbrakk> ev n; P n\<rbrakk> => P (n + 2)
.

これに該当するルールは、`ev.induct`と呼ばれ、以下のようなものである
  \<lbrakk> ev n, P 0, \<And> n. \<lbrakk> ev n ; P n \<rbrakk> ==> P(n + 2) \<rbrakk> ==> P n

`ev n`が前提に入っているのは、
- nがeven であることを知っている状態であることを要求している
  - これによって、evSSのruleの前提を簡単にする

帰納法の仮定がこの証明の全てにおいて要求しているわけではなく、
evSSのケースの処理において、ev nを持っていることが本質的である。

ルールのこのケース分析は "rule invension"と呼ばれ、chap 5で議論されている
*)

(* In Isabelle *)

(* recast the above informal proofs in Isabelle. *)
(* First, Suc terms instead of numerals in rule evSS *)

(* The simplest way to prove ev (Suc (Suc (Suc (Suc 0)))) is in a forward
direction: evSS[OF evSS[OF ev0]] yields the theorem ev (Suc (Suc (Suc(Suc 0)))). *)
lemma "ev(Suc(Suc(Suc(Suc 0))))"
apply(rule evSS)
apply(rule evSS)
apply(rule ev0)
done

(* Rule induction is applied by giving the induction rule explicitly via the rule: modifier: *)
lemma "ev m ==> evn m"
apply(induction rule: ev.induct)
by(simp_all)

(* Note that if there are multiple assumptions of the form ev t, method induction will induct on the leftmost one. *)

lemma "evn n ==> ev n"
apply(induction n rule: evn.induct)
by(simp_all add: ev0 evSS)

(*
`ev`のためのルールは、完璧な単純化と導入規則を作っている。
  なぜなら、それらの前提は常に結論より小さいから。
単純化と導入規則にそれらを永久的に変える場合に意味をなす
  証明の自動化をよりよくするために

Isabelleでは、 `ev.intros`と名付けられている。
*)
declare ev.intros[simp,intro]

(*
帰納的な定義はデフォルトでは単純化規則ではない。
  なぜなら、再帰的な関数とは異なり、帰納的定義には決定性の条件がないから
*)

(* Inductive Versus Recursive *)

(*
再帰的な方が便利ではある。
  項の中間を書ける
  何が正しいかというポジティブな情報と何が間違いかのネガティブな情報の両方を直接表現できる。

帰納的な方は、ポジティブな情報しか直接には表現しない。

Rule Induction はある証明にはよく合っている
  ポジティブなケースの証明のみを要求しているケース
    再帰的な方のinductで証明しようとすると、ネガティブなケースを明示的にしないといけない。

書き換えとRule Inductionの両方の恩恵を受けたいなら
  再帰的と帰納的の両方の二つの定義を書いて
    それらの等しさを示すか、
  新たに定義を作り
    そこから追加の性質を証明するか
*)

(*
多くの概念は、再帰的定義を許容していない
  なぜなら再帰のためのdatatypeがないから

あと、再帰は止まらないかもしれない

再帰的な定義があったとしても、ポジティブな情報にしか興味がないなら、
帰納的定義の方がよりシンプルである。
*)

subsubsection "4.5.2 The Reflexive Transitive Closure"

(* 反射的で推移的閉包 `star` ：
  binary predicateを別のbinary predicateに変換する
*)

inductive star :: "('a => 'a => bool) => 'a => 'a => bool" for r where
refl: "star r x x" |
step: "r x y ==> star r y z ==> star r x z"

(* `for r` というのは、Isabelle に r は star において fixed parameter であることを教えるための者 *)

(* 推移的(transitive)であることの証明 *)
lemma star_trans: "star r x y ==> star r y z ==> star r x z"
apply(induction rule: star.induct)
(* autoを使わない理由は知らないが、多分、何を使うか分かり切っているからなのでは？ *)
apply(assumption)
(* sledgehammer *)
(* by (simp add: star.step) *)
(* テキストでmetisが使われているのは、straightforwarだから、と説明されている。 *)
by (metis step)

subsubsection "4.5.3 The General Case"

(* Inductive な定義は以下のような一般形式をたいていの場合持っている
  inductive I :: "t => bool" where
そして、それに続くルールは以下のような形式を持っている(n がゼロの場合もある)
  \<lbrakk> I a1; ... ; I an \<rbrakk> ==> I a
また、これらのルールは `|` でわけられている。

これに該当するrule induction は `I.induct` だり、これは、以下のような形式の命題に適用される
  I x ==> P x

Rule inductionは常にゴールの一番左のの前提に対してであり、よって、 `I x` は常に最初の前提でなければならない。

`I x ==> P x` をrule inductionによって証明するというのは、Iのすべての規則に対して、Pが不変であるということ、つまり
  \<lbrakk> I a1; P a1;... ; I an; P an \<rbrakk> ==> P a
*)

(*
Iを含まないような追加の前提をもっているargumentsや規則をもっている場合がある
  これはside conditionsと呼ばれる
    これは追加の前提として表れることがある

`for` は反射的で推移的な閉包において、induction ruleを単純化するために用いられる。
*)

subsection "Exercises"

(* Exercise 4.2 *)
inductive palindrome :: "'a list => bool" where
"palindrome []" |
"palindrome [x]" |
"palindrome xs ==> palindrome (a # xs @ [a])"

lemma "palindrome xs ==> rev xs = xs"
apply(induction rule:palindrome.induct)
apply(auto)
done

(* Exercise 4.3. *)
inductive star' :: "( 'a => 'a => bool) => 'a => 'a => bool" for r where
refl' : "star' r x x" |
step' : "star' r x y ==> r y z ==> star' r x z"

lemma "star' r x y ==> star r x y"
apply(induction rule: star'.induct)
apply(rule refl)
 by (meson star.refl star.step star_trans)

(* cf: https://github.com/sergv/isabelle-playground/blob/master/Chapter4.thy *)

lemma star'_singleton : "r a b \<Longrightarrow> star' r a b"
by(metis step' refl')

(*  1. \<And>x. r x c \<Longrightarrow> star r x c *)
lemma ext_star'_from_left : "star' r y z \<Longrightarrow> r x y \<Longrightarrow> star' r x z"
apply(induction rule: star'.induct)
apply(simp add:star'_singleton)
(* sledgehammer *)
by (meson step')

(*  1. \<And>x y z. r x y \<Longrightarrow> star r y z \<Longrightarrow> star' r y z \<Longrightarrow> star' r x z *)
lemma "star r x y ==> star' r x y"
apply(induction rule: star.induct)
apply(rule refl')
apply(simp add: step ext_star'_from_left)
done

(* Exercise 4.4. *)
inductive iter :: "('a  => 'a => bool) => nat => 'a => 'a => bool" for r where
iter_refl: "iter r n x x" |
iter_step: "r x y ==> iter r n y z ==> iter r (Suc n) x z"

(* r y z ==> ...という形ではダメ。from: Rule inductionは常にゴールの一番左のの前提に対して *)
(* lemma ext_iter : "iter r n x y ==> r y z ==> iter r (Suc n) x z"
apply(induction rule:iter.induct)
apply() *)

(* 問で、nについての説明が一切ないので、存在することを示すことにした。 *)
(*  1. \<And>x y z. r x y \<Longrightarrow> star r y z \<Longrightarrow> iter r n y z \<Longrightarrow> iter r n x z *)
lemma "star r x y ==> \<exists> n. iter r n x y"
apply(induction rule: star.induct)
apply(metis iter_refl)
(* sledgehammer *)
by (meson iter_step)

(* Exercise 4.5. *)

datatype alpha = a | b

inductive S :: "alpha list => bool" where
SEmpty: "S[]" |
SConct: "S w ==> S (a # w @ [b])" |
SDoubl: "S w1 ==> S w2 ==> S (w1@w2)"

inductive T :: "alpha list => bool" where
emptyT: "T[]" |
balanceT: "T w1 ==> T w2 ==> T(w1@[a]@w2@[b])"

lemma TtoS: "T w ==> S w"
apply(induction rule: T.induct)
apply(rule S.SEmpty)
by (simp add: SConct SDoubl)

(* cf: https://github.com/sergv/isabelle-playground/blob/master/Chapter4.thy *)
(* この道具を使わないと、とても面倒な証明が要求されてしまう *)
(* thm balanceT[OF emptyT]
lemmas balanceT' = balanceT[OF emptyT, simplified] *)

(* simpを使っている理由は、autoがsimpより多くのことをやるから *)
lemma balance_composite_first: "T (w1 @ w2) ==> T w3 ==>  T (w1 @ w2 @ [a] @ w3 @ [b])"
apply(simp)
apply(rule balanceT[of "w1 @ w2" w3, simplified])
(* sledgehammer *)
apply(auto)
done

(*  1. \<And>w1 w2a.
       T w1 \<Longrightarrow>
       T (w1 @ w2) \<Longrightarrow> T w2a \<Longrightarrow> T (w2a @ w2) \<Longrightarrow> T w2 \<Longrightarrow> T (w1 @ a # w2a @ b # w2) *)
lemma composite_T : "T w2 ==> T w1 ==> T (w1 @ w2)"
apply(induction arbitrary: w1 rule: T.induct)
apply(simp)
(* sledgehammer *)
using balance_composite_first by auto

(* 1. \<And>w1 w2. S w1 \<Longrightarrow> T w1 \<Longrightarrow> S w2 \<Longrightarrow> T w2 \<Longrightarrow> T (w1 @ w2) *)
lemma StoT: "S w ==> T w"
apply(induction rule: S.induct)
apply(rule emptyT)
using balanceT emptyT apply fastforce
(* sledgehammer *)
by (simp add: composite_T)

(* Exercise 4.6. *)

type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp
type_synonym val = int
type_synonym state = "vname => val"

fun aval :: "aexp => state => val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a1 a2) s = aval a1 s + aval a2 s"

inductive aval_rel' :: "aexp => state => val => bool" where
ar_const: "aval_rel' (N n) s n" |
ar_var: "s x = v ==> aval_rel' (V x) s v" |
ar_plus: "aval_rel' a1 s n1 ==>  aval_rel' a2 s n2 ==> aval_rel' (Plus a1 a2) s (n1 + n2)"

lemma aval_rel_is_consistent_with_aval : "aval_rel' exp s v ==> aval exp s = v"
apply(induction rule: aval_rel'.induct)
apply(auto)
done

lemma aval_is_consistent_with_aval_rel : "aval exp s = v ==> aval_rel' exp s v"
apply(induction exp arbitrary: v)
apply(simp add: ar_const)
apply(simp add: ar_var)
apply(simp add: ar_plus)
(* sledgehammer *)
by (meson aval_rel'.simps)

corollary aval_and_aval_rel_is_equiv: "aval exp s = v \<longleftrightarrow> aval_rel' exp s v"
(* sledgehammer *)
 using aval_is_consistent_with_aval_rel aval_rel_is_consistent_with_aval by blast

(* Exercise 4.7. *)
datatype instr = LOADI val | LOAD vname | ADD
(* type_synonym stack = "val list" *)
(* sergvのを丸パクリしている *)
datatype stack = Stack "val list"

fun push :: "val \<Rightarrow> stack \<Rightarrow> stack" where
"push x (Stack xs) = Stack (x # xs)"

fun top :: "stack \<Rightarrow> val" where
"top (Stack (x # _)) = x"

fun top2 :: "stack \<Rightarrow> val" where
"top2 (Stack (_ # x # _)) = x"

fun drop2 :: "stack \<Rightarrow> stack" where
"drop2 (Stack (_ # _ # xs)) = Stack xs"

fun stack_length :: "stack \<Rightarrow> nat" where
"stack_length (Stack xs) = length xs"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec1 (LOADI n) _ stk = push n stk"     |
"exec1 (LOAD v)  s stk = push (s v) stk" |
"exec1 ADD       _ stk = push (top stk + top2 stk) (drop2 stk)"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec []       _ stk = stk" |
"exec (i # is) s stk = exec is s (exec1 i s stk)"

lemma exec_division: "exec (is1 @ is2) s stk = exec is2 s (exec is1 s stk )"
apply(induction is1 arbitrary: stk)
apply(auto)
done

inductive ok :: "nat => instr list => nat => bool" where
ok_emp: "ok n [] n" |
ok_LOADI: "ok n is m ==> ok n (is @ [LOADI _]) (Suc m)" |
ok_LOAD: "ok n is m ==> ok n (is @ [LOAD _]) (Suc m)"|
ok_ADD: "ok n is\<^sub>1 (Suc n) \<Longrightarrow> ok (Suc n) is\<^sub>2 (Suc (Suc n)) \<Longrightarrow> ok n (is\<^sub>1 @ is\<^sub>2 @ [instr.ADD]) (Suc n)"

thm ok.induct

(* lemma "ok (length stk) is1 (Suc (Suc m)) ==> length (exec1 ADD s (exec is1 s stk)) = Suc m" *)

lemma length_of_pushed_stack : "stack_length (push x stk) = Suc (stack_length stk)"
apply(induction stk)
apply(auto)
done

lemma length_of_twice_dropped_stack : "stack_length stk = Suc (Suc n) \<Longrightarrow> stack_length (drop2 stk) = n"
apply(induction stk rule: drop2.induct)
apply(simp_all)
done

(*
 1. \<And>n is1 m is2 stk.
       ok n is1 (Suc m) \<Longrightarrow>
       (\<And>stk. length stk = n \<Longrightarrow> length (exec is1 s stk) = Suc m) \<Longrightarrow>
       ok n is2 (Suc (Suc m)) \<Longrightarrow>
       (\<And>stk. length stk = n \<Longrightarrow> length (exec is2 s stk) = Suc (Suc m)) \<Longrightarrow>
       length stk = n \<Longrightarrow>
       length (exec1 ADD s (exec is2 s (exec is1 s stk))) = Suc m
*)
(*
 1. \<And>is1 m stk.
       ok (length stk) is1 (Suc (Suc m)) \<Longrightarrow>
       (\<And>stka.
           length stka = length stk \<Longrightarrow> length (exec is1 s stka) = Suc (Suc m)) \<Longrightarrow>
       length (exec1 ADD s (exec is1 s stk)) = Suc m
*)
lemma "\<lbrakk>ok n is n'; stack_length stk = n \<rbrakk> \<Longrightarrow> stack_length (exec is s stk) = n'"
apply(induction arbitrary: stk rule: ok.induct)
apply(simp)
apply(simp_all only: exec_division exec.simps exec1.simps)
apply(simp_all only: length_of_pushed_stack)
apply(simp only: length_of_twice_dropped_stack)
done

(* Stackをval listのtype_synonymではなく、datatypeとして導入していることがなんでここまで作用するのかわからない *)

fun comp :: "aexp => instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e1 e2) = comp e1 @ comp e2 @ [ADD]"

theorem "ok n (comp x) (Suc n)"
apply(induction x arbitrary: n)
apply(simp_all)
(* sledgehammer *)
using ok_LOADI ok_emp apply fastforce
using ok_LOAD ok_emp apply fastforce
(* sledgehammer *)
using ok_ADD by blast

end


(*
   File:      Pi_Transcendental_Polynomial_Library
   Author:    Manuel Eberl, TU München

   Various facts about univariate polynomials and some other things that probably belong in
   the distribution.
*)
section \<open>Preliminary facts\<close>
theory Pi_Transcendental_Polynomial_Library
  imports "HOL-Computational_Algebra.Computational_Algebra"
begin

unbundle multiset.lifting

(* TODO: Move all this *)
lemma Ints_sum: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> \<int>) \<Longrightarrow> sum f A \<in> \<int>"
  by (induction A rule: infinite_finite_induct) auto

lemma Ints_prod: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> \<int>) \<Longrightarrow> prod f A \<in> \<int>"
  by (induction A rule: infinite_finite_induct) auto

lemma sum_in_Rats [intro]: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> \<rat>) \<Longrightarrow> sum f A \<in> \<rat>"
  by (induction A rule: infinite_finite_induct) auto

lemma prod_in_Rats [intro]: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> \<rat>) \<Longrightarrow> prod f A \<in> \<rat>"
  by (induction A rule: infinite_finite_induct) auto

lemma poly_cnj: "cnj (poly p z) = poly (map_poly cnj p) (cnj z)"
  by (simp add: poly_altdef degree_map_poly coeff_map_poly)

lemma poly_cnj_real:
  assumes "\<And>n. poly.coeff p n \<in> \<real>"
  shows   "cnj (poly p z) = poly p (cnj z)"
proof -
  from assms have "map_poly cnj p = p"
    by (intro poly_eqI) (auto simp: coeff_map_poly Reals_cnj_iff)
  with poly_cnj[of p z] show ?thesis by simp
qed

lemma real_poly_cnj_root_iff:
  assumes "\<And>n. poly.coeff p n \<in> \<real>"
  shows   "poly p (cnj z) = 0 \<longleftrightarrow> poly p z = 0"
proof -
  have "poly p (cnj z) = cnj (poly p z)"
    by (simp add: poly_cnj_real assms)
  also have "\<dots> = 0 \<longleftrightarrow> poly p z = 0" by simp
  finally show ?thesis .
qed

lemma coeff_pcompose_linear:
  fixes p :: "'a :: comm_semiring_1 poly"
  shows "coeff (pcompose p [:0, c:]) i = c ^ i * coeff p i"
  by (induction p arbitrary: i) (auto simp: pcompose_pCons coeff_pCons mult_ac split: nat.splits)

lemma coeff_pCons': "poly.coeff (pCons c p) n = (if n = 0 then c else poly.coeff p (n - 1))"
  by transfer'(auto split: nat.splits)

lemma prod_smult: "(\<Prod>x\<in>A. Polynomial.smult (c x) (p x)) = Polynomial.smult (prod c A) (prod p A)"
  by (induction A rule: infinite_finite_induct) (auto simp: mult_ac)

lemma degree_higher_pderiv: "Polynomial.degree ((pderiv ^^ n) p) = Polynomial.degree p - n"
  for p :: "'a::{comm_semiring_1,semiring_no_zero_divisors,semiring_char_0} poly"
  by (induction n) (auto simp: degree_pderiv)

lemma sum_to_poly: "(\<Sum>x\<in>A. [:f x:]) = [:\<Sum>x\<in>A. f x:]"
  by (induction A rule: infinite_finite_induct) auto

lemma diff_to_poly: "[:c:] - [:d:] = [:c - d:]"
  by (simp add: poly_eq_iff mult_ac)

lemma mult_to_poly: "[:c:] * [:d:] = [:c * d:]"
  by (simp add: poly_eq_iff mult_ac)

lemma prod_to_poly: "(\<Prod>x\<in>A. [:f x:]) = [:\<Prod>x\<in>A. f x:]"
  by (induction A rule: infinite_finite_induct) (auto simp: mult_to_poly mult_ac)

lemma coeff_mult_0: "poly.coeff (p * q) 0 = poly.coeff p 0 * poly.coeff q 0"
  by (simp add: coeff_mult)

lemma card_poly_roots_bound:
  fixes p :: "'a::{comm_ring_1,ring_no_zero_divisors} poly"
  assumes "p \<noteq> 0"
  shows   "card {x. poly p x = 0} \<le> degree p"
using assms
proof (induction "degree p" arbitrary: p rule: less_induct)
  case (less p)
  show ?case
  proof (cases "\<exists>x. poly p x = 0")
    case False
    hence "{x. poly p x = 0} = {}" by blast
    thus ?thesis by simp
  next
    case True
    then obtain x where x: "poly p x = 0" by blast
    hence "[:-x, 1:] dvd p" by (subst (asm) poly_eq_0_iff_dvd)
    then obtain q where q: "p = [:-x, 1:] * q" by (auto simp: dvd_def)
    with \<open>p \<noteq> 0\<close> have [simp]: "q \<noteq> 0" by auto
    have deg: "degree p = Suc (degree q)"
      by (subst q, subst degree_mult_eq) auto
    have "card {x. poly p x = 0} \<le> card (insert x {x. poly q x = 0})"
      by (intro card_mono) (auto intro: poly_roots_finite simp: q)
    also have "\<dots> \<le> Suc (card {x. poly q x = 0})"
      by (rule card_insert_le_m1) auto
    also from deg have  "card {x. poly q x = 0} \<le> degree q"
      using \<open>p \<noteq> 0\<close> and q by (intro less) auto
    also have "Suc \<dots> = degree p" by (simp add: deg)
    finally show ?thesis by - simp_all
  qed
qed

lemma poly_eqI_degree:
  fixes p q :: "'a :: {comm_ring_1, ring_no_zero_divisors} poly"
  assumes "\<And>x. x \<in> A \<Longrightarrow> poly p x = poly q x"
  assumes "card A > degree p" "card A > degree q"
  shows   "p = q"
proof (rule ccontr)
  assume neq: "p \<noteq> q"
  have "degree (p - q) \<le> max (degree p) (degree q)"
    by (rule degree_diff_le_max)
  also from assms have "\<dots> < card A" by linarith
  also have "\<dots> \<le> card {x. poly (p - q) x = 0}"
    using neq and assms by (intro card_mono poly_roots_finite) auto
  finally have "degree (p - q) < card {x. poly (p - q) x = 0}" .
  moreover have "degree (p - q) \<ge> card {x. poly (p - q) x = 0}"
    using neq by (intro card_poly_roots_bound) auto
  ultimately show False by linarith
qed

lemma poly_root_order_induct [case_names 0 no_roots root]:
  fixes p :: "'a :: idom poly"
  assumes "P 0" "\<And>p. (\<And>x. poly p x \<noteq> 0) \<Longrightarrow> P p"
          "\<And>p x n. n > 0 \<Longrightarrow> poly p x \<noteq> 0 \<Longrightarrow> P p \<Longrightarrow> P ([:-x, 1:] ^ n * p)"
  shows   "P p"
proof (induction "degree p" arbitrary: p rule: less_induct)
  case (less p)
  consider "p = 0" | "p \<noteq> 0" "\<exists>x. poly p x = 0" | "\<And>x. poly p x \<noteq> 0" by blast
  thus ?case
  proof cases
    case 3
    with assms(2)[of p] show ?thesis by simp
  next
    case 2
    then obtain x where x: "poly p x = 0" by auto
    have "[:-x, 1:] ^ order x p dvd p" by (intro order_1)
    then obtain q where q: "p = [:-x, 1:] ^ order x p * q" by (auto simp: dvd_def)
    with 2 have [simp]: "q \<noteq> 0" by auto
    have order_pos: "order x p > 0"
      using \<open>p \<noteq> 0\<close> and x by (auto simp: order_root)
    have "order x p = order x p + order x q"
      by (subst q, subst order_mult) (auto simp: order_power_n_n)
    hence [simp]: "order x q = 0" by simp
    have deg: "degree p = order x p + degree q"
      by (subst q, subst degree_mult_eq) (auto simp: degree_power_eq)
    with order_pos have "degree q < degree p" by simp
    hence "P q" by (rule less)
    with order_pos have "P ([:-x, 1:] ^ order x p * q)"
      by (intro assms(3)) (auto simp: order_root)
    with q show ?thesis by simp
  qed (simp_all add: assms(1))
qed

lemma complex_poly_decompose:
  "smult (lead_coeff p) (\<Prod>z|poly p z = 0. [:-z, 1:] ^ order z p) = (p :: complex poly)"
proof (induction p rule: poly_root_order_induct)
  case (no_roots p)
  show ?case
  proof (cases "degree p = 0")
    case False
    hence "\<not>constant (poly p)" by (subst constant_degree)
    with fundamental_theorem_of_algebra and no_roots show ?thesis by blast
  qed (auto elim!: degree_eq_zeroE)
next
  case (root p x n)
  from root have *: "{z. poly ([:- x, 1:] ^ n * p) z = 0} = insert x {z. poly p z = 0}"
    by auto
  have "smult (lead_coeff ([:-x, 1:] ^ n * p))
           (\<Prod>z|poly ([:-x,1:] ^ n * p) z = 0. [:-z, 1:] ^ order z ([:- x, 1:] ^ n * p)) =
        [:- x, 1:] ^ order x ([:- x, 1:] ^ n * p) *
          smult (lead_coeff p) (\<Prod>z\<in>{z. poly p z = 0}. [:- z, 1:] ^ order z ([:- x, 1:] ^ n * p))"
    by (subst *, subst prod.insert)
       (insert root, auto intro: poly_roots_finite simp: mult_ac lead_coeff_mult lead_coeff_power)
  also have "order x ([:- x, 1:] ^ n * p) = n"
    using root by (subst order_mult) (auto simp: order_power_n_n order_0I)
  also have "(\<Prod>z\<in>{z. poly p z = 0}. [:- z, 1:] ^ order z ([:- x, 1:] ^ n * p)) =
               (\<Prod>z\<in>{z. poly p z = 0}. [:- z, 1:] ^ order z p)"
  proof (intro prod.cong refl, goal_cases)
    case (1 y)
    with root have "order y ([:-x,1:] ^ n) = 0" by (intro order_0I) auto
    thus ?case using root by (subst order_mult) auto
  qed
  also note root.IH
  finally show ?case .
qed simp_all

lemma order_pos_iff: "p \<noteq> 0 \<Longrightarrow> order a p > 0 \<longleftrightarrow> poly p a = 0"
  using order_root[of p a] by auto

lift_definition poly_roots_mset :: "('a :: idom) poly \<Rightarrow> 'a multiset" is
  "\<lambda>p x. if p = 0 then 0 else Polynomial.order x p"
proof -
  fix p :: "'a poly"
  show "finite {x. 0 < (if p = 0 then 0 else order x p)}"
    by (cases "p = 0")
       (auto simp: order_pos_iff intro: finite_subset[OF _ poly_roots_finite[of p]])
qed

lemma poly_roots_mset_0 [simp]: "poly_roots_mset 0 = {#}"
  by transfer' auto

lemma count_poly_roots_mset [simp]:
  "p \<noteq> 0 \<Longrightarrow> count (poly_roots_mset p) a = order a p"
  by transfer' auto

lemma set_count_poly_roots_mset [simp]:
   "p \<noteq> 0 \<Longrightarrow> set_mset (poly_roots_mset p) = {x. poly p x = 0}"
  by (auto simp: set_mset_def order_pos_iff)

lemma image_prod_mset_multiplicity:
  "prod_mset (image_mset f M) = prod (\<lambda>x. f x ^ count M x) (set_mset M)"
proof (induction M)
  case (add x M)
  show ?case
  proof (cases "x \<in> set_mset M")
    case True
    have "(\<Prod>y\<in>set_mset (add_mset x M). f y ^ count (add_mset x M) y) =
            (\<Prod>y\<in>set_mset M. (if y = x then f x else 1) * f y ^ count M y)"
      using True add by (intro prod.cong) auto
    also have "\<dots> = f x * (\<Prod>y\<in>set_mset M. f y ^ count M y)"
      using True by (subst prod.distrib) auto
    also note add.IH [symmetric]
    finally show ?thesis using True by simp
  next
    case False
    hence "(\<Prod>y\<in>set_mset (add_mset x M). f y ^ count (add_mset x M) y) =
              f x * (\<Prod>y\<in>set_mset M. f y ^ count (add_mset x M) y)"
      by (auto simp: not_in_iff)
    also have "(\<Prod>y\<in>set_mset M. f y ^ count (add_mset x M) y) =
                 (\<Prod>y\<in>set_mset M. f y ^ count M y)"
      using False by (intro prod.cong) auto
    also note add.IH [symmetric]
    finally show ?thesis by simp
  qed
qed auto

lemma complex_poly_decompose_multiset:
  "smult (lead_coeff p) (\<Prod>x\<in>#poly_roots_mset p. [:-x, 1:]) = (p :: complex poly)"
proof (cases "p = 0")
  case False
  hence "(\<Prod>x\<in>#poly_roots_mset p. [:-x, 1:]) = (\<Prod>x | poly p x = 0. [:-x, 1:] ^ order x p)"
    by (subst image_prod_mset_multiplicity) simp_all
  also have "smult (lead_coeff p) \<dots> = p"
    by (rule complex_poly_decompose)
  finally show ?thesis .
qed auto

lemma (in monoid_add) prod_list_prod_nth:
  "prod_list xs = (\<Prod>i=0..<length xs. xs ! i)"
proof -
  have "xs = map (\<lambda>i. xs ! i) [0..<length xs]"
    by (simp add: map_nth)
  also have "prod_list \<dots> = (\<Prod>i=0..<length xs. xs ! i)"
    by (subst prod.distinct_set_conv_list [symmetric]) auto
  finally show ?thesis .
qed

lemma prod_zero_iff': "finite A \<Longrightarrow> prod f A = 0 \<longleftrightarrow> (\<exists>x\<in>A. f x = 0)"
  for f :: "'a \<Rightarrow> 'b :: {comm_semiring_1, semiring_no_zero_divisors}"
  by (induction A rule: infinite_finite_induct) auto

lemma degree_prod_eq: "(\<And>x. x \<in> A \<Longrightarrow> f x \<noteq> 0) \<Longrightarrow> degree (prod f A) = (\<Sum>x\<in>A. degree (f x))"
  for f :: "'a \<Rightarrow> 'b::{comm_semiring_1, semiring_no_zero_divisors} poly"
  by (induction A rule: infinite_finite_induct) (auto simp: degree_mult_eq prod_zero_iff')

lemma lead_coeff_prod: "(\<And>x. x \<in> A \<Longrightarrow> f x \<noteq> 0) \<Longrightarrow> lead_coeff (prod f A) = (\<Prod>x\<in>A. lead_coeff (f x))"
  for f :: "'a \<Rightarrow> 'b :: {comm_semiring_1, semiring_no_zero_divisors} poly"
  by (induction A rule: infinite_finite_induct) (auto simp: lead_coeff_mult prod_zero_iff')

lemma complex_poly_decompose':
  obtains root where "smult (lead_coeff p) (\<Prod>i<degree p. [:-root i, 1:]) = (p :: complex poly)"
proof -
  obtain roots where roots: "mset roots = poly_roots_mset p"
    using ex_mset by blast

  have "p = smult (lead_coeff p) (\<Prod>x\<in>#poly_roots_mset p. [:-x, 1:])"
    by (rule complex_poly_decompose_multiset [symmetric])
  also have "(\<Prod>x\<in>#poly_roots_mset p. [:-x, 1:]) = (\<Prod>x\<leftarrow>roots. [:-x, 1:])"
    by (subst prod_mset_prod_list [symmetric]) (simp add: roots)
  also have "\<dots> = (\<Prod>i<length roots. [:-roots ! i, 1:])"
    by (subst prod_list_prod_nth) (auto simp: atLeast0LessThan)
  finally have eq: "p = smult (lead_coeff p) (\<Prod>i<length roots. [:-roots ! i, 1:])" .
  also have [simp]: "degree p = length roots"
    using roots by (subst eq) (auto simp: degree_prod_eq)
  finally show ?thesis by (intro that[of "\<lambda>i. roots ! i"]) auto
qed

lemma rsquarefree_root_order:
  assumes "rsquarefree p" "poly p z = 0" "p \<noteq> 0"
  shows   "order z p = 1"
proof -
  from assms have "order z p \<in> {0, 1}" by (auto simp: rsquarefree_def)
  moreover from assms have "order z p > 0" by (auto simp: order_root)
  ultimately show "order z p = 1" by auto
qed

lemma complex_poly_decompose_rsquarefree:
  assumes "rsquarefree p"
  shows   "smult (lead_coeff p) (\<Prod>z|poly p z = 0. [:-z, 1:]) = (p :: complex poly)"
proof (cases "p = 0")
  case False
  have "(\<Prod>z|poly p z = 0. [:-z, 1:]) = (\<Prod>z|poly p z = 0. [:-z, 1:] ^ order z p)"
    using assms False by (intro prod.cong) (auto simp: rsquarefree_root_order)
  also have "smult (lead_coeff p) \<dots> = p"
    by (rule complex_poly_decompose)
  finally show ?thesis .
qed auto

lemma pcompose_conjugates_integer:
  assumes "\<And>i. poly.coeff p i \<in> \<int>"
  shows   "poly.coeff (pcompose p [:0, \<i>:] * pcompose p [:0, -\<i>:]) i \<in> \<int>"
proof -
  let ?c = "\<lambda>i. poly.coeff p i :: complex"
  have "poly.coeff (pcompose p [:0, \<i>:] * pcompose p [:0, -\<i>:]) i =
          \<i> ^ i * (\<Sum>k\<le>i. (-1) ^ (i - k) * ?c k * ?c (i - k))"
    unfolding coeff_mult sum_distrib_left
    by (intro sum.cong) (auto simp: coeff_mult coeff_pcompose_linear power_minus'
                                    power_diff field_simps intro!: Ints_sum)
  also have "(\<Sum>k\<le>i. (-1) ^ (i - k) * ?c k * ?c (i - k)) =
          (\<Sum>k\<le>i. (-1) ^ k * ?c k * ?c (i - k))" (is "?S1 = ?S2")
    by (intro sum.reindex_bij_witness[of _ "\<lambda>k. i - k" "\<lambda>k. i - k"]) (auto simp: mult_ac)
  hence "?S1 = (?S1 + ?S2) / 2" by simp
  also have "\<dots> = (\<Sum>k\<le>i. ((-1) ^ k + (-1) ^ (i - k)) / 2 * ?c k * ?c (i - k))"
    by (simp add: ring_distribs sum.distrib sum_divide_distrib [symmetric])
  also have "\<dots> = (\<Sum>k\<le>i. (1 + (-1) ^ i) / 2 * (-1) ^ k * ?c k * ?c (i - k))"
    by (intro sum.cong) (auto simp: power_add power_diff field_simps)
  also have "\<i> ^ i * \<dots> \<in> \<int>"
  proof (cases "even i")
    case True
    thus ?thesis
      by (intro Ints_mult Ints_sum assms) (auto elim!: evenE simp: power_mult)
  next
    case False
    hence "1 + (-1) ^ i = (0 :: complex)" by (auto elim!: oddE simp: power_mult)
    thus ?thesis by simp
  qed
  finally show ?thesis .
qed

lemma algebraic_times_i:
  assumes "algebraic x"
  shows   "algebraic (\<i> * x)" "algebraic (-\<i> * x)"
proof -
  from assms obtain p where p: "poly p x = 0" "\<forall>i. coeff p i \<in> \<int>" "p \<noteq> 0"
    by (auto elim!: algebraicE)
  define p' where "p' = pcompose p [:0, \<i>:] * pcompose p [:0, -\<i>:]"
  have p': "poly p' (\<i> * x) = 0" "poly p' (-\<i> * x) = 0" "p' \<noteq> 0"
    by (auto simp: p'_def poly_pcompose algebra_simps p dest: pcompose_eq_0)
  moreover have "\<forall>i. poly.coeff p' i \<in> \<int>"
    using p unfolding p'_def by (intro allI pcompose_conjugates_integer) auto
  ultimately show "algebraic (\<i> * x)" "algebraic (-\<i> * x)" by (intro algebraicI[of p']; simp)+
qed

lemma algebraic_times_i_iff: "algebraic (\<i> * x) \<longleftrightarrow> algebraic x"
  using algebraic_times_i[of x] algebraic_times_i[of "\<i> * x"] by auto

lemma ratpolyE:
  assumes "\<forall>i. poly.coeff p i \<in> \<rat>"
  obtains q where "p = map_poly of_rat q"
proof -
  have "\<forall>i\<in>{..Polynomial.degree p}. \<exists>x. poly.coeff p i = of_rat x"
    using assms by (auto simp: Rats_def)
  from bchoice[OF this] obtain f
    where f: "\<And>i. i \<le> Polynomial.degree p \<Longrightarrow> poly.coeff p i = of_rat (f i)" by blast
  define q where "q = Poly (map f [0..<Suc (Polynomial.degree p)])"
  have "p = map_poly of_rat q"
    by (intro poly_eqI)
       (auto simp: coeff_map_poly q_def nth_default_def f coeff_eq_0 simp del: upt_Suc)
  with that show ?thesis by blast
qed

lifting_update multiset.lifting
lifting_forget multiset.lifting

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_NStoogeSortCount
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype Nat = Z | S "Nat"

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

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

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

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

(*fun did not finish the proof*)
function third :: "Nat => Nat" where
  "third y =
   (if (y = (S (S Z))) then Z else
      (if (y = (S Z)) then Z else
         (case y of
            Z => Z
            | S z => plus (S Z) (third (minus y (S (S (S Z))))))))"
  by pat_completeness auto

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

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

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge1sort2 :: "Nat list => Nat list"
  and nstoogesort :: "Nat list => Nat list"
  and nstooge1sort1 :: "Nat list => Nat list" where
  "nstooge1sort2 y =
   (case splitAt (third (length y)) (reverse y) of
      pair2 ys2 zs2 => x (nstoogesort zs2) (reverse ys2))"
| "nstoogesort (nil2) = nil2"
| "nstoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge1sort2
       (nstooge1sort1 (nstooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge1sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort zs1))"
  by pat_completeness auto

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

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

end


theory AddPredicateTransformers
  imports MonoPredicateTransformers
begin

definition additive :: "('a :: bbi \<Rightarrow> 'b :: bbi) \<Rightarrow> bool" where
  "additive f \<equiv> \<forall>x y. f (x + y) = f x + f y"

definition comp_additive :: "('a :: bbi \<Rightarrow> 'b :: bbi) \<Rightarrow> bool" where
  "comp_additive f \<equiv> \<forall>X. f (\<Squnion>X) = \<Squnion>{f x | x. x \<in> X}"

lemma comp_add_addI: "comp_additive f \<Longrightarrow> additive f"
proof (auto simp: comp_additive_def additive_def)
  fix x y assume "\<forall>X. f (\<Squnion>X) = \<Squnion>{f x |x. x \<in> X}"
  hence "f (\<Squnion>{x, y}) = \<Squnion>{f z |z. z \<in> {x, y}}" by metis
  thus "f (x + y) = f x + f y"
    by (auto intro!: Sup_eqI) metis+
qed

lemma add_mono[dest?]: "additive F \<Longrightarrow> mono F"
  by (auto simp add: mono_def additive_def) (metis le_iff_sup)

lemma comp_add_mono[dest?]: "comp_additive F \<Longrightarrow> mono F"
  by (metis add_mono comp_add_addI)

text {* Closed operations *}

lemma comp_additive_skip [simp,intro]: "comp_additive id"
  by (simp add: comp_additive_def)

lemma comp_additive_comp_clos [intro]: "\<lbrakk>comp_additive (F :: 'a :: bbi \<Rightarrow> 'a); comp_additive (G :: 'a :: bbi \<Rightarrow> 'a)\<rbrakk> \<Longrightarrow> comp_additive (F o G)"
  by (auto simp: comp_additive_def intro!: Sup_eqI Sup_upper Sup_least) force

lemma comp_additive_abort [simp,intro]: "comp_additive \<bottom>"
  by (simp add: comp_additive_def)

lemma comp_additive_sup_clos [intro]: "\<lbrakk>comp_additive F; comp_additive G\<rbrakk> \<Longrightarrow> comp_additive (F + G)"
  apply (auto simp: comp_additive_def intro!: Sup_eqI[symmetric])
  apply (rule le_supI1, auto intro!: Sup_least Sup_upper)
  by (auto intro!: le_supI2 Sup_upper)

text {* Meet and top are not closed under complete additivity *}

lemma comp_additive_inf_clos [intro]: "\<lbrakk>comp_additive F; comp_additive G\<rbrakk> \<Longrightarrow> comp_additive (F \<sqinter> G)"
  (* nitpick *) oops

lemma comp_additive_magic [simp,intro]: "comp_additive \<top>"
  (* nitpick *) oops

lemma comp_additive_Sup_clos [intro]: "\<forall>f \<in> F. comp_additive f \<Longrightarrow> comp_additive (\<Squnion>F)"
proof (simp add: comp_additive_def, rule allI)
  fix X
  assume assm: "\<forall>f \<in> F. \<forall>X. f (\<Squnion>X) = \<Squnion>{f x |x. x \<in> X}"
  hence "(SUP f:F. f (\<Squnion>X)) = (SUP f:F. \<Squnion> {f x| x. x \<in> X})"
    by (auto intro: SUP_cong)
  also have "... = \<Squnion> {(SUP f:F. f x) | x. x \<in> X}"
    apply (auto intro!: Sup_eqI[symmetric])
    apply (rule SUP_mono)
    apply (rule_tac x=f in bexI)
    apply (rule Sup_upper)
    apply force
    apply simp
    apply (rule SUP_least)
    apply (rule Sup_least)
    apply auto
    by (metis SUP_upper dual_order.trans)
  finally show "(SUP f:F. f (\<Squnion>X)) = \<Squnion>{SUP f:F. f x |x. x \<in> X}"
    by auto
qed

text {* Type of additive predicate transformers *}

typedef 'a atran = "{F:: 'a :: bbi \<Rightarrow> 'a. comp_additive F}"
  by (rule_tac x=id in exI) (auto simp: comp_additive_def)
setup_lifting type_definition_atran

text {* Every additive predicate transformer is a monotonic one *}

lemma "\<forall>(F :: 'a :: bbi atran). \<exists>(G :: 'a mtran). Rep_mtran G = Rep_atran F"
  by transfer (auto intro: comp_add_mono)

text {* Morphism between additive to monotonic predicate transformers *}

lift_definition mptran :: "'a :: bbi atran \<Rightarrow> 'a mtran" is "\<lambda>F. F"
  by (metis comp_add_mono)

instantiation atran :: (bbi) bounded_semilattice_sup_bot
begin
lift_definition bot_atran :: "'a atran" is \<bottom> ..
lift_definition less_eq_atran:: "'a atran \<Rightarrow> 'a atran \<Rightarrow> bool" is "op \<le>" .
lift_definition less_atran :: "'a atran \<Rightarrow> 'a atran \<Rightarrow> bool" is "op <" .
lift_definition sup_atran :: "'a atran \<Rightarrow> 'a atran \<Rightarrow> 'a atran" is sup ..
instance
  by default (transfer, auto)+
end

text {* Complete additive predicate transformers form a complete join-semilattice*}

instantiation atran :: (bbi) Sup
begin
lift_definition Sup_atran :: "'a atran set \<Rightarrow> 'a atran" is Sup by auto
instance ..
end

text {*
  All complete join semilattice for a complete lattice.
  Note that meet and top are different from the complete lattice formed by ptran
*}

instantiation atran :: (bbi) complete_lattice
begin

definition "\<Sqinter>(F :: 'a atran set) \<equiv> \<Squnion>{g. \<forall>f \<in> F. g \<le> f}"
definition "\<top> :: 'a atran \<equiv> \<Sqinter>{}"
definition "(F :: 'a atran) \<sqinter> G \<equiv> \<Sqinter>{F, G}"

instance
  apply (default, simp_all add: inf_atran_def Inf_atran_def top_atran_def)
  by (transfer, auto intro: Sup_least Sup_upper Inf_greatest Inf_lower)+
end

text {*
  It forms a monoid
*}

instantiation atran :: (bbi) monoid_mult
begin
lift_definition one_atran :: "'a atran" is "id" ..
lift_definition times_atran :: "'a atran \<Rightarrow> 'a atran \<Rightarrow> 'a atran" is "op o" ..
instance
  by default (transfer, auto)+
end

text {*
  It forms a Quantale
*}

instance atran :: (bbi) near_quantale
  by default (transfer, auto)

instance atran :: (bbi) near_quantale_unital ..

instance atran :: (bbi) pre_quantale
  apply (default, transfer, drule comp_add_mono)
  apply (rule mono_qSup_subdistl)
  by simp

instance atran :: (bbi) quantale
apply default
apply transfer
apply (simp add: comp_additive_def)
apply (rule le_funI)
apply simp
apply (unfold SUP_def)
apply (erule_tac x="((\<lambda>f. f xa) ` Y)" in allE)
apply simp
apply (rule Sup_least)
apply (unfold SUP_def)
apply (rule Sup_upper)
by auto

instance atran :: (bbi) quantale_unital ..

end


(*
  File:      Probability_Misc.thy
  Authors:   Max Haslbeck, Manuel Eberl

  Miscellaneous facts about measures and probability that are missing from the library and
  should perhaps be moved there at some point.
*)
section \<open>Auxiliary material\<close>
theory Probability_Misc
  imports "HOL-Probability.Probability"
begin

lemma measure_eqI_countable_AE':
  assumes [simp]: "sets M = Pow B" "sets N = Pow B" and subset: "\<Omega> \<subseteq> B"
  assumes ae: "AE x in M. x \<in> \<Omega>" "AE x in N. x \<in> \<Omega>" and [simp]: "countable \<Omega>"
  assumes eq: "\<And>x. x \<in> \<Omega> \<Longrightarrow> emeasure M {x} = emeasure N {x}"
  shows "M = N"
proof (rule measure_eqI)
  fix A assume A: "A \<in> sets M"
  have "emeasure N A = emeasure N {x\<in>\<Omega>. x \<in> A}"
    using ae subset A by (intro emeasure_eq_AE) auto
  also have "\<dots> = (\<integral>\<^sup>+x. emeasure N {x} \<partial>count_space {x\<in>\<Omega>. x \<in> A})"
    using A subset by (intro emeasure_countable_singleton) auto
  also have "\<dots> = (\<integral>\<^sup>+x. emeasure M {x} \<partial>count_space {x\<in>\<Omega>. x \<in> A})"
    by (intro nn_integral_cong eq[symmetric]) auto
  also have "\<dots> = emeasure M {x\<in>\<Omega>. x \<in> A}"
    using A subset by (intro emeasure_countable_singleton[symmetric]) auto
  also have "\<dots> = emeasure M A"
    using ae A subset by (intro emeasure_eq_AE) auto
  finally show "emeasure M A = emeasure N A" ..
qed simp

lemma measurable_le[measurable (raw)]:
  fixes f :: "'a \<Rightarrow> 'b::{second_countable_topology, linorder_topology}"
  assumes "f \<in> borel_measurable M" "g \<in> borel_measurable M"
  shows "Measurable.pred M (\<lambda>x. f x \<le> g x)"
  unfolding pred_def by (intro borel_measurable_le assms)

lemma measurable_eq[measurable (raw)]:
  fixes f :: "'a \<Rightarrow> 'b::{second_countable_topology, linorder_topology}"
  assumes "f \<in> borel_measurable M" "g \<in> borel_measurable M"
  shows "Measurable.pred M (\<lambda>x. f x = g x)"
  unfolding pred_def by (intro borel_measurable_eq assms)

context
  fixes M :: "'a measure"
  assumes singleton_null_set: "x \<in> space M \<Longrightarrow> {x} \<in> null_sets M"
begin

lemma countable_null_set:
  assumes "countable A" "A \<subseteq> space M"
  shows   "A \<in> null_sets M"
proof -
  have "(\<Union>x\<in>A. {x}) \<in> null_sets M" using assms
    by (intro null_sets_UN' assms singleton_null_set) auto
  also have "(\<Union>x\<in>A. {x}) = A" by simp
  finally show ?thesis .
qed

lemma finite_null_set:
  assumes "finite A" "A \<subseteq> space M"
  shows   "A \<in> null_sets M"
  using countable_finite[OF assms(1)] countable_null_set[OF _ assms(2)] by simp

end

lemma measurable_inj_on_finite:
  assumes fin [measurable]: "finite I"
  assumes [measurable]: "\<And>i j. Measurable.pred (M i \<Otimes>\<^sub>M M j) (\<lambda>(x,y). x = y)"
  shows   "Measurable.pred (Pi\<^sub>M I M) (\<lambda>x. inj_on x I)" unfolding inj_on_def
  by measurable

lemma almost_everywhere_not_in_countable_set:
  assumes "countable A"
  assumes [measurable]: "Measurable.pred (M \<Otimes>\<^sub>M M) (\<lambda>(x,y). x = y)"
  assumes null: "\<And>x. x \<in> space M \<Longrightarrow> {x} \<in> null_sets M"
  shows   "AE x in M. x \<notin> A"
proof -
  have "A \<inter> space M \<in> null_sets M"
    by (rule countable_null_set) (insert assms(1), auto intro: null)
  hence "AE x in M. \<forall>y\<in>A. x \<noteq> y" by (rule AE_I') auto
  also have "?this \<longleftrightarrow> ?thesis" by (intro AE_cong) auto
  finally show ?thesis .
qed

lemma almost_everywhere_inj_on_PiM:
  assumes fin: "finite I" and prob_space: "\<And>i. i \<in> I \<Longrightarrow> prob_space (M i)"
  assumes [measurable]: "\<And>i j. Measurable.pred (M i \<Otimes>\<^sub>M M j) (\<lambda>(x,y). x = y)"
  assumes null: "\<And>i x. i \<in> I \<Longrightarrow> x \<in> space (M i) \<Longrightarrow> {x} \<in> null_sets (M i)"
  shows   "AE f in (\<Pi>\<^sub>M i\<in>I. M i). inj_on f I"
proof -
  note [measurable] = measurable_inj_on_finite
  define I' where "I' = I"
  hence "I \<subseteq> I'" by simp
  from fin and this show ?thesis
  proof (induction I rule: finite_induct)
    case (insert i I)
    interpret pair_sigma_finite "M i" "PiM I M"
      unfolding pair_sigma_finite_def using insert.prems
      by (auto intro!: prob_space_imp_sigma_finite prob_space prob_space_PiM simp: I'_def)
    from insert.hyps have [measurable]: "finite (insert i I)" by simp
    have "PiM (insert i I) M = distr (M i \<Otimes>\<^sub>M Pi\<^sub>M I M) (Pi\<^sub>M (insert i I) M) (\<lambda>(x, X). X(i := x))"
      using insert.prems
      by (intro distr_pair_PiM_eq_PiM [symmetric] prob_space) (auto simp: I'_def)
    also have "(AE f in \<dots>. inj_on f (insert i I)) \<longleftrightarrow>
                 (AE x in M i \<Otimes>\<^sub>M Pi\<^sub>M I M. inj_on ((snd x)(i := fst x)) (insert i I))"
      by (subst AE_distr_iff; measurable) (simp add: case_prod_unfold)?
    also have "\<dots> = (AE x in M i. AE y in Pi\<^sub>M I M. inj_on (y(i := x)) (insert i I))"
      by (rule AE_pair_iff [symmetric]) measurable
    also have "\<dots> \<longleftrightarrow> (AE x in M i. AE y in Pi\<^sub>M I M. inj_on (y(i := x)) I) \<and>
                      (AE x in M i. AE y in Pi\<^sub>M I M. x \<notin> y(i := x) ` (I - {i}))" by simp
    also have \<dots>
    proof (rule conjI, goal_cases)
      case 1
      from insert.prems have "AE f in Pi\<^sub>M I M. inj_on f I" by (intro insert.IH) auto
      hence "AE f in Pi\<^sub>M I M. inj_on (f(i := x)) I" for x
        by eventually_elim (insert insert.hyps, auto simp: inj_on_def)
      thus ?case by blast
    next
      note [measurable] = \<open>finite I\<close>
      {
        fix f
        have "f ` I \<inter> space (M i) \<in> null_sets (M i)"
          by (rule finite_null_set)
             (insert insert.hyps insert.prems, auto intro!: null simp: I'_def)
        hence "AE x in M i. x \<notin> f(i := x) ` I"
          by (rule AE_I') (insert insert.hyps, auto split: if_splits)
        also have "(AE x in M i. x \<notin> f(i := x) ` I) \<longleftrightarrow> (AE x in M i. \<forall>y\<in>I. f y \<noteq> x)"
          using insert.hyps by (intro AE_cong) (auto split: if_splits)
        finally have "\<dots>" .
      }
      hence "AE f in Pi\<^sub>M I M. AE x in M i. \<forall>y\<in>I. f y \<noteq> x" by blast
      hence "AE x in M i. AE f in Pi\<^sub>M I M. \<forall>y\<in>I. f y \<noteq> x"
        by (subst AE_commute) simp_all
      also have "?this \<longleftrightarrow> (AE x in M i. AE y in Pi\<^sub>M I M. x \<notin> y(i := x) ` (I - {i}))"
        using insert.hyps by (intro AE_cong) (auto split: if_splits)
      finally show \<dots> .
    qed
    finally show ?case .
  qed auto
qed

lemma null_sets_uniform_measure:
  assumes "A \<in> sets M" "emeasure M A \<noteq> \<infinity>"
  shows   "null_sets (uniform_measure M A) = (\<lambda>B. A \<inter> B) -` null_sets M \<inter> sets M"
  using assms by (auto simp: null_sets_def)

lemma almost_everywhere_avoid_finite:
  assumes fin: "finite I"
  shows   "AE f in (\<Pi>\<^sub>M i\<in>I. uniform_measure lborel {(0::real)..1}). inj_on f I"
proof (intro almost_everywhere_inj_on_PiM fin prob_space_uniform_measure)
  fix x :: real
  show "{x} \<in> null_sets (uniform_measure lborel {0..1})"
    by (cases "x \<in> {0..1}") (auto simp: null_sets_uniform_measure)
qed auto

lemma almost_everywhere_avoid_countable:
  assumes "countable A"
  shows   "AE x in uniform_measure lborel {(0::real)..1}. x \<notin> A"
proof (intro almost_everywhere_not_in_countable_set assms prob_space_uniform_measure)
  fix x :: real
  show "{x} \<in> null_sets (uniform_measure lborel {0..1})"
    by (cases "x \<in> {0..1}") (auto simp: null_sets_uniform_measure)
qed auto

lemma measure_pmf_of_set:
  assumes "A \<noteq> {}" and "finite A"
  shows   "measure_pmf (pmf_of_set A) = uniform_measure (count_space UNIV) A"
    using assms
  by (intro measure_eqI)
     (auto simp: emeasure_pmf_of_set divide_ennreal [symmetric] card_gt_0_iff
                  ennreal_of_nat_eq_real_of_nat)

lemma emeasure_distr_restrict:
  assumes "f \<in> M \<rightarrow>\<^sub>M N" "f \<in> M' \<rightarrow>\<^sub>M N'" "A \<in> sets N'" "sets M' \<subseteq> sets M" "sets N' \<subseteq> sets N"
  assumes "\<And>X. X \<in> sets M' \<Longrightarrow> emeasure M X = emeasure M' X"
  assumes "\<And>X. X \<in> sets M \<Longrightarrow> X \<subseteq> space M - space M' \<Longrightarrow> emeasure M X = 0"
  shows   "emeasure (distr M N f) A= emeasure (distr M' N' f) A"
proof -
  have space_subset: "space M' \<subseteq> space M"
    using \<open>sets M' \<subseteq> sets M\<close> by (simp add: sets_le_imp_space_le)
  have "emeasure (distr M N f) A = emeasure M (f -` A \<inter> space M)"
    using assms by (subst emeasure_distr) auto
  also have "f -` A \<inter> space M = f -` A \<inter> space M' \<union> f -` A \<inter> (space M - space M')"
    using space_subset by blast
  also have "emeasure M \<dots> = emeasure M (f -` A \<inter> space M')"
  proof (intro emeasure_Un_null_set)
    show "f -` A \<inter> space M' \<in> sets M"
      using assms by auto
    have "f -` A \<inter> (space M - space M') \<in> sets M"
      using assms by (metis Int_Diff measurable_sets sets.Diff sets.top subsetCE)
    moreover from this have "emeasure M (f -` A \<inter> (space M - space M')) = 0"
      by (intro assms) auto
    ultimately show "f -` A \<inter> (space M - space M') \<in> null_sets M"
      unfolding null_sets_def by blast
  qed
  also have "\<dots> = emeasure M' (f -` A \<inter> space M')"
    using assms by (intro assms) auto
  also have "\<dots> = emeasure (distr M' N' f) A"
    using assms by (subst emeasure_distr) auto
  finally show ?thesis .
qed

lemma distr_uniform_measure_count_space_inj:
  assumes "inj_on f A'" "A' \<subseteq> A" "f ` A \<subseteq> B" "finite A'"
  shows   "distr (uniform_measure (count_space A) A') (count_space B) f =
             uniform_measure (count_space B) (f ` A')" (is "?lhs = ?rhs")
proof (rule measure_eqI, goal_cases)
  case (2 X)
  hence X_subset: "X \<subseteq> B" by simp
  from assms have eq: "f ` A' \<inter> X = f ` (A' \<inter> (f -` X \<inter> A))"
    by auto
  from assms have [measurable]: "f \<in> count_space A \<rightarrow>\<^sub>M count_space B"
    by (subst measurable_count_space_eq1) auto
  from X_subset have "emeasure ?lhs X =
                        emeasure (uniform_measure (count_space A) A') (f -` X \<inter> A)"
    by (subst emeasure_distr) auto
  also from assms X_subset
    have "\<dots> = emeasure (count_space A) (A' \<inter> (f -` X \<inter> A)) / emeasure (count_space A) A'"
    by (intro emeasure_uniform_measure) auto
  also from assms have "\<dots> = of_nat (card (A' \<inter> (f -` X \<inter> A))) / of_nat (card A')"
    by (subst (1 2) emeasure_count_space) auto
  also have "card (A' \<inter> (f -` X \<inter> A)) = card (f ` (A' \<inter> (f -` X \<inter> A)))"
    using assms by (intro card_image [symmetric]) (auto simp: inj_on_def)
  also have "f ` (A' \<inter> (f -` X \<inter> A)) = f ` A' \<inter> X"
    using assms by auto
  also have "of_nat (card A') = of_nat (card (f ` A'))"
    using assms by (subst card_image) auto
  also have "of_nat (card (f ` A' \<inter> X)) / \<dots> =
               emeasure (count_space B) (f ` A' \<inter> X) / emeasure (count_space B) (f ` A')"
    using assms by (subst (1 2) emeasure_count_space) auto
  also from assms X_subset have "\<dots> = emeasure ?rhs X"
    by (intro emeasure_uniform_measure [symmetric]) auto
  finally show ?case .
qed simp_all

lemma (in pair_prob_space) pair_measure_bind:
  assumes [measurable]: "f \<in> M1 \<Otimes>\<^sub>M M2 \<rightarrow>\<^sub>M subprob_algebra N"
  shows "(M1 \<Otimes>\<^sub>M M2) \<bind> f = do {x \<leftarrow> M1; y \<leftarrow> M2; f (x, y)}"
proof -
  note M1 = M1.prob_space_axioms and M2 = M2.prob_space_axioms
  have [measurable]: "M1 \<in> space (subprob_algebra M1)"
    by (rule M1.M_in_subprob)
  have [measurable]: "M2 \<in> space (subprob_algebra M2)"
    by (rule M2.M_in_subprob)
  have "(M1 \<Otimes>\<^sub>M M2) = M1 \<bind> (\<lambda>x. M2 \<bind> (\<lambda>y. return (M1 \<Otimes>\<^sub>M M2) (x, y)))"
    by (subst pair_measure_eq_bind) simp_all
  also have "\<dots> \<bind> f = M1 \<bind> (\<lambda>x. (M2 \<bind> (\<lambda>y. return (M1 \<Otimes>\<^sub>M M2) (x, y))) \<bind> f)"
    by (rule bind_assoc) measurable
  also have "\<dots> = M1 \<bind> (\<lambda>x. M2 \<bind> (\<lambda>xa. return (M1 \<Otimes>\<^sub>M M2) (x, xa) \<bind> f))"
    by (intro bind_cong refl bind_assoc) measurable
  also have "\<dots> = do {x \<leftarrow> M1; y \<leftarrow> M2; f (x, y)}"
    by (intro bind_cong refl bind_return)
       (measurable, simp_all add: space_pair_measure)
  finally show ?thesis .
qed

lemma count_space_singleton_conv_return:
  "count_space {x} = return (count_space {x}) x"
proof (rule measure_eqI)
  fix A assume "A \<in> sets (count_space {x})"
  hence "A \<subseteq> {x}" by auto
  hence "A = {} \<or> A = {x}" by (cases "x \<in> A") auto
  thus "emeasure (count_space {x}) A = emeasure (return (count_space {x}) x) A"
    by auto
qed auto

lemma distr_count_space_singleton [simp]:
    "f x \<in> space M \<Longrightarrow> distr (count_space {x}) M f = return M (f x)"
  by (subst count_space_singleton_conv_return, subst distr_return) simp_all

lemma uniform_measure_count_space_singleton [simp]:
  assumes "{x} \<in> sets M" "emeasure M {x} \<noteq> 0" "emeasure M {x} < \<infinity>"
  shows   "uniform_measure M {x} = return M x"
proof (rule measure_eqI)
  fix A assume A: "A \<in> sets (uniform_measure M {x})"
  show "emeasure (uniform_measure M {x}) A = emeasure (return M x) A"
    by (cases "x \<in> A") (insert assms A, auto)
qed simp_all

lemma PiM_uniform_measure_permute:
  fixes a b :: real
  assumes "g permutes A" "a < b"
  shows   "distr (PiM A (\<lambda>_. uniform_measure lborel {a..b})) (PiM A (\<lambda>_. lborel)) (\<lambda>f. f \<circ> g) =
             PiM A (\<lambda>_. uniform_measure lborel {a..b})"
proof -
  have "distr (PiM A (\<lambda>_. uniform_measure lborel {a..b})) (PiM A (\<lambda>_. lborel)) (\<lambda>f. f \<circ> g) =
          distr (PiM A (\<lambda>_. uniform_measure lborel {a..b}))
            (PiM A (\<lambda>_. uniform_measure lborel {a..b})) (\<lambda>f. \<lambda>x\<in>A. f (g x))" using assms
    by (intro distr_cong sets_PiM_cong refl)
       (auto simp: fun_eq_iff space_PiM PiE_def extensional_def permutes_in_image[of g A])
  also from assms have "\<dots> = Pi\<^sub>M A (\<lambda>i. uniform_measure lborel {a..b})"
    by (intro distr_PiM_reindex)
       (auto simp: permutes_inj_on permutes_in_image[of g A] intro!: prob_space_uniform_measure)
  finally show ?thesis .
qed

lemma ennreal_fact [simp]: "ennreal (fact n) = fact n"
  by (induction n) (auto simp: algebra_simps ennreal_mult' ennreal_of_nat_eq_real_of_nat)

lemma inverse_ennreal_unique:
  assumes "a * (b :: ennreal) = 1"
  shows   "b = inverse a"
  using assms
  by (metis divide_ennreal_def ennreal_inverse_1 ennreal_top_eq_mult_iff mult.comm_neutral
        mult_divide_eq_ennreal mult_eq_0_iff semiring_normalization_rules(7))

end


(*  Title:      HOL/BNF_Def.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2012, 2013, 2014

Definition of bounded natural functors.
*)

section \<open>Definition of Bounded Natural Functors\<close>

theory BNF_Def
imports BNF_Cardinal_Arithmetic Fun_Def_Base
keywords
  "print_bnfs" :: diag and
  "bnf" :: thy_goal
begin

lemma Collect_case_prodD: "x \<in> Collect (case_prod A) \<Longrightarrow> A (fst x) (snd x)"
  by auto

inductive
   rel_sum :: "('a \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> 'a + 'b \<Rightarrow> 'c + 'd \<Rightarrow> bool" for R1 R2
where
  "R1 a c \<Longrightarrow> rel_sum R1 R2 (Inl a) (Inl c)"
| "R2 b d \<Longrightarrow> rel_sum R1 R2 (Inr b) (Inr d)"

definition
  rel_fun :: "('a \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('c \<Rightarrow> 'd) \<Rightarrow> bool"
where
  "rel_fun A B = (\<lambda>f g. \<forall>x y. A x y \<longrightarrow> B (f x) (g y))"

lemma rel_funI [intro]:
  assumes "\<And>x y. A x y \<Longrightarrow> B (f x) (g y)"
  shows "rel_fun A B f g"
  using assms by (simp add: rel_fun_def)

lemma rel_funD:
  assumes "rel_fun A B f g" and "A x y"
  shows "B (f x) (g y)"
  using assms by (simp add: rel_fun_def)

lemma rel_fun_mono:
  "\<lbrakk> rel_fun X A f g; \<And>x y. Y x y \<longrightarrow> X x y; \<And>x y. A x y \<Longrightarrow> B x y \<rbrakk> \<Longrightarrow> rel_fun Y B f g"
by(simp add: rel_fun_def)

lemma rel_fun_mono' [mono]:
  "\<lbrakk> \<And>x y. Y x y \<longrightarrow> X x y; \<And>x y. A x y \<longrightarrow> B x y \<rbrakk> \<Longrightarrow> rel_fun X A f g \<longrightarrow> rel_fun Y B f g"
by(simp add: rel_fun_def)

definition rel_set :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> bool"
  where "rel_set R = (\<lambda>A B. (\<forall>x\<in>A. \<exists>y\<in>B. R x y) \<and> (\<forall>y\<in>B. \<exists>x\<in>A. R x y))"

lemma rel_setI:
  assumes "\<And>x. x \<in> A \<Longrightarrow> \<exists>y\<in>B. R x y"
  assumes "\<And>y. y \<in> B \<Longrightarrow> \<exists>x\<in>A. R x y"
  shows "rel_set R A B"
  using assms unfolding rel_set_def by simp

lemma predicate2_transferD:
   "\<lbrakk>rel_fun R1 (rel_fun R2 (op =)) P Q; a \<in> A; b \<in> B; A \<subseteq> {(x, y). R1 x y}; B \<subseteq> {(x, y). R2 x y}\<rbrakk> \<Longrightarrow>
   P (fst a) (fst b) \<longleftrightarrow> Q (snd a) (snd b)"
  unfolding rel_fun_def by (blast dest!: Collect_case_prodD)

definition collect where
  "collect F x = (\<Union>f \<in> F. f x)"

lemma fstI: "x = (y, z) \<Longrightarrow> fst x = y"
  by simp

lemma sndI: "x = (y, z) \<Longrightarrow> snd x = z"
  by simp

lemma bijI': "\<lbrakk>\<And>x y. (f x = f y) = (x = y); \<And>y. \<exists>x. y = f x\<rbrakk> \<Longrightarrow> bij f"
  unfolding bij_def inj_on_def by auto blast

(* Operator: *)
definition "Gr A f = {(a, f a) | a. a \<in> A}"

definition "Grp A f = (\<lambda>a b. b = f a \<and> a \<in> A)"

definition vimage2p where
  "vimage2p f g R = (\<lambda>x y. R (f x) (g y))"

lemma collect_comp: "collect F \<circ> g = collect ((\<lambda>f. f \<circ> g) ` F)"
  by (rule ext) (auto simp only: comp_apply collect_def)

definition convol ("\<langle>(_,/ _)\<rangle>") where
  "\<langle>f, g\<rangle> \<equiv> \<lambda>a. (f a, g a)"

lemma fst_convol: "fst \<circ> \<langle>f, g\<rangle> = f"
  apply(rule ext)
  unfolding convol_def by simp

lemma snd_convol: "snd \<circ> \<langle>f, g\<rangle> = g"
  apply(rule ext)
  unfolding convol_def by simp

lemma convol_mem_GrpI:
  "x \<in> A \<Longrightarrow> \<langle>id, g\<rangle> x \<in> (Collect (case_prod (Grp A g)))"
  unfolding convol_def Grp_def by auto

definition csquare where
  "csquare A f1 f2 p1 p2 \<longleftrightarrow> (\<forall> a \<in> A. f1 (p1 a) = f2 (p2 a))"

lemma eq_alt: "op = = Grp UNIV id"
  unfolding Grp_def by auto

lemma leq_conversepI: "R = op = \<Longrightarrow> R \<le> R^--1"
  by auto

lemma leq_OOI: "R = op = \<Longrightarrow> R \<le> R OO R"
  by auto

lemma OO_Grp_alt: "(Grp A f)^--1 OO Grp A g = (\<lambda>x y. \<exists>z. z \<in> A \<and> f z = x \<and> g z = y)"
  unfolding Grp_def by auto

lemma Grp_UNIV_id: "f = id \<Longrightarrow> (Grp UNIV f)^--1 OO Grp UNIV f = Grp UNIV f"
  unfolding Grp_def by auto

lemma Grp_UNIV_idI: "x = y \<Longrightarrow> Grp UNIV id x y"
  unfolding Grp_def by auto

lemma Grp_mono: "A \<le> B \<Longrightarrow> Grp A f \<le> Grp B f"
  unfolding Grp_def by auto

lemma GrpI: "\<lbrakk>f x = y; x \<in> A\<rbrakk> \<Longrightarrow> Grp A f x y"
  unfolding Grp_def by auto

lemma GrpE: "Grp A f x y \<Longrightarrow> (\<lbrakk>f x = y; x \<in> A\<rbrakk> \<Longrightarrow> R) \<Longrightarrow> R"
  unfolding Grp_def by auto

lemma Collect_case_prod_Grp_eqD: "z \<in> Collect (case_prod (Grp A f)) \<Longrightarrow> (f \<circ> fst) z = snd z"
  unfolding Grp_def comp_def by auto

lemma Collect_case_prod_Grp_in: "z \<in> Collect (case_prod (Grp A f)) \<Longrightarrow> fst z \<in> A"
  unfolding Grp_def comp_def by auto

definition "pick_middlep P Q a c = (SOME b. P a b \<and> Q b c)"

lemma pick_middlep:
  "(P OO Q) a c \<Longrightarrow> P a (pick_middlep P Q a c) \<and> Q (pick_middlep P Q a c) c"
  unfolding pick_middlep_def apply(rule someI_ex) by auto

definition fstOp where
  "fstOp P Q ac = (fst ac, pick_middlep P Q (fst ac) (snd ac))"

definition sndOp where
  "sndOp P Q ac = (pick_middlep P Q (fst ac) (snd ac), (snd ac))"

lemma fstOp_in: "ac \<in> Collect (case_prod (P OO Q)) \<Longrightarrow> fstOp P Q ac \<in> Collect (case_prod P)"
  unfolding fstOp_def mem_Collect_eq
  by (subst (asm) surjective_pairing, unfold prod.case) (erule pick_middlep[THEN conjunct1])

lemma fst_fstOp: "fst bc = (fst \<circ> fstOp P Q) bc"
  unfolding comp_def fstOp_def by simp

lemma snd_sndOp: "snd bc = (snd \<circ> sndOp P Q) bc"
  unfolding comp_def sndOp_def by simp

lemma sndOp_in: "ac \<in> Collect (case_prod (P OO Q)) \<Longrightarrow> sndOp P Q ac \<in> Collect (case_prod Q)"
  unfolding sndOp_def mem_Collect_eq
  by (subst (asm) surjective_pairing, unfold prod.case) (erule pick_middlep[THEN conjunct2])

lemma csquare_fstOp_sndOp:
  "csquare (Collect (f (P OO Q))) snd fst (fstOp P Q) (sndOp P Q)"
  unfolding csquare_def fstOp_def sndOp_def using pick_middlep by simp

lemma snd_fst_flip: "snd xy = (fst \<circ> (%(x, y). (y, x))) xy"
  by (simp split: prod.split)

lemma fst_snd_flip: "fst xy = (snd \<circ> (%(x, y). (y, x))) xy"
  by (simp split: prod.split)

lemma flip_pred: "A \<subseteq> Collect (case_prod (R ^--1)) \<Longrightarrow> (%(x, y). (y, x)) ` A \<subseteq> Collect (case_prod R)"
  by auto

lemma predicate2_eqD: "A = B \<Longrightarrow> A a b \<longleftrightarrow> B a b"
  by simp

lemma case_sum_o_inj: "case_sum f g \<circ> Inl = f" "case_sum f g \<circ> Inr = g"
  by auto

lemma map_sum_o_inj: "map_sum f g o Inl = Inl o f" "map_sum f g o Inr = Inr o g"
  by auto

lemma card_order_csum_cone_cexp_def:
  "card_order r \<Longrightarrow> ( |A1| +c cone) ^c r = |Func UNIV (Inl ` A1 \<union> {Inr ()})|"
  unfolding cexp_def cone_def Field_csum Field_card_of by (auto dest: Field_card_order)

lemma If_the_inv_into_in_Func:
  "\<lbrakk>inj_on g C; C \<subseteq> B \<union> {x}\<rbrakk> \<Longrightarrow>
   (\<lambda>i. if i \<in> g ` C then the_inv_into C g i else x) \<in> Func UNIV (B \<union> {x})"
  unfolding Func_def by (auto dest: the_inv_into_into)

lemma If_the_inv_into_f_f:
  "\<lbrakk>i \<in> C; inj_on g C\<rbrakk> \<Longrightarrow> ((\<lambda>i. if i \<in> g ` C then the_inv_into C g i else x) \<circ> g) i = id i"
  unfolding Func_def by (auto elim: the_inv_into_f_f)

lemma the_inv_f_o_f_id: "inj f \<Longrightarrow> (the_inv f \<circ> f) z = id z"
  by (simp add: the_inv_f_f)

lemma vimage2pI: "R (f x) (g y) \<Longrightarrow> vimage2p f g R x y"
  unfolding vimage2p_def .

lemma rel_fun_iff_leq_vimage2p: "(rel_fun R S) f g = (R \<le> vimage2p f g S)"
  unfolding rel_fun_def vimage2p_def by auto

lemma convol_image_vimage2p: "\<langle>f \<circ> fst, g \<circ> snd\<rangle> ` Collect (case_prod (vimage2p f g R)) \<subseteq> Collect (case_prod R)"
  unfolding vimage2p_def convol_def by auto

lemma vimage2p_Grp: "vimage2p f g P = Grp UNIV f OO P OO (Grp UNIV g)\<inverse>\<inverse>"
  unfolding vimage2p_def Grp_def by auto

lemma subst_Pair: "P x y \<Longrightarrow> a = (x, y) \<Longrightarrow> P (fst a) (snd a)"
  by simp

lemma comp_apply_eq: "f (g x) = h (k x) \<Longrightarrow> (f \<circ> g) x = (h \<circ> k) x"
  unfolding comp_apply by assumption

lemma refl_ge_eq: "(\<And>x. R x x) \<Longrightarrow> op = \<le> R"
  by auto

lemma ge_eq_refl: "op = \<le> R \<Longrightarrow> R x x"
  by auto

lemma reflp_eq: "reflp R = (op = \<le> R)"
  by (auto simp: reflp_def fun_eq_iff)

lemma transp_relcompp: "transp r \<longleftrightarrow> r OO r \<le> r"
  by (auto simp: transp_def)

lemma symp_conversep: "symp R = (R\<inverse>\<inverse> \<le> R)"
  by (auto simp: symp_def fun_eq_iff)

lemma diag_imp_eq_le: "(\<And>x. x \<in> A \<Longrightarrow> R x x) \<Longrightarrow> \<forall>x y. x \<in> A \<longrightarrow> y \<in> A \<longrightarrow> x = y \<longrightarrow> R x y"
  by blast

definition eq_onp :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
  where "eq_onp R = (\<lambda>x y. R x \<and> x = y)"

lemma eq_onp_Grp: "eq_onp P = BNF_Def.Grp (Collect P) id"
  unfolding eq_onp_def Grp_def by auto

lemma eq_onp_to_eq: "eq_onp P x y \<Longrightarrow> x = y"
  by (simp add: eq_onp_def)

lemma eq_onp_top_eq_eq: "eq_onp top = op ="
  by (simp add: eq_onp_def)

lemma eq_onp_same_args: "eq_onp P x x = P x"
  by (auto simp add: eq_onp_def)

lemma eq_onp_eqD: "eq_onp P = Q \<Longrightarrow> P x = Q x x"
  unfolding eq_onp_def by blast

lemma Ball_Collect: "Ball A P = (A \<subseteq> (Collect P))"
  by auto

lemma eq_onp_mono0: "\<forall>x\<in>A. P x \<longrightarrow> Q x \<Longrightarrow> \<forall>x\<in>A. \<forall>y\<in>A. eq_onp P x y \<longrightarrow> eq_onp Q x y"
  unfolding eq_onp_def by auto

lemma eq_onp_True: "eq_onp (\<lambda>_. True) = (op =)"
  unfolding eq_onp_def by simp

lemma Ball_image_comp: "Ball (f ` A) g = Ball A (g o f)"
  by auto

lemma rel_fun_Collect_case_prodD:
  "rel_fun A B f g \<Longrightarrow> X \<subseteq> Collect (case_prod A) \<Longrightarrow> x \<in> X \<Longrightarrow> B ((f o fst) x) ((g o snd) x)"
  unfolding rel_fun_def by auto

lemma eq_onp_mono_iff: "eq_onp P \<le> eq_onp Q \<longleftrightarrow> P \<le> Q"
  unfolding eq_onp_def by auto

ML_file "Tools/BNF/bnf_util.ML"
ML_file "Tools/BNF/bnf_tactics.ML"
ML_file "Tools/BNF/bnf_def_tactics.ML"
ML_file "Tools/BNF/bnf_def.ML"

end