theory Semantics
  imports "../Algebra/PartialMonoid" "../Algebra/BBI"
begin

section {* Notation and types *}

no_notation pmult (infixl "*" 80)
  and times (infixl "*" 70)
  and Set.image (infixr "`" 90)
  and sup (infixl "+" 65)
  and pmult_one ("1")
  and bot ("\<bottom>")
  and sep_impl (infix "-*" 55)

type_synonym heap = "nat \<Rightarrow> nat option"
type_synonym 'a state = "'a \<times> heap"
type_synonym 'a stateT = "'a state \<Rightarrow> 'a state"
type_synonym 'a pred = "'a state \<Rightarrow> bool"
type_synonym 'a state_predT = "'a state \<Rightarrow> 'a pred"
type_synonym 'a predT = "'a pred \<Rightarrow> 'a pred"

section {* Heap *}

definition ortho :: "heap \<Rightarrow> heap \<Rightarrow> bool" (infix "\<bottom>" 55)
  where "h1 \<bottom> h2 \<equiv> dom h1 \<inter> dom h2 = {}"

lemma theI: "h x = Some y \<Longrightarrow> the (h x) = y"
  by simp

lemma heap_divider: "h1 \<bottom> h2 \<Longrightarrow> h1 x = Some y \<Longrightarrow> (h1 ++ h2) x = Some y"
  by (auto simp: ortho_def map_add_def split: option.splits)

lemma heap_add_comm: "h1 \<bottom> h2 \<Longrightarrow> h1 ++ h2 = h2 ++ h1"
  by (auto simp: ortho_def intro: map_add_comm)

(* should write this directly on ML *)
definition heap_update :: "nat \<Rightarrow> nat \<Rightarrow> heap \<Rightarrow> heap" where
  "heap_update p q h \<equiv> h (p\<mapsto>q)"
declare heap_update_def[simp]

interpretation partial_comm_monoid map_add ortho Map.empty
  by default (auto simp: ortho_def intro: map_add_comm)

section {* Predicates *}

definition emp :: "'a pred" where "emp \<equiv> \<lambda>(s, h). h = Map.empty"

definition sep_conj :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a pred" (infixl "*" 75) where
  "P * Q \<equiv> \<lambda>(s, h). \<Squnion> {P (s, h1) \<and> Q (s, h2) | h1 h2. h = h1 ++ h2 \<and> ortho h1 h2}"

lemma sep_conj_eq: "(P * Q) (s, h) = (\<exists>h1 h2. h = h1++h2 \<and> (ortho h1 h2) \<and> P (s, h1) \<and> Q (s, h2))"
  by (auto simp: sep_conj_def)

lemma sep_conj_eq2: "(P * Q) = (\<lambda>(s, h). (\<exists>h1 h2. h = h1++h2 \<and> (ortho h1 h2) \<and> P (s, h1) \<and> Q (s, h2)))"
  by (auto simp: sep_conj_def)

abbreviation (input)
  pred_ex :: "('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" (binder "EXS " 10) where
  "EXS x. P x \<equiv> \<lambda>s. \<exists>x. P x s"

abbreviation (input)
  pred_all :: "('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" (binder "ALLS " 10) where
  "ALLS x. P x \<equiv> \<lambda>s. \<forall>x. P x s"

abbreviation true :: "'a pred" where "true \<equiv> top"
abbreviation false :: "'a pred" where "false \<equiv> bot"

(* Algebraic structure *)
interpretation comm_monoid_mult sep_conj emp
  apply default
  apply (auto simp add: emp_def sep_conj_def ortho_def intro!: ext)
  apply (rule_tac x=h1a in exI, simp)
  apply (rule_tac x="h2a ++ h2" in exI, auto)
  apply (rule_tac x=h2a in exI, auto)
  apply (rule_tac x="h1 ++ h1a" in exI, auto)
  apply (rule_tac x=h2a in exI, auto)
  by (auto intro: map_add_comm)

interpretation quantale_Sup Inf Sup inf less_eq less sup bot top sep_conj
  by default (auto simp: sep_conj_def)

interpretation bbi Inf Sup inf less_eq less sup bot top minus uminus sep_conj emp
  by default (auto simp: sep_conj_def emp_def)

abbreviation magic_wand :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a pred" (infix "-*" 55) where
  "P -* Q \<equiv> sep_impl P Q"

lemma magic_wand: "(P -* Q) = (\<lambda>(s, h). (\<forall>h'. h' \<bottom> h \<and> P (s, h') \<longrightarrow> Q(s, h ++ h')))"
  oops

(* Predicates about heaps *)
definition is_singleton :: "nat \<Rightarrow> nat \<Rightarrow> heap \<Rightarrow> bool" where
  "is_singleton e t h \<equiv> h = [e \<mapsto> t]"

definition ex_singleton :: "nat \<Rightarrow> heap \<Rightarrow> bool" where
  "ex_singleton e h \<equiv> \<exists>t. is_singleton e t h"

primrec is_heap_list :: "nat \<Rightarrow> nat list \<Rightarrow> 'a pred" where
  "is_heap_list e [] = emp"
| "is_heap_list e (t#ts) = (\<lambda>(s, h). is_singleton e t h) * is_heap_list (Suc e) ts"

section {* Predicate Transformers *}

(* Algebraic Structure *)
interpretation PT: monoid "op o" id
  by default auto

interpretation PT: near_quantale_Sup Inf Sup inf less_eq less sup bot "top :: 'a predT" "op o"
  by default auto

interpretation PT: near_quantale_Sup_unital id "op o" Inf Sup inf less_eq less sup bot "top :: 'a predT"
  by default auto

interpretation PT: pre_quantale_Sup Inf Sup inf less_eq less sup bot "top :: 'a predT" "op o"
  (* nitpick *) oops

interpretation PT: quantale_Sup_unital id "op o" Inf Sup inf less_eq less sup bot top
  (* nitpick *) oops

interpretation PT: complete_distrib_lattice Inf Sup inf less_eq less sup bot "top :: 'a predT" ..

section {* Lifting between types *}

definition lift_stateT_pred :: "'a stateT \<Rightarrow> 'a state_predT" where
  "lift_stateT_pred f \<equiv> \<lambda>\<sigma> \<sigma>'. \<sigma>' = f \<sigma>"

definition lift_state_pred_predT :: "'a state_predT \<Rightarrow> 'a predT" where
  "lift_state_pred_predT F \<equiv> \<lambda>Q \<sigma>. F \<sigma> \<le> Q"

definition lift_state_a_stateT :: "('a state \<Rightarrow> 'a) \<Rightarrow> 'a stateT" where
  "lift_state_a_stateT F \<equiv> \<lambda>(s, h). (F (s, h), h)"

definition lift_state_heap_stateT :: "('a state \<Rightarrow> heap) \<Rightarrow> 'a stateT" where
  "lift_state_heap_stateT F \<equiv> \<lambda>(s, h). (s, F (s, h))"

definition lift_state_heap_pair :: "('a state \<Rightarrow> 'a) \<Rightarrow> ('a state \<Rightarrow> heap) \<Rightarrow> 'a stateT" where
  "lift_state_heap_pair F G \<equiv> \<lambda>(s, h). (F (s, h), G(s, h))"

definition lift_stateT_predT :: "'a stateT \<Rightarrow> 'a predT" ("<_>") where
  "<f> \<equiv> \<lambda>Q. Q o f"

definition lift_state_a_predT :: "('a state \<Rightarrow> 'a) \<Rightarrow> 'a predT" where
  "lift_state_a_predT F \<equiv> < lift_state_a_stateT F >"

definition lift_state_heap_predT :: "('a state \<Rightarrow> heap) \<Rightarrow> 'a predT" where
  "lift_state_heap_predT F \<equiv> < lift_state_heap_stateT F >"

definition lift_pred_predT :: "'a pred \<Rightarrow> 'a predT" ("\<lceil>_\<rceil>") where
  "\<lceil>P\<rceil> \<equiv> \<lambda>Q. - P \<squnion> Q"

declare lift_state_a_predT_def [simp]
  lift_state_heap_predT_def [simp]
  lift_stateT_predT_def [simp]
  lift_state_a_stateT_def [simp]
  lift_state_heap_stateT_def [simp]
  lift_pred_predT_def [simp]

section {* Simple while language with pointers *}

abbreviation skip :: "'a predT" ("skip") where "skip \<equiv> id"

notation comp (infixl ";" 60)

definition pow :: "'a predT \<Rightarrow> nat \<Rightarrow> 'a predT" where
  "pow F i \<equiv> PT.Sup.qpower F i"

definition iteration :: "'a predT \<Rightarrow> 'a predT" ("_\<^sup>\<star>" [101] 100) where
  "F\<^sup>\<star> \<equiv> \<Sqinter> {y. \<exists>i. y = pow F i}"

definition if_comm :: "'a pred \<Rightarrow> 'a predT \<Rightarrow> 'a predT \<Rightarrow> 'a predT" where
  "if_comm p x y = (\<lceil>p\<rceil>;x) \<sqinter> (\<lceil>-p\<rceil>;y)"

definition while_comm :: "'a pred \<Rightarrow> 'a predT \<Rightarrow> 'a predT" where
  "while_comm p x = (\<lceil>p\<rceil>;x)\<^sup>\<star>;\<lceil>-p\<rceil>"

definition while_inv_comm :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a predT \<Rightarrow> 'a predT" where
  "while_inv_comm p i x = (\<lceil>p\<rceil>;x)\<^sup>\<star>;\<lceil>-p\<rceil>"

definition stable_var :: "(('b \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
  "stable_var v_update v \<longleftrightarrow> (\<forall>s n. v (v_update (\<lambda>_. n) s) = n)"

definition new_comm :: "(('b \<Rightarrow> nat) \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a stateT" where
  "new_comm v a \<equiv> \<lambda>(s, h). let N = (SOME n. \<forall>x \<in> dom h. n > x) in
      (v (\<lambda>_. N) s, h(N \<mapsto> a))"

definition dispose_comm :: "nat \<Rightarrow> heap \<Rightarrow> heap" where
  "dispose_comm e h \<equiv> h (e := None)"

syntax
  "_quote" :: "'b \<Rightarrow> ('a \<Rightarrow> 'b)" ("(\<lbrace>_\<rbrace>)" [0] 1000)       (* Create assertion applying antiquotes *)
  "_antiquote_s" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a" ("`_" [1000] 1000) (* Apply store *)
  "_antiquote_to_h" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a" ("@_" [1000] 1000) (* Apply to heap *)
  "_antiquote_h" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a" ("|_|" [1000] 1000) (* Apply heap *)
  "_assign" :: "idt \<Rightarrow> 'b \<Rightarrow> 'a predT" ("(`_ :=/ _)" [70, 65] 61)
  "_cons" :: "idt \<Rightarrow> 'b \<Rightarrow> 'a predT" ("(`_ :=/ cons _)" [70, 65] 61)
  "_mutation" :: "'b \<Rightarrow> 'b \<Rightarrow> 'a predT" ("(@_ :=/ _)" [70, 65] 61)
  "_dispose" :: "nat \<Rightarrow> 'a predT" ("dispose _" [65] 61)
  "_subst" :: "'a pred \<Rightarrow> 'b \<Rightarrow> idt \<Rightarrow> 'a pred" ("_[_'/`_]" [1000] 999)
  "_if" :: "'a pred \<Rightarrow> 'a predT \<Rightarrow> 'a predT \<Rightarrow> 'a predT" ("(0if _//then _//else _//fi)" [0,0,0] 61)
  "_if_skip" :: "'a pred \<Rightarrow> 'a predT \<Rightarrow> 'a predT" ("(0if _//then _//fi)" [0,0] 61)
  "_while" :: "'a pred \<Rightarrow> 'a predT \<Rightarrow> 'a predT" ("(0while  _//do _//od)" [0, 0] 61)
  "_while_inv" :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a predT \<Rightarrow> 'a predT" ("(0while _//inv _//do _//od)" [0, 0, 0] 61)

ML_file "while_syntax.ML"

parse_translation {*
  [(@{syntax_const "_quote"}, K quote_tr'),
    (@{syntax_const "_subst"}, K subst_tr),
    (@{syntax_const "_assign"}, K assign_tr),
    (@{syntax_const "_cons"}, K cons_tr),
    (@{syntax_const "_mutation"}, K mutation_tr),
    (@{syntax_const "_dispose"}, K dispose_tr),
    (@{syntax_const "_if"}, K if_tr),
    (@{syntax_const "_while"}, K while_tr),
    (@{syntax_const "_while_inv"}, K while_inv_tr)]
*}

translations
  "if b then x fi" == "if b then x else skip fi"

(* Syntactic sugar of predicates about heap *)
syntax
  "_is_singl" :: "nat \<Rightarrow> nat \<Rightarrow> bool" ("_ \<mapsto> _" [56,51] 56)
  "_ex_singleton" :: "nat \<Rightarrow> bool" ("_ \<mapsto> -" [56] 56)
  "_is_heap_list" :: "nat \<Rightarrow> nat \<Rightarrow> bool" ("_ [\<mapsto>] _" [56,51] 56)

translations
  "i \<mapsto> j" == "|(CONST is_singleton i j)|"
  "i \<mapsto> -" == "|(CONST ex_singleton i)|"
  "x [\<mapsto>] xs" == "|(`(CONST curry (CONST is_heap_list x xs)))|"

section {* Monotonicity *}

text {* All the constructs are monotones. *}

lemma mono_skip: "mono skip"
  by (simp add: mono_def)

lemma mono_assign: "mono ( `x := ` |m| )"
  by (auto simp: mono_def)

lemma mono_mutation: "mono ( @`x := `m )"
  by (auto simp: mono_def)

lemma mono_dispose: "mono ( dispose e )"
  by (auto simp: mono_def)

lemma mono_seq: "mono F \<Longrightarrow> mono G \<Longrightarrow> mono (F o G)"
  by (auto simp: mono_def)

lemma mono_inf: "mono F \<Longrightarrow> mono G \<Longrightarrow> mono (F \<sqinter> G)"
  by (auto simp: mono_def le_infI1 le_infI2)

lemma mono_pred : "mono \<lceil>p\<rceil>"
  by (auto simp: mono_def)

lemma mono_if: "mono F \<Longrightarrow> mono G \<Longrightarrow> mono (if_comm p F G)"
  by (metis if_comm_def mono_inf mono_seq mono_pred)

lemma mono_Inf: "\<forall>(f :: 'a :: complete_lattice \<Rightarrow> 'a) \<in> F. mono f  \<Longrightarrow> mono (\<Sqinter>F)"
  by (auto simp: mono_def, rule INF_mono) auto

lemma mono_Sup: "\<forall>(f :: 'a :: complete_lattice \<Rightarrow> 'a) \<in> F. mono f  \<Longrightarrow> mono (\<Squnion>F)"
  by (auto simp: mono_def, rule SUP_mono) auto

lemma mono_qpower: "mono F \<Longrightarrow> mono (PT.Sup.qpower F i)"
  apply (induct_tac i)
  apply (unfold mono_def)
  by simp_all

lemma mono_iteration: "mono (F :: 'a predT) \<Longrightarrow> mono (F\<^sup>\<star> :: 'a predT)"
  by (auto simp: iteration_def pow_def intro: mono_qpower mono_Inf)

lemma mono_while: "mono F \<Longrightarrow> mono (while_comm p F)"
  apply (auto simp: while_comm_def intro!: mono_seq mono_iteration)
  by (auto simp: mono_def)

section {* Locality *}

definition local :: "'a predT \<Rightarrow> bool" where
  "local F \<equiv> \<forall>x y. F x * y \<le> F (x * y)"

lemma local_stateT_predT: "local <F>"
  sorry

lemma local_pred : "local \<lceil>p\<rceil>"
  sorry

text {* All the constructs are local *}

lemma local_skip: "local skip"
  by (simp add: local_def)

lemma local_seq: "mono F \<Longrightarrow> local F \<Longrightarrow> local G \<Longrightarrow> local (F o G)"
proof (subst local_def, (rule allI)+, (subst comp_apply)+)
  fix x y assume assms: "mono F" "local F" "local G"
  hence "F (G x) * y \<le> F (G x * y)"
    by (simp add: local_def)
  also have "... \<le> F (G (x * y))" using assms
    by (auto simp add: assms local_def mono_def)
  finally show "F (G x) * y \<le> F (G (x * y))" .
qed

lemma local_inf: "local F \<Longrightarrow> local G \<Longrightarrow> local (F \<sqinter> G)"
  apply (auto simp: local_def)
  apply (metis (mono_tags) Semantics.Sup.qisol le_inf_iff mult_commute order_refl predicate1D)+
done

lemma local_if: "local F \<Longrightarrow> local G \<Longrightarrow> local (if_comm p F G)"
  by (metis if_comm_def mono_pred local_inf local_seq local_pred)

lemma local_power: "mono F \<Longrightarrow> local F \<Longrightarrow> local (near_quantale_unital.qpower op \<circ> skip F i)"
  apply (induct i)
  by (auto simp: local_skip intro: local_seq)

lemma local_mutation: "local (@e := e')"
  by (metis lift_state_heap_predT_def local_stateT_predT)

lemma local_cons: "local (`v := cons e)"
  by (metis local_stateT_predT)

lemma local_dispose: "local (dispose e)"
  by (metis lift_state_heap_predT_def local_stateT_predT)

lemma local_sup: "local f \<Longrightarrow> local g \<Longrightarrow> local (f \<squnion> g)"
proof (subst local_def, (rule allI)+, simp)
  fix x y assume assms: "local f" "local g"
  have "(f x \<squnion> g x) * y \<le> f x * y \<squnion> g x * y"
    by (metis Semantics.Sup.qdistr eq_refl)
  also have "... \<le>  f (x * y) \<squnion> g (x * y)" using assms
    apply (unfold local_def)
    by (metis sup.mono)
  finally show "(f x \<squnion> g x) * y \<le> f (x * y) \<squnion> g (x * y)" .
qed

lemma local_Sup: "\<forall>f \<in> F. local f \<Longrightarrow> local (\<Squnion>F)"
  apply (subst local_def)
  apply (rule allI)+
  apply simp
  apply (unfold SUP_def)
  apply (subst Semantics.Sup.Join_distr)
  apply simp
  apply (rule SUP_mono)
  apply (rule_tac x=xa in bexI)
  by (auto simp: local_def)

lemma local_Inf: "\<forall>f \<in> F. local f \<Longrightarrow> local (\<Sqinter>F)"
  apply (subst local_def)
  apply (rule allI)+
  apply simp
  apply (unfold INF_def)
  apply (rule Inf_greatest)
  apply (clarsimp simp: local_def)
  apply (erule_tac x=f in ballE)
  apply (erule_tac x=x in allE)
  apply (erule_tac x=y in allE)
  apply auto
  by (metis (mono_tags) INF_lower Semantics.Sup.qisol mult_commute predicate1D)

lemma pow_zero: "pow F 0 = skip"
  by (auto simp: pow_def)

lemma pow_suc: "pow F (Suc i) = F o (pow F i)"
  by (auto simp: pow_def)

lemma local_qpower: "mono F \<Longrightarrow> local F \<Longrightarrow> local (pow F i)"
  apply (simp add: local_def)
  apply (induct i)
  apply (auto simp: pow_zero pow_suc)
  by (metis (mono_tags) mono_def predicate1D)

lemma local_iteration: "mono F \<Longrightarrow> local F \<Longrightarrow> local (F\<^sup>\<star> :: 'a predT)"
  by (auto simp: iteration_def intro: local_Inf local_qpower)

end


theory Refine_Folds
imports
  Autoref_Misc
begin

section \<open>Fold binary predicate over finite nonempty set\<close>

definition "FOLD_bin_ne b X = do {
  ASSERT (X \<noteq> {});
  x \<leftarrow> SPEC (\<lambda>x. x \<in> X);
  let X = X - {x};
  FOREACH X (\<lambda>x r. RETURN (b x r)) x
}"

lemma Fold_bin_spec:
  assumes 1: "X \<noteq> {}"
  assumes 2: "finite X"
  assumes refl: "\<And>x. c x x"
  assumes idem1: "\<And>x y. c (b x y) x"
  assumes idem2: "\<And>x y. c (b x y) y"
  assumes trans: "\<And>x y z. c x y \<Longrightarrow> c y z \<Longrightarrow> c x z"
  shows "FOLD_bin_ne b X \<le> SPEC (\<lambda>r. \<forall>x \<in> X. c r x)"
  using 1 2
  unfolding FOLD_bin_ne_def
  apply refine_vcg
  subgoal for x
    apply (rule FOREACH_rule[where I = "\<lambda>it r. (\<forall>x \<in> (insert x (X - {x} - it)). c r x)"])
    subgoal by simp
    subgoal by (simp add: refl)
    subgoal
      using idem1 idem2 trans
      by simp fast
    subgoal by simp
    done
  done

subsection \<open>@{term Inf}/@{term Sup}/@{term Max}/@{term Min}\<close>

lemma inf_Inf_absorb[simp]:
  fixes x::"'a::conditionally_complete_lattice"
  shows "x \<in> X \<Longrightarrow> finite X \<Longrightarrow> inf x (Inf X) = Inf X"
  by (subst cInf_insert[symmetric]) (auto simp: insert_absorb)

lemma sup_Sup_absorb[simp]:
  fixes x::"'a::conditionally_complete_lattice"
  shows "x \<in> X \<Longrightarrow> finite X \<Longrightarrow> sup x (Sup X) = Sup X"
  by (subst cSup_insert[symmetric]) (auto simp: insert_absorb)

definition "Inf_ne X = FOLD_bin_ne inf X"
definition "Sup_ne X = FOLD_bin_ne sup X"
definition "Min_ne X = FOLD_bin_ne min X"
definition "Max_ne X = FOLD_bin_ne max X"
lemma [autoref_itype]:
  "Inf_ne ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_nres"
  "Sup_ne ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_nres"
  "Min_ne ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_nres"
  "Max_ne ::\<^sub>i \<langle>I\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i \<langle>I\<rangle>\<^sub>ii_nres"
  by simp_all

lemma Inf_ne_spec:
  fixes X::"'a::conditionally_complete_lattice set"
  assumes "X \<noteq> {}"
  assumes "finite X"
  shows "Inf_ne X \<le> SPEC (\<lambda>r. r = Inf X)"
  using assms
  unfolding Inf_ne_def FOLD_bin_ne_def
  apply refine_vcg
  apply (rule_tac I = "\<lambda>it r. r = (Inf (insert x (X - {x} - it)))" in FOREACH_rule)
  apply (auto simp: assms it_step_insert_iff cInf_insert_If ac_simps)
  done

lemma Sup_ne_spec:
  fixes X::"'a::conditionally_complete_lattice set"
  assumes "X \<noteq> {}"
  assumes "finite X"
  shows "Sup_ne X \<le> SPEC (\<lambda>r. r = Sup X)"
  using assms
  unfolding Sup_ne_def  FOLD_bin_ne_def
  apply (refine_rcg refine_vcg)
  apply (rule_tac I = "\<lambda>it r. r = (Sup (insert x (X - {x} - it)))" in FOREACH_rule)
  apply (auto simp: assms it_step_insert_iff cSup_insert_If ac_simps)
  done

lemma Min_ne_spec:
  fixes X::"'a::linorder set"
  assumes "X \<noteq> {}"
  assumes "finite X"
  shows "Min_ne X \<le> SPEC (\<lambda>r. r = Min X)"
  using assms
  unfolding Min_ne_def  FOLD_bin_ne_def
  apply refine_vcg
  apply (rule_tac I = "\<lambda>it r. r = (Min (insert x (X - {x} - it)))" in FOREACH_rule)
  apply (auto simp: assms it_step_insert_iff Min.insert_remove ac_simps)
  done

lemma Max_ne_spec:
  fixes X::"'a::linorder set"
  assumes "X \<noteq> {}"
  assumes "finite X"
  shows "Max_ne X \<le> SPEC (\<lambda>r. r = Max X)"
  using assms
  unfolding Max_ne_def  FOLD_bin_ne_def
  apply refine_vcg
  apply (rule_tac I = "\<lambda>it r. r = (Max (insert x (X - {x} - it)))" in FOREACH_rule)
  apply (auto simp: assms it_step_insert_iff Max.insert_remove ac_simps Max.in_idem)
  done

subsection \<open>Implementations\<close>
context includes autoref_syntax begin

schematic_goal FOLD_bin_ne_impl:
  assumes [autoref_rules(overloaded)]: "(del_impl,op_set_delete) \<in> R \<rightarrow> \<langle>R\<rangle>C \<rightarrow> \<langle>R\<rangle>C"
  assumes [autoref_rules(overloaded)]: "(pick_impl,op_set_pick) \<in> \<langle>R\<rangle>C \<rightarrow> \<langle>R\<rangle>nres_rel"
  assumes [autoref_ga_rules]: "is_set_to_list R C tsl"
  assumes[unfolded comps, autoref_rules(overloaded)]: "(bi, b) \<in> R \<rightarrow> R \<rightarrow> R"
  assumes[autoref_rules]: "(Xi, X) \<in> \<langle>R\<rangle>C"
  shows "(?f, (OP FOLD_bin_ne ::: ((R \<rightarrow> R \<rightarrow> R) \<rightarrow> \<langle>R\<rangle>C \<rightarrow> \<langle>R\<rangle>nres_rel)) $ b $ X) \<in> \<langle>R\<rangle>nres_rel"
  unfolding FOLD_bin_ne_def[abs_def] autoref_tag_defs comps
  by (autoref_monadic (plain))
concrete_definition FOLD_bin_ne_impl uses FOLD_bin_ne_impl
lemmas [autoref_rules(overloaded)] = FOLD_bin_ne_impl.refine [OF GEN_OP_D GEN_OP_D SIDE_GEN_ALGO_D]
  \<comment> \<open>TODO: really? overloaded here?\<close>

schematic_goal Inf_ne_impl:
  assumes [autoref_rules(overloaded)]: "(del_impl,op_set_delete) \<in> R \<rightarrow> \<langle>R\<rangle>C \<rightarrow> \<langle>R\<rangle>C"
  assumes [autoref_rules(overloaded)]: "(pick_impl,op_set_pick) \<in> \<langle>R\<rangle>C \<rightarrow> \<langle>R\<rangle>nres_rel"
  assumes [autoref_ga_rules]: "is_set_to_list R C tsl"
  assumes[autoref_rules(overloaded)]: "(infi, inf) \<in> R \<rightarrow> R \<rightarrow> R"
  assumes[autoref_rules]: "(Xi, X) \<in> \<langle>R\<rangle>C"
  shows "(?f, (OP Inf_ne ::: (\<langle>R\<rangle>C \<rightarrow> \<langle>R\<rangle>nres_rel)) $ X) \<in> \<langle>R\<rangle>nres_rel"
  unfolding Inf_ne_def[abs_def] FOLD_bin_ne_def[abs_def] autoref_tag_defs
  by (autoref_monadic (plain))
concrete_definition Inf_ne_impl uses Inf_ne_impl
lemmas [autoref_rules(overloaded)] = Inf_ne_impl.refine [OF GEN_OP_D GEN_OP_D SIDE_GEN_ALGO_D]

schematic_goal Sup_ne_impl:
  assumes [autoref_rules(overloaded)]: "(del_impl,op_set_delete) \<in> R \<rightarrow> \<langle>R\<rangle>C \<rightarrow> \<langle>R\<rangle>C"
  assumes [autoref_rules(overloaded)]: "(pick_impl,op_set_pick) \<in> \<langle>R\<rangle>C \<rightarrow> \<langle>R\<rangle>nres_rel"
  assumes [autoref_ga_rules]: "is_set_to_list R C tsl"
  assumes[autoref_rules(overloaded)]: "(supi, sup) \<in> R \<rightarrow> R \<rightarrow> R"
  assumes[autoref_rules]: "(Xi, X) \<in> \<langle>R\<rangle>C"
  shows "(?f, (OP Sup_ne ::: (\<langle>R\<rangle>C \<rightarrow> \<langle>R\<rangle>nres_rel)) $ X) \<in> \<langle>R\<rangle>nres_rel"
  unfolding Sup_ne_def[abs_def] FOLD_bin_ne_def[abs_def] autoref_tag_defs
  by (autoref_monadic (plain))
concrete_definition Sup_ne_impl uses Sup_ne_impl
lemmas [autoref_rules(overloaded)] = Sup_ne_impl.refine [OF GEN_OP_D GEN_OP_D SIDE_GEN_ALGO_D]

schematic_goal Min_ne_impl:
  assumes [autoref_rules(overloaded)]: "(del_impl,op_set_delete) \<in> R \<rightarrow> \<langle>R\<rangle>C \<rightarrow> \<langle>R\<rangle>C"
  assumes [autoref_rules(overloaded)]: "(pick_impl,op_set_pick) \<in> \<langle>R\<rangle>C \<rightarrow> \<langle>R\<rangle>nres_rel"
  assumes [autoref_ga_rules]: "is_set_to_list R C tsl"
  assumes[autoref_rules(overloaded)]: "(mini, min) \<in> R \<rightarrow> R \<rightarrow> R"
  assumes[autoref_rules]: "(Xi, X) \<in> \<langle>R\<rangle>C"
  shows "(?f, (OP Min_ne ::: (\<langle>R\<rangle>C \<rightarrow> \<langle>R\<rangle>nres_rel)) $ X) \<in> \<langle>R\<rangle>nres_rel"
  unfolding Min_ne_def[abs_def] FOLD_bin_ne_def[abs_def] autoref_tag_defs
  by (autoref_monadic (plain))
concrete_definition Min_ne_impl uses Min_ne_impl
lemmas [autoref_rules(overloaded)] = Min_ne_impl.refine [OF GEN_OP_D GEN_OP_D SIDE_GEN_ALGO_D]

schematic_goal Max_ne_impl:
  assumes [autoref_rules(overloaded)]: "(del_impl,op_set_delete) \<in> R \<rightarrow> \<langle>R\<rangle>C \<rightarrow> \<langle>R\<rangle>C"
  assumes [autoref_rules(overloaded)]: "(pick_impl,op_set_pick) \<in> \<langle>R\<rangle>C \<rightarrow> \<langle>R\<rangle>nres_rel"
  assumes [autoref_ga_rules]: "is_set_to_list R C tsl"
  assumes[autoref_rules(overloaded)]: "(maxi, max) \<in> R \<rightarrow> R \<rightarrow> R"
  assumes[autoref_rules]: "(Xi, X) \<in> \<langle>R\<rangle>C"
  shows "(?f, (OP Max_ne ::: (\<langle>R\<rangle>C \<rightarrow> \<langle>R\<rangle>nres_rel)) $ X) \<in> \<langle>R\<rangle>nres_rel"
  unfolding Max_ne_def[abs_def] FOLD_bin_ne_def[abs_def] autoref_tag_defs
  by (autoref_monadic (plain))
concrete_definition Max_ne_impl uses Max_ne_impl
lemmas [autoref_rules(overloaded)] = Max_ne_impl.refine [OF GEN_OP_D GEN_OP_D SIDE_GEN_ALGO_D]

end

end


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

Refute examples adapted to Nitpick.
*)

section \<open>Refute Examples Adapted to Nitpick\<close>

theory Refute_Nits
imports MainRLT
begin

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

lemma "P \<and> Q"
apply (rule conjI)
nitpick [expect = genuine] 1
nitpick [expect = genuine] 2
nitpick [expect = genuine]
nitpick [card = 5, expect = genuine]
nitpick [sat_solver = SAT4J, expect = genuine] 2
oops

subsection \<open>Examples and Test Cases\<close>

subsubsection \<open>Propositional logic\<close>

lemma "True"
nitpick [expect = none]
apply auto
done

lemma "False"
nitpick [expect = genuine]
oops

lemma "P"
nitpick [expect = genuine]
oops

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

lemma "P \<and> Q"
nitpick [expect = genuine]
oops

lemma "P \<or> Q"
nitpick [expect = genuine]
oops

lemma "P \<longrightarrow> Q"
nitpick [expect = genuine]
oops

lemma "(P::bool) = Q"
nitpick [expect = genuine]
oops

lemma "(P \<or> Q) \<longrightarrow> (P \<and> Q)"
nitpick [expect = genuine]
oops

subsubsection \<open>Predicate logic\<close>

lemma "P x y z"
nitpick [expect = genuine]
oops

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

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

subsubsection \<open>Equality\<close>

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

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

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

lemma "f x = g x"
nitpick [expect = genuine]
oops

lemma "(f::'a\<Rightarrow>'b) = g"
nitpick [expect = genuine]
oops

lemma "(f::('d\<Rightarrow>'d)\<Rightarrow>('c\<Rightarrow>'d)) = g"
nitpick [expect = genuine]
oops

lemma "distinct [a, b]"
nitpick [expect = genuine]
apply simp
nitpick [expect = genuine]
oops

subsubsection \<open>First-Order Logic\<close>

lemma "\<exists>x. P x"
nitpick [expect = genuine]
oops

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

lemma "\<exists>!x. P x"
nitpick [expect = genuine]
oops

lemma "Ex P"
nitpick [expect = genuine]
oops

lemma "All P"
nitpick [expect = genuine]
oops

lemma "Ex1 P"
nitpick [expect = genuine]
oops

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

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

lemma "(\<exists>x. P x) \<longrightarrow> (\<exists>!x. P x)"
nitpick [expect = genuine]
oops

text \<open>A true statement (also testing names of free and bound variables being identical)\<close>

lemma "(\<forall>x y. P x y \<longrightarrow> P y x) \<longrightarrow> (\<forall>x. P x y) \<longrightarrow> P y x"
nitpick [expect = none]
apply fast
done

text \<open>"A type has at most 4 elements."\<close>

lemma "\<not> distinct [a, b, c, d, e]"
nitpick [expect = genuine]
apply simp
nitpick [expect = genuine]
oops

lemma "distinct [a, b, c, d]"
nitpick [expect = genuine]
apply simp
nitpick [expect = genuine]
oops

text \<open>"Every reflexive and symmetric relation is transitive."\<close>

lemma "\<lbrakk>\<forall>x. P x x; \<forall>x y. P x y \<longrightarrow> P y x\<rbrakk> \<Longrightarrow> P x y \<longrightarrow> P y z \<longrightarrow> P x z"
nitpick [expect = genuine]
oops

text \<open>The ``Drinker's theorem''\<close>

lemma "\<exists>x. f x = g x \<longrightarrow> f = g"
nitpick [expect = none]
apply (auto simp add: ext)
done

text \<open>And an incorrect version of it\<close>

lemma "(\<exists>x. f x = g x) \<longrightarrow> f = g"
nitpick [expect = genuine]
oops

text \<open>"Every function has a fixed point."\<close>

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

text \<open>"Function composition is commutative."\<close>

lemma "f (g x) = g (f x)"
nitpick [expect = genuine]
oops

text \<open>"Two functions that are equivalent wrt.\ the same predicate 'P' are equal."\<close>

lemma "((P::('a\<Rightarrow>'b)\<Rightarrow>bool) f = P g) \<longrightarrow> (f x = g x)"
nitpick [expect = genuine]
oops

subsubsection \<open>Higher-Order Logic\<close>

lemma "\<exists>P. P"
nitpick [expect = none]
apply auto
done

lemma "\<forall>P. P"
nitpick [expect = genuine]
oops

lemma "\<exists>!P. P"
nitpick [expect = none]
apply auto
done

lemma "\<exists>!P. P x"
nitpick [expect = genuine]
oops

lemma "P Q \<or> Q x"
nitpick [expect = genuine]
oops

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

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

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

text \<open>``The transitive closure of an arbitrary relation is non-empty.''\<close>

definition "trans" :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
"trans P \<equiv> (\<forall>x y z. P x y \<longrightarrow> P y z \<longrightarrow> P x z)"

definition
"subset" :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
"subset P Q \<equiv> (\<forall>x y. P x y \<longrightarrow> Q x y)"

definition
"trans_closure" :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
"trans_closure P Q \<equiv> (subset Q P) \<and> (trans P) \<and> (\<forall>R. subset Q R \<longrightarrow> trans R \<longrightarrow> subset P R)"

lemma "trans_closure T P \<longrightarrow> (\<exists>x y. T x y)"
nitpick [expect = genuine]
oops

text \<open>``The union of transitive closures is equal to the transitive closure of unions.''\<close>

lemma "(\<forall>x y. (P x y \<or> R x y) \<longrightarrow> T x y) \<longrightarrow> trans T \<longrightarrow> (\<forall>Q. (\<forall>x y. (P x y \<or> R x y) \<longrightarrow> Q x y) \<longrightarrow> trans Q \<longrightarrow> subset T Q)
 \<longrightarrow> trans_closure TP P
 \<longrightarrow> trans_closure TR R
 \<longrightarrow> (T x y = (TP x y \<or> TR x y))"
nitpick [expect = genuine]
oops

text \<open>``Every surjective function is invertible.''\<close>

lemma "(\<forall>y. \<exists>x. y = f x) \<longrightarrow> (\<exists>g. \<forall>x. g (f x) = x)"
nitpick [expect = genuine]
oops

text \<open>``Every invertible function is surjective.''\<close>

lemma "(\<exists>g. \<forall>x. g (f x) = x) \<longrightarrow> (\<forall>y. \<exists>x. y = f x)"
nitpick [expect = genuine]
oops

text \<open>``Every point is a fixed point of some function.''\<close>

lemma "\<exists>f. f x = x"
nitpick [card = 1-7, expect = none]
apply (rule_tac x = "\<lambda>x. x" in exI)
apply simp
done

text \<open>Axiom of Choice: first an incorrect version\<close>

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

text \<open>And now two correct ones\<close>

lemma "(\<forall>x. \<exists>y. P x y) \<longrightarrow> (\<exists>f. \<forall>x. P x (f x))"
nitpick [card = 1-4, expect = none]
apply (simp add: choice)
done

lemma "(\<forall>x. \<exists>!y. P x y) \<longrightarrow> (\<exists>!f. \<forall>x. P x (f x))"
nitpick [card = 1-3, expect = none]
apply auto
 apply (simp add: ex1_implies_ex choice)
apply (fast intro: ext)
done

subsubsection \<open>Metalogic\<close>

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

lemma "f x \<equiv> g x"
nitpick [expect = genuine]
oops

lemma "P \<Longrightarrow> Q"
nitpick [expect = genuine]
oops

lemma "\<lbrakk>P; Q; R\<rbrakk> \<Longrightarrow> S"
nitpick [expect = genuine]
oops

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

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

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

subsubsection \<open>Schematic Variables\<close>

schematic_goal "?P"
nitpick [expect = none]
apply auto
done

schematic_goal "x = ?y"
nitpick [expect = none]
apply auto
done

subsubsection \<open>Abstractions\<close>

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

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

lemma "(\<lambda>x. x) = (\<lambda>y. y)"
nitpick [expect = none]
apply simp
done

subsubsection \<open>Sets\<close>

lemma "P (A::'a set)"
nitpick [expect = genuine]
oops

lemma "P (A::'a set set)"
nitpick [expect = genuine]
oops

lemma "{x. P x} = {y. P y}"
nitpick [expect = none]
apply simp
done

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

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

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

lemma "P Collect"
nitpick [expect = genuine]
oops

lemma "A Un B = A Int B"
nitpick [expect = genuine]
oops

lemma "(A Int B) Un C = (A Un C) Int B"
nitpick [expect = genuine]
oops

lemma "Ball A P \<longrightarrow> Bex A P"
nitpick [expect = genuine]
oops

subsubsection \<open>\<^const>\<open>undefined\<close>\<close>

lemma "undefined"
nitpick [expect = genuine]
oops

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

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

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

subsubsection \<open>\<^const>\<open>The\<close>\<close>

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

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

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

lemma "(THE x. x=y) = z"
nitpick [expect = genuine]
oops

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

subsubsection \<open>\<^const>\<open>Eps\<close>\<close>

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

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

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

lemma "(SOME x. x=y) = z"
nitpick [expect = genuine]
oops

lemma "Ex P \<longrightarrow> P (Eps P)"
nitpick [expect = none]
apply (auto simp add: someI)
done

subsubsection \<open>Operations on Natural Numbers\<close>

lemma "(x::nat) + y = 0"
nitpick [expect = genuine]
oops

lemma "(x::nat) = x + x"
nitpick [expect = genuine]
oops

lemma "(x::nat) - y + y = x"
nitpick [expect = genuine]
oops

lemma "(x::nat) = x * x"
nitpick [expect = genuine]
oops

lemma "(x::nat) < x + y"
nitpick [card = 1, expect = genuine]
oops

text \<open>\<times>\<close>

lemma "P (x::'a\<times>'b)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a\<times>'b. P x"
nitpick [expect = genuine]
oops

lemma "P (x, y)"
nitpick [expect = genuine]
oops

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

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

lemma "P Pair"
nitpick [expect = genuine]
oops

lemma "P (case x of Pair a b \<Rightarrow> f a b)"
nitpick [expect = genuine]
oops

subsubsection \<open>Subtypes (typedef), typedecl\<close>

text \<open>A completely unspecified non-empty subset of \<^typ>\<open>'a\<close>:\<close>

definition "myTdef = insert (undefined::'a) (undefined::'a set)"

typedef 'a myTdef = "myTdef :: 'a set"
unfolding myTdef_def by auto

lemma "(x::'a myTdef) = y"
nitpick [expect = genuine]
oops

typedecl myTdecl

definition "T_bij = {(f::'a\<Rightarrow>'a). \<forall>y. \<exists>!x. f x = y}"

typedef 'a T_bij = "T_bij :: ('a \<Rightarrow> 'a) set"
unfolding T_bij_def by auto

lemma "P (f::(myTdecl myTdef) T_bij)"
nitpick [expect = genuine]
oops

subsubsection \<open>Inductive Datatypes\<close>

text \<open>unit\<close>

lemma "P (x::unit)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::unit. P x"
nitpick [expect = genuine]
oops

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

lemma "P (case x of () \<Rightarrow> u)"
nitpick [expect = genuine]
oops

text \<open>option\<close>

lemma "P (x::'a option)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a option. P x"
nitpick [expect = genuine]
oops

lemma "P None"
nitpick [expect = genuine]
oops

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

lemma "P (case x of None \<Rightarrow> n | Some u \<Rightarrow> s u)"
nitpick [expect = genuine]
oops

text \<open>+\<close>

lemma "P (x::'a+'b)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a+'b. P x"
nitpick [expect = genuine]
oops

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

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

lemma "P Inl"
nitpick [expect = genuine]
oops

lemma "P (case x of Inl a \<Rightarrow> l a | Inr b \<Rightarrow> r b)"
nitpick [expect = genuine]
oops

text \<open>Non-recursive datatypes\<close>

datatype T1 = A | B

lemma "P (x::T1)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::T1. P x"
nitpick [expect = genuine]
oops

lemma "P A"
nitpick [expect = genuine]
oops

lemma "P B"
nitpick [expect = genuine]
oops

lemma "rec_T1 a b A = a"
nitpick [expect = none]
apply simp
done

lemma "rec_T1 a b B = b"
nitpick [expect = none]
apply simp
done

lemma "P (rec_T1 a b x)"
nitpick [expect = genuine]
oops

lemma "P (case x of A \<Rightarrow> a | B \<Rightarrow> b)"
nitpick [expect = genuine]
oops

datatype 'a T2 = C T1 | D 'a

lemma "P (x::'a T2)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a T2. P x"
nitpick [expect = genuine]
oops

lemma "P D"
nitpick [expect = genuine]
oops

lemma "rec_T2 c d (C x) = c x"
nitpick [expect = none]
apply simp
done

lemma "rec_T2 c d (D x) = d x"
nitpick [expect = none]
apply simp
done

lemma "P (rec_T2 c d x)"
nitpick [expect = genuine]
oops

lemma "P (case x of C u \<Rightarrow> c u | D v \<Rightarrow> d v)"
nitpick [expect = genuine]
oops

datatype ('a, 'b) T3 = E "'a \<Rightarrow> 'b"

lemma "P (x::('a, 'b) T3)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::('a, 'b) T3. P x"
nitpick [expect = genuine]
oops

lemma "P E"
nitpick [expect = genuine]
oops

lemma "rec_T3 e (E x) = e x"
nitpick [card = 1-4, expect = none]
apply simp
done

lemma "P (rec_T3 e x)"
nitpick [expect = genuine]
oops

lemma "P (case x of E f \<Rightarrow> e f)"
nitpick [expect = genuine]
oops

text \<open>Recursive datatypes\<close>

text \<open>nat\<close>

lemma "P (x::nat)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::nat. P x"
nitpick [expect = genuine]
oops

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

lemma "P Suc"
nitpick [card = 1-7, expect = none]
oops

lemma "rec_nat zero suc 0 = zero"
nitpick [expect = none]
apply simp
done

lemma "rec_nat zero suc (Suc x) = suc x (rec_nat zero suc x)"
nitpick [expect = none]
apply simp
done

lemma "P (rec_nat zero suc x)"
nitpick [expect = genuine]
oops

lemma "P (case x of 0 \<Rightarrow> zero | Suc n \<Rightarrow> suc n)"
nitpick [expect = genuine]
oops

text \<open>'a list\<close>

lemma "P (xs::'a list)"
nitpick [expect = genuine]
oops

lemma "\<forall>xs::'a list. P xs"
nitpick [expect = genuine]
oops

lemma "P [x, y]"
nitpick [expect = genuine]
oops

lemma "rec_list nil cons [] = nil"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "rec_list nil cons (x#xs) = cons x xs (rec_list nil cons xs)"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "P (rec_list nil cons xs)"
nitpick [expect = genuine]
oops

lemma "P (case x of Nil \<Rightarrow> nil | Cons a b \<Rightarrow> cons a b)"
nitpick [expect = genuine]
oops

lemma "(xs::'a list) = ys"
nitpick [expect = genuine]
oops

lemma "a # xs = b # xs"
nitpick [expect = genuine]
oops

datatype BitList = BitListNil | Bit0 BitList | Bit1 BitList

lemma "P (x::BitList)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::BitList. P x"
nitpick [expect = genuine]
oops

lemma "P (Bit0 (Bit1 BitListNil))"
nitpick [expect = genuine]
oops

lemma "rec_BitList nil bit0 bit1 BitListNil = nil"
nitpick [expect = none]
apply simp
done

lemma "rec_BitList nil bit0 bit1 (Bit0 xs) = bit0 xs (rec_BitList nil bit0 bit1 xs)"
nitpick [expect = none]
apply simp
done

lemma "rec_BitList nil bit0 bit1 (Bit1 xs) = bit1 xs (rec_BitList nil bit0 bit1 xs)"
nitpick [expect = none]
apply simp
done

lemma "P (rec_BitList nil bit0 bit1 x)"
nitpick [expect = genuine]
oops

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

lemma "P (x::'a BinTree)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a BinTree. P x"
nitpick [expect = genuine]
oops

lemma "P (Node (Leaf x) (Leaf y))"
nitpick [expect = genuine]
oops

lemma "rec_BinTree l n (Leaf x) = l x"
nitpick [expect = none]
apply simp
done

lemma "rec_BinTree l n (Node x y) = n x y (rec_BinTree l n x) (rec_BinTree l n y)"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "P (rec_BinTree l n x)"
nitpick [expect = genuine]
oops

lemma "P (case x of Leaf a \<Rightarrow> l a | Node a b \<Rightarrow> n a b)"
nitpick [expect = genuine]
oops

text \<open>Mutually recursive datatypes\<close>

datatype 'a aexp = Number 'a | ITE "'a bexp" "'a aexp" "'a aexp"
 and 'a bexp = Equal "'a aexp" "'a aexp"

lemma "P (x::'a aexp)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a aexp. P x"
nitpick [expect = genuine]
oops

lemma "P (ITE (Equal (Number x) (Number y)) (Number x) (Number y))"
nitpick [expect = genuine]
oops

lemma "P (x::'a bexp)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a bexp. P x"
nitpick [expect = genuine]
oops

lemma "rec_aexp number ite equal (Number x) = number x"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "rec_aexp number ite equal (ITE x y z) = ite x y z (rec_bexp number ite equal x) (rec_aexp number ite equal y) (rec_aexp number ite equal z)"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "P (rec_aexp number ite equal x)"
nitpick [expect = genuine]
oops

lemma "P (case x of Number a \<Rightarrow> number a | ITE b a1 a2 \<Rightarrow> ite b a1 a2)"
nitpick [expect = genuine]
oops

lemma "rec_bexp number ite equal (Equal x y) = equal x y (rec_aexp number ite equal x) (rec_aexp number ite equal y)"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "P (rec_bexp number ite equal x)"
nitpick [expect = genuine]
oops

lemma "P (case x of Equal a1 a2 \<Rightarrow> equal a1 a2)"
nitpick [expect = genuine]
oops

datatype X = A | B X | C Y and Y = D X | E Y | F

lemma "P (x::X)"
nitpick [expect = genuine]
oops

lemma "P (y::Y)"
nitpick [expect = genuine]
oops

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

lemma "P (B (C F))"
nitpick [expect = genuine]
oops

lemma "P (C (D A))"
nitpick [expect = genuine]
oops

lemma "P (C (E F))"
nitpick [expect = genuine]
oops

lemma "P (D (B A))"
nitpick [expect = genuine]
oops

lemma "P (D (C F))"
nitpick [expect = genuine]
oops

lemma "P (E (D A))"
nitpick [expect = genuine]
oops

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

lemma "P (C (D (C F)))"
nitpick [expect = genuine]
oops

lemma "rec_X a b c d e f A = a"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "rec_X a b c d e f (B x) = b x (rec_X a b c d e f x)"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "rec_X a b c d e f (C y) = c y (rec_Y a b c d e f y)"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "rec_Y a b c d e f (D x) = d x (rec_X a b c d e f x)"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "rec_Y a b c d e f (E y) = e y (rec_Y a b c d e f y)"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "rec_Y a b c d e f F = f"
nitpick [card = 1-5, expect = none]
apply simp
done

lemma "P (rec_X a b c d e f x)"
nitpick [expect = genuine]
oops

lemma "P (rec_Y a b c d e f y)"
nitpick [expect = genuine]
oops

text \<open>Other datatype examples\<close>

text \<open>Indirect recursion is implemented via mutual recursion.\<close>

datatype XOpt = CX "XOpt option" | DX "bool \<Rightarrow> XOpt option"

lemma "P (x::XOpt)"
nitpick [expect = genuine]
oops

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

lemma "P (CX (Some (CX None)))"
nitpick [expect = genuine]
oops

lemma "P (rec_X cx dx n1 s1 n2 s2 x)"
nitpick [expect = genuine]
oops

datatype 'a YOpt = CY "('a \<Rightarrow> 'a YOpt) option"

lemma "P (x::'a YOpt)"
nitpick [expect = genuine]
oops

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

lemma "P (CY (Some (\<lambda>a. CY None)))"
nitpick [expect = genuine]
oops

datatype Trie = TR "Trie list"

lemma "P (x::Trie)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::Trie. P x"
nitpick [expect = genuine]
oops

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

datatype InfTree = Leaf | Node "nat \<Rightarrow> InfTree"

lemma "P (x::InfTree)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::InfTree. P x"
nitpick [expect = genuine]
oops

lemma "P (Node (\<lambda>n. Leaf))"
nitpick [expect = genuine]
oops

lemma "rec_InfTree leaf node Leaf = leaf"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "rec_InfTree leaf node (Node g) = node ((\<lambda>InfTree. (InfTree, rec_InfTree leaf node InfTree)) \<circ> g)"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "P (rec_InfTree leaf node x)"
nitpick [expect = genuine]
oops

datatype 'a lambda = Var 'a | App "'a lambda" "'a lambda" | Lam "'a \<Rightarrow> 'a lambda"

lemma "P (x::'a lambda)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'a lambda. P x"
nitpick [expect = genuine]
oops

lemma "P (Lam (\<lambda>a. Var a))"
nitpick [card = 1-5, expect = none]
nitpick [card 'a = 4, card "'a lambda" = 5, expect = genuine]
oops

lemma "rec_lambda var app lam (Var x) = var x"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "rec_lambda var app lam (App x y) = app x y (rec_lambda var app lam x) (rec_lambda var app lam y)"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "rec_lambda var app lam (Lam x) = lam ((\<lambda>lambda. (lambda, rec_lambda var app lam lambda)) \<circ> x)"
nitpick [card = 1-3, expect = none]
apply simp
done

lemma "P (rec_lambda v a l x)"
nitpick [expect = genuine]
oops

text \<open>Taken from "Inductive datatypes in HOL", p. 8:\<close>

datatype (dead 'a, 'b) T = C "'a \<Rightarrow> bool" | D "'b list"
datatype 'c U = E "('c, 'c U) T"

lemma "P (x::'c U)"
nitpick [expect = genuine]
oops

lemma "\<forall>x::'c U. P x"
nitpick [expect = genuine]
oops

lemma "P (E (C (\<lambda>a. True)))"
nitpick [expect = genuine]
oops

subsubsection \<open>Records\<close>

record ('a, 'b) point =
  xpos :: 'a
  ypos :: 'b

lemma "(x::('a, 'b) point) = y"
nitpick [expect = genuine]
oops

record ('a, 'b, 'c) extpoint = "('a, 'b) point" +
  ext :: 'c

lemma "(x::('a, 'b, 'c) extpoint) = y"
nitpick [expect = genuine]
oops

subsubsection \<open>Inductively Defined Sets\<close>

inductive_set undefinedSet :: "'a set" where
"undefined \<in> undefinedSet"

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

inductive_set evenCard :: "'a set set"
where
"{} \<in> evenCard" |
"\<lbrakk>S \<in> evenCard; x \<notin> S; y \<notin> S; x \<noteq> y\<rbrakk> \<Longrightarrow> S \<union> {x, y} \<in> evenCard"

lemma "S \<in> evenCard"
nitpick [expect = genuine]
oops

inductive_set
even :: "nat set"
and odd :: "nat set"
where
"0 \<in> even" |
"n \<in> even \<Longrightarrow> Suc n \<in> odd" |
"n \<in> odd \<Longrightarrow> Suc n \<in> even"

lemma "n \<in> odd"
nitpick [expect = genuine]
oops

consts f :: "'a \<Rightarrow> 'a"

inductive_set a_even :: "'a set" and a_odd :: "'a set" where
"undefined \<in> a_even" |
"x \<in> a_even \<Longrightarrow> f x \<in> a_odd" |
"x \<in> a_odd \<Longrightarrow> f x \<in> a_even"

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

subsubsection \<open>Examples Involving Special Functions\<close>

lemma "card x = 0"
nitpick [expect = genuine]
oops

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

lemma "xs @ [] = ys @ []"
nitpick [expect = genuine]
oops

lemma "xs @ ys = ys @ xs"
nitpick [expect = genuine]
oops

lemma "f (lfp f) = lfp f"
nitpick [card = 2, expect = genuine]
oops

lemma "f (gfp f) = gfp f"
nitpick [card = 2, expect = genuine]
oops

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

subsubsection \<open>Axiomatic Type Classes and Overloading\<close>

text \<open>A type class without axioms:\<close>

class classA

lemma "P (x::'a::classA)"
nitpick [expect = genuine]
oops

text \<open>An axiom with a type variable (denoting types which have at least two elements):\<close>

class classC =
  assumes classC_ax: "\<exists>x y. x \<noteq> y"

lemma "P (x::'a::classC)"
nitpick [expect = genuine]
oops

lemma "\<exists>x y. (x::'a::classC) \<noteq> y"
nitpick [expect = none]
sorry

text \<open>A type class for which a constant is defined:\<close>

class classD =
  fixes classD_const :: "'a \<Rightarrow> 'a"
  assumes classD_ax: "classD_const (classD_const x) = classD_const x"

lemma "P (x::'a::classD)"
nitpick [expect = genuine]
oops

text \<open>A type class with multiple superclasses:\<close>

class classE = classC + classD

lemma "P (x::'a::classE)"
nitpick [expect = genuine]
oops

text \<open>OFCLASS:\<close>

lemma "OFCLASS('a::type, type_class)"
nitpick [expect = none]
apply intro_classes
done

lemma "OFCLASS('a::classC, type_class)"
nitpick [expect = none]
apply intro_classes
done

lemma "OFCLASS('a::type, classC_class)"
nitpick [expect = genuine]
oops

text \<open>Overloading:\<close>

consts inverse :: "'a \<Rightarrow> 'a"

overloading inverse_bool \<equiv> "inverse :: bool \<Rightarrow> bool"
begin
  definition "inverse (b::bool) \<equiv> \<not> b"
end

overloading inverse_set \<equiv> "inverse :: 'a set \<Rightarrow> 'a set"
begin
  definition "inverse (S::'a set) \<equiv> -S"
end

overloading inverse_pair \<equiv> "inverse :: 'a \<times> 'b \<Rightarrow> 'a \<times> 'b"
begin
  definition "inverse_pair p \<equiv> (inverse (fst p), inverse (snd p))"
end

lemma "inverse b"
nitpick [expect = genuine]
oops

lemma "P (inverse (S::'a set))"
nitpick [expect = genuine]
oops

lemma "P (inverse (p::'a\<times>'b))"
nitpick [expect = genuine]
oops

end


(*  Author:     Gertrud Bauer
*)

header{* Plane Graph Enumeration *}

theory Plane
imports Enumerator FaceDivision RTranCl
begin

definition maxGon :: "nat \<Rightarrow> nat" where
"maxGon p \<equiv> p+3"

declare maxGon_def [simp]

definition duplicateEdge :: "graph \<Rightarrow> face \<Rightarrow> vertex \<Rightarrow> vertex \<Rightarrow> bool" where
 "duplicateEdge g f a b \<equiv>
  2 \<le> directedLength f a b \<and> 2 \<le> directedLength f b a \<and> b \<in> set (neighbors g a)"

primrec containsUnacceptableEdgeSnd ::
      "(nat \<Rightarrow> nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> bool" where
 "containsUnacceptableEdgeSnd N v [] = False" |
 "containsUnacceptableEdgeSnd N v (w#ws) =
     (case ws of [] \<Rightarrow> False
         | (w'#ws') \<Rightarrow> if v < w \<and> w < w' \<and> N w w' then True
                      else containsUnacceptableEdgeSnd N w ws)"

primrec containsUnacceptableEdge :: "(nat \<Rightarrow> nat \<Rightarrow> bool) \<Rightarrow> nat list \<Rightarrow> bool" where
 "containsUnacceptableEdge N [] = False" |
 "containsUnacceptableEdge N (v#vs) =
     (case vs of [] \<Rightarrow> False
           | (w#ws) \<Rightarrow> if v < w \<and> N v w then True
                      else containsUnacceptableEdgeSnd N v vs)"

definition containsDuplicateEdge :: "graph \<Rightarrow> face \<Rightarrow> vertex \<Rightarrow> nat list \<Rightarrow> bool" where
 "containsDuplicateEdge g f v is \<equiv>
     containsUnacceptableEdge (\<lambda>i j. duplicateEdge g f (f\<^bsup>i\<^esup>\<bullet>v) (f\<^bsup>j\<^esup>\<bullet>v)) is"

definition containsDuplicateEdge' :: "graph \<Rightarrow> face \<Rightarrow> vertex \<Rightarrow> nat list \<Rightarrow> bool" where
 "containsDuplicateEdge' g f v is \<equiv>
  2 \<le> |is| \<and>
  ((\<exists>k < |is| - 2. let i0 = is!k; i1 = is!(k+1); i2 = is!(k+2) in
    (duplicateEdge g f (f\<^bsup>i1 \<^esup>\<bullet>v) (f\<^bsup>i2 \<^esup>\<bullet>v)) \<and> (i0 < i1) \<and> (i1 < i2))
  \<or> (let i0 = is!0; i1 = is!1 in
    (duplicateEdge g f (f\<^bsup>i0 \<^esup>\<bullet>v) (f\<^bsup>i1 \<^esup>\<bullet>v)) \<and> (i0 < i1)))"

definition generatePolygon :: "nat \<Rightarrow> vertex \<Rightarrow> face \<Rightarrow> graph \<Rightarrow> graph list" where
 "generatePolygon n v f g \<equiv>
     let enumeration = enumerator n |vertices f|;
     enumeration = [is \<leftarrow> enumeration. \<not> containsDuplicateEdge g f v is];
     vertexLists = [indexToVertexList f v is. is \<leftarrow> enumeration] in
     [subdivFace g f vs. vs \<leftarrow> vertexLists]"

definition next_plane0 :: "nat \<Rightarrow> graph \<Rightarrow> graph list" ("next'_plane0\<^bsub>_\<^esub>") where
 "next_plane0\<^bsub>p\<^esub> g \<equiv>
     if final g then []
     else \<Squnion>\<^bsub>f\<in>nonFinals g\<^esub> \<Squnion>\<^bsub>v\<in>vertices f\<^esub> \<Squnion>\<^bsub>i\<in>[3..<Suc(maxGon p)]\<^esub> generatePolygon i v f g"

definition Seed :: "nat \<Rightarrow> graph" ("Seed\<^bsub>_\<^esub>") where
  "Seed\<^bsub>p\<^esub> \<equiv> graph(maxGon p)"

lemma Seed_not_final[iff]: "\<not> final (Seed p)"
by(simp add:Seed_def graph_def finalGraph_def nonFinals_def)

definition PlaneGraphs0 :: "graph set" where
"PlaneGraphs0 \<equiv> \<Union>p. {g. Seed\<^bsub>p\<^esub> [next_plane0\<^bsub>p\<^esub>]\<rightarrow>* g \<and> final g}"

end


(* Author: Alexander Maletzky *)

section \<open>Further Properties of Multivariate Polynomials\<close>

theory More_MPoly_Type_Class
  imports Polynomials.MPoly_Type_Class_Ordered General
begin

text \<open>Some further general properties of (ordered) multivariate polynomials needed for Gr\"obner
  bases. This theory is an extension of @{theory Polynomials.MPoly_Type_Class_Ordered}.\<close>

subsection \<open>Modules and Linear Hulls\<close>

context module
begin

lemma span_listE:
  assumes "p \<in> span (set bs)"
  obtains qs where "length qs = length bs" and "p = sum_list (map2 (*s) qs bs)"
proof -
  have "finite (set bs)" ..
  from this assms obtain q where p: "p = (\<Sum>b\<in>set bs. (q b) *s b)" by (rule span_finiteE)
  let ?qs = "map_dup q (\<lambda>_. 0) bs"
  show ?thesis
  proof
    show "length ?qs = length bs" by simp
  next
    let ?zs = "zip (map q (remdups bs)) (remdups bs)"
    have *: "distinct ?zs" by (rule distinct_zipI2, rule distinct_remdups)
    have inj: "inj_on (\<lambda>b. (q b, b)) (set bs)" by (rule, simp)
    have "p = (\<Sum>(q, b)\<leftarrow>?zs. q *s b)"
      by (simp add: sum_list_distinct_conv_sum_set[OF *] set_zip_map1 p comm_monoid_add_class.sum.reindex[OF inj])
    also have "... = (\<Sum>(q, b)\<leftarrow>(filter (\<lambda>(q, b). q \<noteq> 0) ?zs). q *s b)"
      by (rule monoid_add_class.sum_list_map_filter[symmetric], auto)
    also have "... = (\<Sum>(q, b)\<leftarrow>(filter (\<lambda>(q, b). q \<noteq> 0) (zip ?qs bs)). q *s b)"
      by (simp only: filter_zip_map_dup_const)
    also have "... = (\<Sum>(q, b)\<leftarrow>zip ?qs bs. q *s b)"
      by (rule monoid_add_class.sum_list_map_filter, auto)
    finally show "p = (\<Sum>(q, b)\<leftarrow>zip ?qs bs. q *s b)" .
  qed
qed

lemma span_listI: "sum_list (map2 (*s) qs bs) \<in> span (set bs)"
proof (induct qs arbitrary: bs)
  case Nil
  show ?case by (simp add: span_zero)
next
  case step: (Cons q qs)
  show ?case
  proof (simp add: zip_Cons1 span_zero split: list.split, intro allI impI)
    fix a as
    have "sum_list (map2 (*s) qs as) \<in> span (insert a (set as))" (is "?x \<in> ?A")
      by (rule, fact step, rule span_mono, auto)
    moreover have "a \<in> ?A" by (rule span_base) simp
    ultimately show "q *s a + ?x \<in> ?A" by (intro span_add span_scale)
  qed
qed

end

lemma (in term_powerprod) monomial_1_in_pmdlI:
  assumes "(f::_ \<Rightarrow>\<^sub>0 'b::field) \<in> pmdl F" and "keys f = {t}"
  shows "monomial 1 t \<in> pmdl F"
proof -
  define c where "c \<equiv> lookup f t"
  from assms(2) have f_eq: "f = monomial c t" unfolding c_def
    by (metis (mono_tags, lifting) Diff_insert_absorb cancel_comm_monoid_add_class.add_cancel_right_right
        plus_except insert_absorb insert_not_empty keys_eq_empty keys_except)
  from assms(2) have "c \<noteq> 0"
    unfolding c_def by auto
  hence "monomial 1 t = monom_mult (1 / c) 0 f" by (simp add: f_eq monom_mult_monomial term_simps)
  also from assms(1) have "... \<in> pmdl F" by (rule pmdl_closed_monom_mult)
  finally show ?thesis .
qed

subsection \<open>Ordered Polynomials\<close>

context ordered_term
begin

subsubsection \<open>Sets of Leading Terms and -Coefficients\<close>

definition lt_set :: "('t, 'b::zero) poly_mapping set \<Rightarrow> 't set" where
  "lt_set F = lt ` (F - {0})"

definition lc_set :: "('t, 'b::zero) poly_mapping set \<Rightarrow> 'b set" where
  "lc_set F = lc ` (F - {0})"

lemma lt_setI:
  assumes "f \<in> F" and "f \<noteq> 0"
  shows "lt f \<in> lt_set F"
  unfolding lt_set_def using assms by simp

lemma lt_setE:
  assumes "t \<in> lt_set F"
  obtains f where "f \<in> F" and "f \<noteq> 0" and "lt f = t"
  using assms unfolding lt_set_def by auto

lemma lt_set_iff:
  shows "t \<in> lt_set F \<longleftrightarrow> (\<exists>f\<in>F. f \<noteq> 0 \<and> lt f = t)"
  unfolding lt_set_def by auto

lemma lc_setI:
  assumes "f \<in> F" and "f \<noteq> 0"
  shows "lc f \<in> lc_set F"
  unfolding lc_set_def using assms by simp

lemma lc_setE:
  assumes "c \<in> lc_set F"
  obtains f where "f \<in> F" and "f \<noteq> 0" and "lc f = c"
  using assms unfolding lc_set_def by auto

lemma lc_set_iff:
  shows "c \<in> lc_set F \<longleftrightarrow> (\<exists>f\<in>F. f \<noteq> 0 \<and> lc f = c)"
  unfolding lc_set_def by auto

lemma lc_set_nonzero:
  shows "0 \<notin> lc_set F"
proof
  assume "0 \<in> lc_set F"
  then obtain f where "f \<in> F" and "f \<noteq> 0" and "lc f = 0" by (rule lc_setE)
  from \<open>f \<noteq> 0\<close> have "lc f \<noteq> 0" by (rule lc_not_0)
  from this \<open>lc f = 0\<close> show False ..
qed

lemma lt_sum_distinct_eq_Max:
  assumes "finite I" and "sum p I \<noteq> 0"
    and "\<And>i1 i2. i1 \<in> I \<Longrightarrow> i2 \<in> I \<Longrightarrow> p i1 \<noteq> 0 \<Longrightarrow> p i2 \<noteq> 0 \<Longrightarrow> lt (p i1) = lt (p i2) \<Longrightarrow> i1 = i2"
  shows "lt (sum p I) = ord_term_lin.Max (lt_set (p ` I))"
proof -
  have "\<not> p ` I \<subseteq> {0}"
  proof
    assume "p ` I \<subseteq> {0}"
    hence "sum p I = 0" by (rule sum_poly_mapping_eq_zeroI)
    with assms(2) show False ..
  qed
  from assms(1) this assms(3) show ?thesis
  proof (induct I)
    case empty
    from empty(1) show ?case by simp
  next
    case (insert x I)
    show ?case
    proof (cases "p ` I \<subseteq> {0}")
      case True
      hence "p ` I - {0} = {}" by simp
      have "p x \<noteq> 0"
      proof
        assume "p x = 0"
        with True have " p ` insert x I \<subseteq> {0}" by simp
        with insert(4) show False ..
      qed
      hence "insert (p x) (p ` I) - {0} = insert (p x) (p ` I - {0})" by auto
      hence "lt_set (p ` insert x I) = {lt (p x)}" by (simp add: lt_set_def \<open>p ` I - {0} = {}\<close>)
      hence eq1: "ord_term_lin.Max (lt_set (p ` insert x I)) = lt (p x)" by simp
      have eq2: "sum p I = 0"
      proof (rule ccontr)
        assume "sum p I \<noteq> 0"
        then obtain y where "y \<in> I" and "p y \<noteq> 0" by (rule sum.not_neutral_contains_not_neutral)
        with True show False by auto
      qed
      show ?thesis by (simp only: eq1 sum.insert[OF insert(1) insert(2)], simp add: eq2)
    next
      case False
      hence IH: "lt (sum p I) = ord_term_lin.Max (lt_set (p ` I))"
      proof (rule insert(3))
        fix i1 i2
        assume "i1 \<in> I" and "i2 \<in> I"
        hence "i1 \<in> insert x I" and "i2 \<in> insert x I" by simp_all
        moreover assume "p i1 \<noteq> 0" and "p i2 \<noteq> 0" and "lt (p i1) = lt (p i2)"
        ultimately show "i1 = i2" by (rule insert(5))
      qed
      show ?thesis
      proof (cases "p x = 0")
        case True
        hence eq: "lt_set (p ` insert x I) = lt_set (p ` I)" by (simp add: lt_set_def)
        show ?thesis by (simp only: eq, simp add: sum.insert[OF insert(1) insert(2)] True, fact IH)
      next
        case False
        hence eq1: "lt_set (p ` insert x I) = insert (lt (p x)) (lt_set (p ` I))"
          by (auto simp add: lt_set_def)
        from insert(1) have "finite (lt_set (p ` I))" by (simp add: lt_set_def)
        moreover from \<open>\<not> p ` I \<subseteq> {0}\<close> have "lt_set (p ` I) \<noteq> {}" by (simp add: lt_set_def)
        ultimately have eq2: "ord_term_lin.Max (insert (lt (p x)) (lt_set (p ` I))) =
                          ord_term_lin.max (lt (p x)) (ord_term_lin.Max (lt_set (p ` I)))"
          by (rule ord_term_lin.Max_insert)
        show ?thesis
        proof (simp only: eq1, simp add: sum.insert[OF insert(1) insert(2)] eq2 IH[symmetric],
            rule lt_plus_distinct_eq_max, rule)
          assume *: "lt (p x) = lt (sum p I)"
          have "lt (p x) \<in> lt_set (p ` I)" by (simp only: * IH, rule ord_term_lin.Max_in, fact+)
          then obtain f where "f \<in> p ` I" and "f \<noteq> 0" and ltf: "lt f = lt (p x)" by (rule lt_setE)
          from this(1) obtain y where "y \<in> I" and "f = p y" ..
          from this(2) \<open>f \<noteq> 0\<close> ltf have "p y \<noteq> 0" and lt_eq: "lt (p y) = lt (p x)" by simp_all
          from _ _ this(1) \<open>p x \<noteq> 0\<close> this(2) have "y = x"
          proof (rule insert(5))
            from \<open>y \<in> I\<close> show "y \<in> insert x I" by simp
          next
            show "x \<in> insert x I" by simp
          qed
          with \<open>y \<in> I\<close> have "x \<in> I" by simp
          with \<open>x \<notin> I\<close> show False ..
        qed
      qed
    qed
  qed
qed

lemma lt_sum_distinct_in_lt_set:
  assumes "finite I" and "sum p I \<noteq> 0"
    and "\<And>i1 i2. i1 \<in> I \<Longrightarrow> i2 \<in> I \<Longrightarrow> p i1 \<noteq> 0 \<Longrightarrow> p i2 \<noteq> 0 \<Longrightarrow> lt (p i1) = lt (p i2) \<Longrightarrow> i1 = i2"
  shows "lt (sum p I) \<in> lt_set (p ` I)"
proof -
  have "\<not> p ` I \<subseteq> {0}"
  proof
    assume "p ` I \<subseteq> {0}"
    hence "sum p I = 0" by (rule sum_poly_mapping_eq_zeroI)
    with assms(2) show False ..
  qed
  have "lt (sum p I) = ord_term_lin.Max (lt_set (p ` I))"
    by (rule lt_sum_distinct_eq_Max, fact+)
  also have "... \<in> lt_set (p ` I)"
  proof (rule ord_term_lin.Max_in)
    from assms(1) show "finite (lt_set (p ` I))" by (simp add: lt_set_def)
  next
    from \<open>\<not> p ` I \<subseteq> {0}\<close> show "lt_set (p ` I) \<noteq> {}" by (simp add: lt_set_def)
  qed
  finally show ?thesis .
qed

subsubsection \<open>Monicity\<close>

definition monic :: "('t \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('t \<Rightarrow>\<^sub>0 'b::field)" where
  "monic p = monom_mult (1 / lc p) 0 p"

definition is_monic_set :: "('t \<Rightarrow>\<^sub>0 'b::field) set \<Rightarrow> bool" where
  "is_monic_set B \<equiv> (\<forall>b\<in>B. b \<noteq> 0 \<longrightarrow> lc b = 1)"

lemma lookup_monic: "lookup (monic p) v = (lookup p v) / lc p"
proof -
  have "lookup (monic p) (0 \<oplus> v) = (1 / lc p) * (lookup p v)" unfolding monic_def
    by (rule lookup_monom_mult_plus)
  thus ?thesis by (simp add: term_simps)
qed

lemma lookup_monic_lt:
  assumes "p \<noteq> 0"
  shows "lookup (monic p) (lt p) = 1"
  unfolding monic_def
proof -
  from assms have "lc p \<noteq> 0" by (rule lc_not_0)
  hence "1 / lc p \<noteq> 0" by simp
  let ?q = "monom_mult (1 / lc p) 0 p"
  have "lookup ?q (0 \<oplus> lt p) = (1 / lc p) * (lookup p (lt p))" by (rule lookup_monom_mult_plus)
  also have "... = (1 / lc p) * lc p" unfolding lc_def ..
  also have "... = 1" using \<open>lc p \<noteq> 0\<close> by simp
  finally have "lookup ?q (0 \<oplus> lt p) = 1" .
  thus "lookup ?q (lt p) = 1" by (simp add: term_simps)
qed

lemma monic_0 [simp]: "monic 0 = 0"
  unfolding monic_def by (rule monom_mult_zero_right)

lemma monic_0_iff: "(monic p = 0) \<longleftrightarrow> (p = 0)"
proof
  assume "monic p = 0"
  show "p = 0"
  proof (rule ccontr)
    assume "p \<noteq> 0"
    hence "lookup (monic p) (lt p) = 1" by (rule lookup_monic_lt)
    with \<open>monic p = 0\<close> have "lookup 0 (lt p) = (1::'b)" by simp
    thus False by simp
  qed
next
  assume p0: "p = 0"
  show "monic p = 0" unfolding p0 by (fact monic_0)
qed

lemma keys_monic [simp]: "keys (monic p) = keys p"
proof (cases "p = 0")
  case True
  show ?thesis unfolding True monic_0 ..
next
  case False
  hence "lc p \<noteq> 0" by (rule lc_not_0)
  show ?thesis by (rule set_eqI, simp add: in_keys_iff lookup_monic \<open>lc p \<noteq> 0\<close>)
qed

lemma lt_monic [simp]: "lt (monic p) = lt p"
proof (cases "p = 0")
  case True
  show ?thesis unfolding True monic_0 ..
next
  case False
  have "lt (monom_mult (1 / lc p) 0 p) = 0 \<oplus> lt p"
  proof (rule lt_monom_mult)
    from False have "lc p \<noteq> 0" by (rule lc_not_0)
    thus "1 / lc p \<noteq> 0" by simp
  qed fact
  thus ?thesis by (simp add: monic_def term_simps)
qed

lemma lc_monic:
  assumes "p \<noteq> 0"
  shows "lc (monic p) = 1"
  using assms by (simp add: lc_def lookup_monic_lt)

lemma mult_lc_monic:
  assumes "p \<noteq> 0"
  shows "monom_mult (lc p) 0 (monic p) = p" (is "?q = p")
proof (rule poly_mapping_eqI)
  fix v
  from assms have "lc p \<noteq> 0" by (rule lc_not_0)
  have "lookup ?q (0 \<oplus> v) = (lc p) * (lookup (monic p) v)" by (rule lookup_monom_mult_plus)
  also have "... = (lc p) * ((lookup p v) / lc p)" by (simp add: lookup_monic)
  also have "... = lookup p v" using \<open>lc p \<noteq> 0\<close> by simp
  finally show "lookup ?q v = lookup p v" by (simp add: term_simps)
qed

lemma is_monic_setI:
  assumes "\<And>b. b \<in> B \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> lc b = 1"
  shows "is_monic_set B"
  unfolding is_monic_set_def using assms by auto

lemma is_monic_setD:
  assumes "is_monic_set B" and "b \<in> B" and "b \<noteq> 0"
  shows "lc b = 1"
  using assms unfolding is_monic_set_def by auto

lemma Keys_image_monic [simp]: "Keys (monic ` A) = Keys A"
  by (simp add: Keys_def)

lemma image_monic_is_monic_set: "is_monic_set (monic ` A)"
proof (rule is_monic_setI)
  fix p
  assume pin: "p \<in> monic ` A" and "p \<noteq> 0"
  from pin obtain p' where p_def: "p = monic p'" and "p' \<in> A" ..
  from \<open>p \<noteq> 0\<close> have "p' \<noteq> 0" unfolding p_def monic_0_iff .
  thus "lc p = 1" unfolding p_def by (rule lc_monic)
qed

lemma pmdl_image_monic [simp]: "pmdl (monic ` B) = pmdl B"
proof
  show "pmdl (monic ` B) \<subseteq> pmdl B"
  proof
    fix p
    assume "p \<in> pmdl (monic ` B)"
    thus "p \<in> pmdl B"
    proof (induct p rule: pmdl_induct)
      case base: module_0
      show ?case by (fact pmdl.span_zero)
    next
      case ind: (module_plus a b c t)
      from ind(3) obtain b' where b_def: "b = monic b'" and "b' \<in> B" ..
      have eq: "b = monom_mult (1 / lc b') 0 b'" by (simp only: b_def monic_def)
      show ?case unfolding eq monom_mult_assoc
        by (rule pmdl.span_add, fact, rule monom_mult_in_pmdl, fact)
    qed
  qed
next
  show "pmdl B \<subseteq> pmdl (monic ` B)"
  proof
    fix p
    assume "p \<in> pmdl B"
    thus "p \<in> pmdl (monic ` B)"
    proof (induct p rule: pmdl_induct)
      case base: module_0
      show ?case by (fact pmdl.span_zero)
    next
      case ind: (module_plus a b c t)
      show ?case
      proof (cases "b = 0")
        case True
        from ind(2) show ?thesis by (simp add: True)
      next
        case False
        let ?b = "monic b"
        from ind(3) have "?b \<in> monic ` B" by (rule imageI)
        have "a + monom_mult c t (monom_mult (lc b) 0 ?b) \<in> pmdl (monic ` B)"
          unfolding monom_mult_assoc
          by (rule pmdl.span_add, fact, rule monom_mult_in_pmdl, fact)
        thus ?thesis unfolding mult_lc_monic[OF False] .
      qed
    qed
  qed
qed

end (* ordered_term *)

end (* theory *)