(*
Auction Theory Toolbox (http://formare.github.io/auctions/)

Authors:
* Marco B. Caminati http://caminati.co.nr
* Manfred Kerber <mnfrd.krbr@gmail.com>
* Christoph Lange <math.semantic.web@gmail.com>
* Colin Rowat <c.rowat@bham.ac.uk>

Dually licenced under
* Creative Commons Attribution (CC-BY) 3.0
* ISC License (1-clause BSD License)
See LICENSE file for details
(Rationale for this dual licence: http://arxiv.org/abs/1107.3212)
*)

section \<open>Toolbox of various definitions and theorems about sets, relations and lists\<close>

theory MiscTools

imports
"HOL-Library.Discrete"
"HOL-Library.Code_Target_Nat"
"HOL-Library.Indicator_Function"
Argmax
RelationProperties

begin

lemmas restrict_def = RelationOperators.restrict_def

subsection \<open>Facts and notations about relations, sets and functions.\<close>

(* We use as alternative notation for paste instead of +* also +< and overload this with the next definition *)
notation paste (infix "+<" 75)

text \<open>\<open>+<\<close> abbreviation permits to shorten the notation for altering a function f in a single point by giving a pair (a, b) so that the new function has value b with argument a.\<close>

abbreviation singlepaste
  where "singlepaste f pair == f +* {(fst pair, snd pair)}"
  notation singlepaste (infix "+<" 75)
(* Type of g in f +< g should avoid ambiguities *)

text \<open>\<open>--\<close> abbreviation permits to shorten the notation for considering a function outside a single point.\<close>

abbreviation singleoutside (infix "--" 75)
  where "f -- x \<equiv> f outside {x}"

text \<open>Turns a HOL function into a set-theoretical function\<close>

definition (*Graph :: "('a => 'b) => ('a \<times> 'b) set" where *)
  "Graph f = {(x, f x) | x . True}"

text \<open>Inverts @{term Graph} (which is equivalently done by @{term eval_rel}).\<close>
(* Assume (x, y) is in R. Apply R to x, i.e., R ,, x,  will result in y assumed y is unique. *)

definition
  "toFunction R = (\<lambda> x . (R ,, x))"

(* toFunction = eval_rel *)
lemma
  "toFunction = eval_rel"
  using toFunction_def by blast

lemma lm001:
  "((P \<union> Q) || X) = ((P || X) \<union> (Q||X))"
  unfolding restrict_def by blast

text \<open>update behaves like P +* Q (paste), but without enlarging P's Domain. update is the set theoretic equivalent of the lambda function update @{term fun_upd}\<close>

definition update
  where "update P Q = P +* (Q || (Domain P))"
  notation update (infix "+^" 75)

(* The operator runiqer will make out of an arbitrary relation a function by making a choice to all those elements in the domain for which the value is not unique by applying the axiom of choice. *)
definition runiqer  :: "('a \<times> 'b) set => ('a \<times> 'b) set"
  where "runiqer R = { (x, THE y. y \<in> R `` {x})| x. x \<in> Domain R }"

text \<open>@{term graph} is like @{term Graph}, but with a built-in restriction to a given set @{term X}.
This makes it computable for finite X, whereas @{term "Graph f || X"} is not computable.
Duplicates the eponymous definition found in \<open>Function_Order\<close>, which is otherwise not needed.\<close>

definition graph
  where "graph X f = {(x, f x) | x. x \<in> X}"

lemma lm002:
  assumes "runiq R"
  shows "R \<supseteq> graph (Domain R) (toFunction R)"
  unfolding graph_def toFunction_def
  using assms graph_def toFunction_def eval_runiq_rel by fastforce

lemma lm003:
  assumes "runiq R"
  shows "R \<subseteq> graph (Domain R) (toFunction R)"
  unfolding graph_def toFunction_def
  using assms eval_runiq_rel runiq_basic Domain.DomainI mem_Collect_eq subrelI by fastforce

lemma lm004:
  assumes "runiq R"
  shows "R = graph (Domain R) (toFunction R)"
  using assms lm002 lm003 by fast

lemma domainOfGraph:
  "runiq(graph X f) & Domain(graph X f)=X"
  unfolding graph_def
  using rightUniqueRestrictedGraph by fast

(* The following definition gives the image of a relation R for a fixed element x. It is equivalent to eval_rel for right unique R, but more general since it determines values even when R is not right unique. *)
abbreviation "eval_rel2 (R::('a \<times> ('b set)) set) (x::'a) == \<Union> (R``{x})"
  notation eval_rel2 (infix ",,," 75)

lemma imageEquivalence:
  assumes "runiq (f::(('a \<times> ('b set)) set))" "x \<in> Domain f"
  shows "f,,x = f,,,x"
  using assms Image_runiq_eq_eval cSup_singleton by metis

(* UNIV is the universal set containing everything of the given type. It is defined in Set.thy.*)
lemma lm005:
  "Graph f=graph UNIV f"
  unfolding Graph_def graph_def by simp

lemma graphIntersection:
  "graph (X \<inter> Y) f \<subseteq> ((graph X f) || Y)"
  unfolding graph_def
  using Int_iff mem_Collect_eq RelationOperators.restrict_ext subrelI by auto

definition runiqs
  where "runiqs={f. runiq f}"

lemma outsideOutside:
  "((P outside X) outside Y) = P outside (X\<union>Y)"
  unfolding Outside_def by blast

corollary lm006:
  "((P outside X) outside X) = P outside X"
  using outsideOutside by force

lemma lm007:
  assumes "(X \<inter> Domain P) \<subseteq> Domain Q"
  shows "P +* Q = (P outside X) +* Q"
  unfolding paste_def Outside_def using assms by blast

corollary lm008:
  "P +* Q = (P outside (Domain Q)) +* Q"
  using lm007 by fast

corollary outsideUnion:
  "R = (R outside {x}) \<union> ({x} \<times> (R `` {x}))"
  using restrict_to_singleton outside_union_restrict by metis

lemma lm009:
  "P = P \<union> {x}\<times>P``{x}"
  by (metis outsideUnion sup.right_idem)

corollary lm010:
  "R = (R outside {x}) +* ({x} \<times> (R `` {x}))"
  by (metis paste_outside_restrict restrict_to_singleton)

lemma lm011:
  "R \<subseteq> R +* ({x} \<times> (R``{x}))"
  using lm010 lm008 paste_def Outside_def by fast

lemma lm012:
  "R \<supseteq> R+*({x} \<times> (R``{x}))"
  by (metis Un_least Un_upper1 outside_union_restrict paste_def
            restrict_to_singleton restriction_is_subrel)

lemma lm013:
  "R = R +* ({x} \<times> (R``{x}))"
  using lm011 lm012 by force

lemma rightUniqueTrivialCartes:
  assumes "trivial Y"
  shows "runiq (X \<times> Y)"
  using assms runiq_def Image_subset lm013 trivial_subset lm011 by (metis(no_types))

(* Two constant functions can be combined to a function *)
lemma lm014:
  "runiq ((X \<times> {x}) +* (Y \<times> {y}))"
  using rightUniqueTrivialCartes trivial_singleton runiq_paste2 by metis

lemma lm015:
  "(P || (X \<inter> Y)) \<subseteq> (P||X)    &    P outside (X \<union> Y) \<subseteq> P outside X"
  by (metis doubleRestriction le_sup_iff outsideOutside outside_union_restrict subset_refl)

lemma lm016:
  "P || X \<subseteq> (P||(X \<union> Y))       &    P outside X \<subseteq> P outside (X \<inter> Y)"
  using lm015 distrib_sup_le sup_idem le_inf_iff subset_antisym sup_commute
  by (metis sup_ge1)

lemma cardinalityOneSubset:
  assumes "card X=1" and "X \<subseteq> Y"
  shows "Union X \<in> Y"
  using assms cardinalityOneTheElemIdentity by (metis cSup_singleton insert_subset)

lemma cardinalityOneTheElem:
  assumes "card X=1" "X \<subseteq> Y"
  shows "the_elem X \<in> Y"
  using assms by (metis (full_types) insert_subset cardinalityOneTheElemIdentity)

lemma lm018:
  "(R outside X1) outside X2 = (R outside X2) outside X1"
  by (metis outsideOutside sup_commute)

subsection \<open>Ordered relations\<close>

(* note that card \<^bold>X\<ge>1 means in Isabelle that X is finite and not empty *)
lemma lm019:
  assumes "card X\<ge>1" "\<forall>x\<in>X. y > x"
  shows "y > Max X"
  using assms by (metis (poly_guards_query) Max_in One_nat_def card_eq_0_iff lessI not_le)

(* assume the function f has a maximum in mx *)
lemma lm020:
  assumes "finite X" "mx \<in> X" "f x < f mx"
  shows"x \<notin> argmax f X"
  using assms not_less by fastforce

lemma lm021:
  assumes "finite X" "mx \<in> X" "\<forall>x \<in> X-{mx}. f x < f mx"
  shows "argmax f X \<subseteq> {mx}"
  using assms mk_disjoint_insert by force

lemma lm022:
  assumes "finite X" "mx \<in> X" "\<forall>x \<in> X-{mx}. f x < f mx"
  shows "argmax f X = {mx}"
  using assms lm021 by (metis argmax_non_empty_iff equals0D subset_singletonD)

(* The following corollary is essentially the same as lm022, however, is simplifies a proof in UniformTieBreaking.thy *)
corollary argmaxProperty:
  "(finite X & mx \<in> X & (\<forall>aa \<in> X-{mx}. f aa < f mx)) \<longrightarrow> argmax f X = {mx}"
  using lm022 by metis

corollary lm023:
  assumes "finite X" "mx \<in> X" "\<forall>x \<in> X. x \<noteq> mx \<longrightarrow> f x < f mx"
  shows "argmax f X = {mx}"
  using assms lm022 by (metis Diff_iff insertI1)

lemma lm024:
  assumes "f \<circ> g = id"
  shows "inj_on g UNIV" using assms
  by (metis inj_on_id inj_on_imageI2)

(* Note that Pow X is the powerset of X *)
lemma lm025:
  assumes "inj_on f X"
  shows "inj_on (image f) (Pow X)"
  using assms inj_on_image_eq_iff inj_onI PowD by (metis (mono_tags, lifting))

lemma injectionPowerset:
  assumes "inj_on f Y" "X \<subseteq> Y"
  shows "inj_on (image f) (Pow X)"
  using assms lm025 by (metis subset_inj_on)

(* the finest possible partition of X, e.g., X = {1, 2, 3} goes to {{1}, {2}, {3}}. *)
definition finestpart
  where "finestpart X = (%x. {x}) ` X"

lemma finestPart:
  "finestpart X = {{x}|x . x\<in>X}"
  unfolding finestpart_def by blast

lemma finestPartUnion:
  "X=\<Union> (finestpart X)"
  using finestPart by auto

lemma lm026:
  "Union \<circ> finestpart = id"
  using finestpart_def finestPartUnion by fastforce

lemma lm027:
  "inj_on Union (finestpart ` UNIV)"
  using lm026 by (metis inj_on_id inj_on_imageI)

lemma nonEqualitySetOfSets:
  assumes "X \<noteq> Y"
  shows "{{x}| x. x \<in> X} \<noteq> {{x}| x. x \<in> Y}"
  using assms by auto

corollary lm028:
  "inj_on finestpart UNIV"
  using nonEqualitySetOfSets finestPart by (metis (lifting, no_types) injI)

(* E.g. in the following example, with X = {{1}, {1,2}}, x can be {1} and {1,2} and Y is {{1}} and {{1},{2}}, that is, the lefthand and righthand sides evaluate to {{1},{2}} *)
lemma unionFinestPart:
  "{Y | Y. \<exists>x.((Y \<in> finestpart x) \<and> (x \<in> X))} = \<Union>(finestpart`X)"
  by auto

(* Now we specialize the previous lemma to the situation where X consists of a relation (that is is a set of pairs) *)
lemma rangeSetOfPairs:
  "Range {(fst pair, Y)| Y pair. Y \<in> finestpart (snd pair) & pair \<in> X} =
   {Y. \<exists>x. ((Y \<in> finestpart x) \<and> (x \<in> Range X))}"
  by auto

(* Further specialization to a singleton for Y *)
lemma setOfPairsEquality:
  "{(fst pair, {y})| y pair. y \<in> snd pair & pair \<in> X} =
   {(fst pair, Y)| Y pair. Y \<in> finestpart (snd pair) & pair \<in> X}"
  using finestpart_def by fastforce

lemma setOfPairs:
  "{(fst pair, {y})| y. y \<in>  snd pair} =
   {fst pair} \<times> {{y}| y. y \<in> snd pair}"
  by fastforce

lemma lm029:
  "x \<in> X = ({x} \<in> finestpart X)"
  using finestpart_def by force

lemma pairDifference:
  "{(x,X)}-{(x,Y)} = {x}\<times>({X}-{Y})"
  by blast

lemma lm030:
  assumes "\<Union> P = X"
  shows "P \<subseteq> Pow X"
  using assms by blast

lemma lm031:
  "argmax f {x} = {x}"
  by auto

lemma sortingSameSet:
  assumes "finite X"
  shows "set (sorted_list_of_set X) = X"
  using assms by simp

(* We assume for the next lemma that f has value in numbers, and sum f A is
   sum f(x) for x in A. *)
lemma lm032:
  assumes "finite A"
  shows "sum f A = sum f (A \<inter> B) + sum f (A - B)"
  using assms by (metis DiffD2 Int_iff Un_Diff_Int Un_commute finite_Un sum.union_inter_neutral)

corollary sumOutside:
  assumes "finite g"
  shows "sum f g = sum f (g outside X) + (sum f (g||X))"
  unfolding Outside_def restrict_def using assms add.commute inf_commute lm032 by (metis)

lemma lm033:
  assumes "(Domain P \<subseteq> Domain Q)"
  shows "(P +* Q) = Q"
  unfolding paste_def Outside_def using assms by fast

lemma lm034:
  assumes "(P +* Q=Q)"
  shows "(Domain P \<subseteq> Domain Q)"
  using assms paste_def Outside_def by blast

lemma lm035:
  "(Domain P \<subseteq> Domain Q) = (P +* Q=Q)"
  using lm033 lm034 by metis

lemma
  "(P||(Domain Q)) +* Q = Q"
  by (metis Int_lower2 restrictedDomain lm035)

lemma lm036:
  "P||X   =   P outside (Domain P - X)"
  using Outside_def restrict_def by fastforce

lemma lm037:
  "(P outside X) \<subseteq>    P || ((Domain P)-X)"
  using lm036 lm016 by (metis Int_commute restrictedDomain outside_reduces_domain)

lemma lm038:
  "Domain (P outside X) \<inter> Domain (Q || X) = {}"
  using lm036
  by (metis Diff_disjoint Domain_empty_iff Int_Diff inf_commute restrictedDomain
            outside_reduces_domain restrict_empty)

lemma lm039:
  "(P outside X) \<inter> (Q || X) = {}"
  using lm038 by fast

lemma lm040:
  "(P outside (X \<union> Y)) \<inter> (Q || X) = {}   &   (P outside X) \<inter> (Q || (X \<inter> Z)) = {}"
  using Outside_def restrict_def lm039 lm015 by fast

lemma lm041:
  "P outside X    =    P || ((Domain P) - X)"
  using Outside_def restrict_def lm037 by fast

lemma lm042:
  "R``(X-Y) = (R||X)``(X-Y)"
  using restrict_def by blast

(* x is a (non-empty) element of the family XX whose union is a subset of X *)
lemma lm043:
  assumes "\<Union> XX \<subseteq> X" "x \<in> XX" "x \<noteq> {}"
  shows "x \<inter> X \<noteq> {}"
  using assms by blast

(* Note that set converts lists such as L1 into sets. L1 is here a list of lists and l an element, that is, a list. We assume furthermore that f2 is constant function with the fixed 2nd argument N. Then we can convert lists to sets in a canonical way. *)
lemma lm044:
  assumes "\<forall>l \<in> set L1. set L2 = f2 (set l) N"
  shows "set [set L2. l <- L1]  =  {f2 P N| P. P \<in> set (map set L1)}"
  using assms by auto

(* Two Variants of the previous lemma *)
lemma setVsList:
  assumes "\<forall>l \<in> set (g1 G). set (g2 l N) = f2 (set l) N"
  shows "set [set (g2 l N). l <- (g1 G)]  =  {f2 P N| P. P \<in> set (map set (g1 G))}"
  using assms by auto

lemma lm045:
  "(\<forall>l \<in> set (g1 G). set (g2 l N) = f2 (set l) N) -->
     {f2 P N| P. P \<in> set (map set (g1 G))} = set [set (g2 l N). l <- g1 G]"
  by auto

lemma lm046:
  assumes "X \<inter> Y  =  {}"
  shows "R``X = (R outside Y)``X"
  using assms Outside_def Image_def by blast

lemma lm047:
  assumes "(Range P) \<inter> (Range Q) = {}" "runiq (P^-1)" "runiq (Q^-1)"
  shows "runiq ((P \<union> Q)^-1)"
  using assms by (metis Domain_converse converse_Un disj_Un_runiq)

lemma lm048:
  assumes "(Range P) \<inter> (Range Q) = {}" "runiq (P^-1)" "runiq (Q^-1)"
  shows "runiq ((P +* Q)^-1)"
  using lm047 assms subrel_runiq by (metis converse_converse converse_subset_swap paste_sub_Un)

lemma lm049:
  assumes "runiq R"
  shows "card (R `` {a}) = 1 \<longleftrightarrow> a \<in> Domain R"
  using assms card_Suc_eq One_nat_def
  by (metis Image_within_domain' Suc_neq_Zero assms rightUniqueSetCardinality)

(* triples a can be bracket in any way, i.e., (1st, (2nd, 3rd)) \<rightarrow> ((1st, 2nd), 3rd).*)
lemma lm050:
  "inj (\<lambda>a. ((fst a, fst (snd a)), snd (snd a)))"
  by (auto intro: injI)

lemma lm051:
  assumes "finite X" "x > Max X"
  shows "x \<notin> X"
  using assms Max.coboundedI by (metis leD)

lemma lm052:
  assumes "finite A" "A \<noteq> {}"
  shows "Max (f`A) \<in> f`A"
  using assms by (metis Max_in finite_imageI image_is_empty)

(* Note that in the following -` means the inverse image of the following set. *)
lemma lm053:
  "argmax f A \<subseteq> f -` {Max (f ` A)}"
  by force

lemma lm054:
  "argmax f A = A \<inter> { x . f x = Max (f ` A) }"
  by auto

lemma lm055:
  "(x \<in> argmax f X) = (x \<in> X & f x = Max (f ` X))"
  using argmax.simps mem_Collect_eq by (metis (mono_tags, lifting))

lemma rangeEmpty:
  "Range -` {{}} = {{}}"
  by auto

lemma finitePairSecondRange:
  "(\<forall> pair \<in> R. finite (snd pair)) = (\<forall> y \<in> Range R. finite y)"
  by fastforce

lemma lm056:
  "fst ` P = snd ` (P^-1)"
  by force

lemma lm057:
  "fst pair = snd (flip pair) & snd pair = fst (flip pair)"
  unfolding flip_def by simp

lemma flip_flip2:
  "flip \<circ> flip   =   id"
  using flip_flip by fastforce

lemma lm058:
  "fst = (snd\<circ>flip)"
  using lm057 by fastforce

lemma lm059:
  "snd = (fst\<circ>flip)"
  using lm057 by fastforce

lemma lm060:
  "inj_on fst P = inj_on (snd\<circ>flip) P"
  using lm058 by metis

lemma lm062:
  "inj_on fst P = inj_on snd (P^-1)"
  using lm060 flip_conv by (metis converse_converse inj_on_imageI lm059)

lemma sumPairsInverse:
  assumes "runiq (P^-1)"
  shows "sum (f \<circ> snd) P = sum f (Range P)"
  using assms lm062 converse_converse rightUniqueInjectiveOnFirst rightUniqueInjectiveOnFirst
        sum.reindex snd_eq_Range
  by metis

lemma notEmptyFinestpart:
  assumes "X \<noteq> {}"
  shows "finestpart X \<noteq> {}"
  using assms finestpart_def by blast

lemma lm063:
  assumes "inj_on g X"
  shows "sum f (g`X) = sum (f \<circ> g) X"
  using assms by (metis sum.reindex)

lemma functionOnFirstEqualsSecond:
  assumes "runiq R" "z \<in> R"
  shows "R,,(fst z) = snd z"
  using assms by (metis rightUniquePair surjective_pairing)

lemma lm064:
  assumes "runiq R"
  shows "sum (toFunction R) (Domain R) = sum snd R"
  using assms toFunction_def sum.reindex_cong functionOnFirstEqualsSecond
        rightUniqueInjectiveOnFirst
  by (metis (no_types) fst_eq_Domain)

corollary lm065:
  assumes "runiq (f||X)"
  shows "sum (toFunction (f||X)) (X \<inter> Domain f) = sum snd (f||X)"
  using assms lm064 by (metis Int_commute restrictedDomain)

lemma lm066:
  "Range (R outside X) = R``((Domain R) - X)"
  by (metis Diff_idemp ImageE Range.intros Range_outside_sub_Image_Domain lm041
            lm042 order_class.order.antisym subsetI)

lemma lm067:
  "(R||X) `` X = R``X"
  using Int_absorb doubleRestriction restrictedRange by metis

lemma lm068:
  assumes "x \<in> Domain (f||X)"
  shows "(f||X)``{x} = f``{x}"
  using assms doubleRestriction restrictedRange Int_empty_right Int_iff
        Int_insert_right_if1 restrictedDomain
  by metis

lemma lm069:
  assumes "x \<in> X \<inter> Domain f" "runiq (f||X)"
  shows "(f||X),,x = f,,x"
  using assms doubleRestriction restrictedRange Int_empty_right Int_iff Int_insert_right_if1
        eval_rel.simps
  by metis

lemma lm070:
  assumes "runiq (f||X)"
  shows "sum (toFunction (f||X)) (X \<inter> Domain f) = sum (toFunction f) (X \<inter> Domain f)"
  using assms sum.cong lm069 toFunction_def by metis

corollary sumRestrictedToDomainInvariant:
  assumes "runiq (f||X)"
  shows "sum (toFunction f) (X \<inter> Domain f) = sum snd (f||X)"
  using assms lm065 lm070 by fastforce

corollary sumRestrictedOnFunction:
  assumes "runiq (f||X)"
  shows "sum (toFunction (f||X)) (X \<inter> Domain f) = sum snd (f||X)"
  using assms lm064 restrictedDomain Int_commute by metis

lemma cardFinestpart:
  "card (finestpart X) = card X"
  using finestpart_def by (metis (lifting) card_image inj_on_inverseI the_elem_eq)

corollary lm071:
  "finestpart {} = {}    &    card \<circ> finestpart = card"
  using cardFinestpart finestpart_def by fastforce

lemma finiteFinestpart:
  "finite (finestpart X) = finite X"
  using finestpart_def lm071
  by (metis card_eq_0_iff empty_is_image finite.simps cardFinestpart)

lemma lm072:
  "finite \<circ> finestpart = finite"
  using finiteFinestpart by fastforce

lemma finestpartSubset:
  assumes "X \<subseteq> Y"
  shows "finestpart X \<subseteq> finestpart Y"
  using assms finestpart_def by (metis image_mono)

corollary lm073:
  assumes "x \<in> X"
  shows "finestpart x \<subseteq> finestpart (\<Union> X)"
  using assms finestpartSubset by (metis Union_upper)

lemma lm074:
  "\<Union> (finestpart ` XX) \<subseteq> finestpart (\<Union> XX)"
  using finestpart_def lm073 by force

lemma lm075:
  "\<Union> (finestpart ` XX) \<supseteq> finestpart (\<Union> XX)"
  (is "?L \<supseteq> ?R")
  unfolding finestpart_def using finestpart_def by auto

corollary commuteUnionFinestpart:
  "\<Union> (finestpart ` XX) = finestpart (\<Union> XX)"
  using lm074 lm075 by fast

lemma unionImage:
  assumes "runiq a"
  shows "{(x, {y})| x y. y \<in> \<Union> (a``{x}) & x \<in> Domain a} =
         {(x, {y})| x y. y \<in> a,,x & x \<in> Domain a}"
  using assms Image_runiq_eq_eval
  by (metis (lifting, no_types) cSup_singleton)

lemma lm076:
  assumes "runiq P"
  shows "card (Domain P) = card P"
  using assms rightUniqueInjectiveOnFirst card_image by (metis Domain_fst)

lemma finiteDomainImpliesFinite:
  assumes "runiq f"
  shows "finite (Domain f) = finite f"
  using assms Domain_empty_iff card_eq_0_iff finite.emptyI lm076 by metis

(* A relation for the sum of all y\<in>Y of f(x,y) for a fixed x. *)
lemma sumCurry:
  "sum ((curry f) x) Y = sum f ({x} \<times> Y)"
proof -
  let ?f="% y. (x, y)" let ?g="(curry f) x" let ?h=f
  have "inj_on ?f Y" by (metis(no_types) Pair_inject inj_onI)
  moreover have "{x} \<times> Y = ?f ` Y" by fast
  moreover have "\<forall> y. y \<in> Y \<longrightarrow> ?g y = ?h (?f y)" by simp
  ultimately show ?thesis using sum.reindex_cong by metis
qed

lemma lm077:
  "sum (%y. f (x,y)) Y = sum f ({x}\<times>Y)"
  using sumCurry Sigma_cong curry_def sum.cong by fastforce

corollary lm078:
  assumes "finite X"
  shows "sum f X = sum f (X-Y) + (sum f (X \<inter> Y))"
  using assms Diff_iff IntD2 Un_Diff_Int finite_Un inf_commute sum.union_inter_neutral
  by metis

lemma lm079:
  "(P +* Q)``(Domain Q\<inter>X)  =  Q``(Domain Q\<inter>X)"
  unfolding paste_def Outside_def Image_def Domain_def by blast

corollary lm080:
  "(P +* Q)``(X\<inter>(Domain Q))  =  Q``X"
  using Int_commute lm079 by (metis lm017)

corollary lm081:
  assumes "X \<inter> (Domain Q) = {}"
  shows "(P +* Q) `` X = (P outside (Domain Q))`` X"
  using assms paste_def by fast

lemma lm082:
  assumes "X\<inter>Y = {}"
  shows "(P outside Y)``X=P``X"
  using assms Outside_def by blast

corollary lm083:
  assumes "X\<inter> (Domain Q) = {}"
  shows "(P +* Q)``X=P``X"
  using assms lm081 lm082 by metis

lemma lm084:
  assumes "finite X" "finite Y" "card(X\<inter>Y) = card X"
  shows "X \<subseteq> Y"
  using assms by (metis Int_lower1 Int_lower2 card_seteq order_refl)

lemma cardinalityIntersectionEquality:
  assumes "finite X" "finite Y" "card X = card Y"
  shows "(card (X\<inter>Y) = card X)     =    (X = Y)"
  using assms lm084 by (metis card_seteq le_iff_inf order_refl)

lemma lm085: (*fixes f::"'a => 'b" fixes P::"'a => bool" fixes xx::"'a"*)
  assumes "P xx"
  shows "{(x,f x)| x. P x},,xx   =   f xx"
proof -
  let ?F="{(x,f x)| x. P x}" let ?X="?F``{xx}"
  have "?X={f xx}" using Image_def assms by blast thus ?thesis by fastforce
qed

lemma graphEqImage:
  assumes "x \<in> X"
  shows "graph X f,,x   =   f x"
  unfolding graph_def using assms lm085 by (metis (mono_tags) Gr_def)

lemma lm086:
  "Graph f,,x    =    f x"
  using UNIV_I graphEqImage lm005 by (metis(no_types))

lemma lm087:
  "toFunction (Graph f)    =    f"    (is "?L=_")
proof -
  {fix x have "?L x=f x" unfolding toFunction_def lm086 by metis}
  thus ?thesis by blast
qed

lemma lm088:
  "R outside X \<subseteq> R"
  by (metis outside_union_restrict subset_Un_eq sup_left_idem)

lemma lm089:
  "Range(f outside X) \<supseteq> (Range f)-(f``X)"
  using Outside_def by blast

lemma lm090:
  assumes "runiq P"
  shows "(P\<inverse>``((Range P)-Y)) \<inter> ((P\<inverse>)``Y)   =   {}"
  using assms rightUniqueFunctionAfterInverse by blast

lemma lm092:
  assumes "runiq f" "runiq (f^-1)"
  shows "Range(f outside X) \<subseteq> (Range f)-(f``X)"
  using assms Diff_triv lm091 lm066 Diff_iff ImageE Range_iff subsetI by metis

lemma rangeOutside:
  assumes "runiq f" "runiq (f^-1)"
  shows "Range(f outside X) = (Range f)-(f``X)"
  using assms lm089 lm092 by (metis order_class.order.antisym)

(* X and Y are family of sets such that any x and y in X and Y resp. are disjoint. *)
lemma unionIntersectionEmpty:
  "(\<forall>x\<in>X. \<forall>y\<in>Y. x\<inter>y = {}) = ((\<Union>X)\<inter>(\<Union> Y)={})"
  by blast

lemma setEqualityAsDifference:
  "{x}-{y} = {}  =  (x = y)"
  by auto

lemma lm093:
  assumes "R \<noteq> {}" "Domain R \<inter> X \<noteq> {}"
  shows "R``X \<noteq> {}"
  using assms by blast

lemma lm095:
  "R \<subseteq> (Domain R) \<times> (Range R)"
  by auto

lemma finiteRelationCharacterization:
  "(finite (Domain Q) & finite (Range Q)) = finite Q"
  using rev_finite_subset finite_SigmaI lm095 finite_Domain finite_Range by metis

lemma familyUnionFiniteEverySetFinite:
  assumes "finite (\<Union> XX)"
  shows "\<forall>X \<in> XX. finite X"
  using assms by (metis Union_upper finite_subset)

lemma lm096:
  assumes "runiq f" "X \<subseteq> (f^-1)``Y"
  shows "f``X \<subseteq> Y"
  using assms rightUniqueFunctionAfterInverse by (metis Image_mono order_refl subset_trans)

lemma lm097:
  assumes "y \<in> f``{x}" "runiq f"
  shows "f,,x = y"
  using assms by (metis Image_singleton_iff rightUniquePair)

subsection \<open>Indicator function in set-theoretical form.\<close>

abbreviation
  "Outside' X f == f outside X"

abbreviation
  "Chi X Y == (Y \<times> {0::nat}) +* (X \<times> {1})"
  notation Chi (infix "<||" 80)

abbreviation
  "chii X Y == toFunction (X <|| Y)"
  notation chii (infix "<|" 80)

(* X is a set and chi X is a function that returns 1 for elements X and 0 else. *)
abbreviation
  "chi X == indicator X"

lemma lm098:
  "runiq (X <|| Y)"
  by (rule lm014)

lemma lm099:
  assumes "x \<in> X"
  shows "1 \<in> (X <|| Y) `` {x}"
  using assms toFunction_def paste_def Outside_def runiq_def lm014 by blast

lemma lm100:
  assumes "x \<in> Y-X"
  shows "0 \<in> (X <|| Y) `` {x}"
  using assms toFunction_def paste_def Outside_def runiq_def lm014 by blast

lemma lm101:
  assumes "x \<in> X \<union> Y"
  shows "(X <|| Y),,x = chi X x" (is "?L=?R")
  using assms lm014 lm099 lm100 lm097
  by (metis DiffI Un_iff indicator_simps(1) indicator_simps(2))

lemma lm102:
  assumes "x \<in> X \<union> Y"
  shows "(X <| Y) x = chi X x"
  using assms toFunction_def lm101 by metis

corollary lm103:
  "sum (X <| Y) (X\<union>Y) = sum (chi X) (X\<union>Y)"
  using lm102 sum.cong by metis

corollary lm104:
  assumes "\<forall>x\<in>X. f x = g x"
  shows "sum f X = sum g X"
  using assms by (metis (poly_guards_query) sum.cong)

corollary lm105:
  assumes "\<forall>x\<in>X. f x = g x" "Y\<subseteq>X"
  shows "sum f Y = sum g Y"
  using assms lm104 by (metis contra_subsetD)

corollary lm106:
  assumes "Z \<subseteq> X \<union> Y"
  shows "sum (X <| Y) Z = sum (chi X) Z"
proof -
  have "\<forall>x\<in>Z.(X<|Y) x=(chi X) x" using assms lm102 in_mono by metis
  thus ?thesis using lm104 by blast
qed

corollary lm107:
  "sum (chi X) (Z - X) = 0"
  by simp

corollary lm108:
  assumes "Z \<subseteq> X \<union> Y"
  shows "sum (X <| Y) (Z - X) = 0"
  using assms lm107 lm106 Diff_iff in_mono subsetI by metis

corollary lm109:
  assumes "finite Z"
  shows "sum (X <| Y) Z    =    sum (X <| Y) (Z - X)   +  (sum (X <| Y) (Z \<inter> X))"
  using lm078 assms by blast

corollary lm110:
  assumes "Z \<subseteq> X \<union> Y" "finite Z"
  shows "sum (X <| Y) Z = sum (X <| Y) (Z \<inter> X)"
  using assms lm078 lm108 comm_monoid_add_class.add_0 by metis

corollary lm111:
  assumes "finite Z"
  shows "sum (chi X) Z = card (X \<inter> Z)"
  using assms sum_indicator_eq_card by (metis Int_commute)

corollary lm112:
  assumes "Z \<subseteq> X \<union> Y" "finite Z"
  shows "sum (X <| Y) Z = card (Z \<inter> X)"
  using assms lm111 by (metis lm106 sum_indicator_eq_card)

corollary subsetCardinality:
  assumes "Z \<subseteq> X \<union> Y" "finite Z"
  shows "(sum (X <| Y) X) - (sum (X <| Y) Z) = card X - card (Z \<inter> X)"
  using assms lm112 by (metis Int_absorb2 Un_upper1 card.infinite equalityE sum.infinite)

corollary differenceSumVsCardinality:
  assumes "Z \<subseteq> X \<union> Y" "finite Z"
  shows "int (sum (X <| Y) X) - int (sum (X <| Y) Z) =  int (card X) - int (card (Z \<inter> X))"
  using assms lm112 by (metis Int_absorb2 Un_upper1 card.infinite equalityE sum.infinite)

(* type conversion in Isabelle *)
lemma lm113:
  "int (n::nat) = real n"
  by simp

(* same as differenceSumVsCardinality but for type real *)
corollary differenceSumVsCardinalityReal:
  assumes "Z\<subseteq>X\<union>Y" "finite Z"
  shows "real (sum (X <| Y) X) - real (sum (X <| Y) Z) =
         real (card X) - real (card (Z \<inter> X))"
  using assms lm112 by (metis Int_absorb2 Un_upper1 card.infinite equalityE sum.infinite)

subsection \<open>Lists\<close>
(* If there is an element in a list satisfying P, then the list of all elements satisfying P is not the empty list *)

(* Assume ll is an element of list l, then there is an index n such that the n-th entry of l is ll. *)
lemma lm115:
  assumes "ll \<in> set (l::'a list)"
  shows "\<exists> n\<in> (nth l) -` (set l). ll=l!n"
  using assms(1) by (metis in_set_conv_nth vimageI2)

(* variant of the above *)
lemma lm116:
  assumes "ll \<in> set (l::'a list)"
  shows "\<exists> n. ll=l!n & n < size l & n >= 0"
  using assms in_set_conv_nth by (metis le0)

(* another variant of the above *)
lemma lm117:
  assumes "P -` {True} \<inter> set l \<noteq> {}"
  shows "\<exists> n \<in> {0..<size l}. P (l!n)"
  using assms lm116 by fastforce

(* variant of lm114 *)
lemma nonEmptyListFiltered:
  assumes "P -` {True} \<inter> set l \<noteq> {}"
  shows "[n. n \<leftarrow> [0..<size l], P (l!n)] \<noteq> []"
  using assms filterpositions2_def lm117 lm114 by metis

(* take the elements of a list l which are also in a set X then this forms a subset of X intersection with the elements of the list *)
lemma lm118:
  "(nth l) ` set ([n. n \<leftarrow> [0..<size l], (%x. x\<in>X) (l!n)]) \<subseteq> X\<inter>set l"
  by force

(* variant of the above *)
corollary lm119:
  "(nth l)` set (filterpositions2 (%x.(x\<in>X)) l) \<subseteq> X \<inter>  set l"
  unfolding filterpositions2_def using lm118 by fast

lemma lm120:
  "(n\<in>{0..<N}) = ((n::nat) < N)"
  using atLeast0LessThan lessThan_iff by metis

(* If X is a set of indices then the corresponding elements combined are a subset of all the elements of the list. *)
lemma lm121:
  assumes "X \<subseteq> {0..<size list}"
  shows "(nth list)`X \<subseteq> set list"
  using assms atLeastLessThan_def atLeast0LessThan lessThan_iff by auto

(* The indices of the elements of a list satisfying a predicate P are a subset of all the indices. *)
lemma lm122:
  "set ([n. n \<leftarrow> [0..<size l], P (l!n)]) \<subseteq> {0..<size l}"
  by force

(* variant of the above *)
lemma lm123:
  "set (filterpositions2 pre list) \<subseteq> {0..<size list}"
  using filterpositions2_def lm122 by metis

subsection \<open>Computing all the permutations of a list\<close>
abbreviation
  "rotateLeft == rotate"
abbreviation
  "rotateRight n l == rotateLeft (size l - (n mod (size l))) l"

(* for n in {0, ..., size l} inserts x in l so that it will have index n in the output*)
(* note that for other n, the behaviour is not guaranteed to be consistent with that *)
abbreviation
  "insertAt x l n == rotateRight n (x#(rotateLeft n l))"

(* for n in {0,..., fact(size l) - 1 },
   perm2 l n gives all and only the possible permutations of l *)
fun perm2 where
  "perm2 [] = (%n. [])" |
  "perm2 (x#l) = (%n. insertAt x ((perm2 l) (n div (1+size l)))
                      (n mod (1+size l)))"

abbreviation
  "takeAll P list == map (nth list) (filterpositions2 P list)"

lemma permutationNotEmpty:
  assumes "l \<noteq> []"
  shows "perm2 l n \<noteq> []"
  using assms perm2.simps(2) rotate_is_Nil_conv by (metis neq_Nil_conv)

lemma lm124:
  "set (takeAll P list) = ((nth list) ` set (filterpositions2 P list))"
  by simp

corollary listIntersectionWithSet:
  "set (takeAll (%x.(x\<in>X)) l) \<subseteq>  (X \<inter> set l)"
  using lm119 lm124 by metis

corollary lm125:
  "set (takeAll P list) \<subseteq> set list"
  using lm123 lm124 lm121 by metis

lemma takeAllSubset:
  "set (takeAll (%x. x\<in> P) list) \<subseteq> P"
  by (metis Int_subset_iff listIntersectionWithSet)

lemma lm126:
  "set (insertAt x l n) = {x} \<union> set l"
  by simp

lemma lm127:
  "\<forall>n. set (perm2 [] n) = set []"
  by simp

lemma lm128:
  assumes "\<forall>n. (set (perm2 l n) = set l)"
  shows "set (perm2 (x#l) n) = {x} \<union> set l"
  using assms lm126 by force

(* Combining the previous two lemmas we get inductively that the set of elements in a permuted list are the same as the elements in the original list. This is weaker than saying (perm2 l n) is a permutation of l, but suffices for our purposes. *)
corollary permutationInvariance:
   "\<forall>n. set (perm2 (l::'a list) n) = set l"
proof (induct l)
   let ?P = "%l::('a list). (\<forall>n. set (perm2 l n)  =  set l)"
   show "?P []" using lm127 by force
   fix x fix l
   assume "?P l" then
   show "?P (x#l)" by force
qed

(* variant of listIntersectionWithSet with permutation added *)
corollary takeAllPermutation:
  "set (perm2 (takeAll (%x.(x\<in>X)) l) n)  \<subseteq>  X \<inter> set l"
  using listIntersectionWithSet permutationInvariance by metis

(* "subList list1 list2" extracts the components of list1 according to the indices given in list2, e.g.,  "subList [1::nat,2,3,4] [0,2]" gives [1,3] *)
abbreviation "subList l xl == map (nth l) (takeAll (%x. x \<le> size l) xl)"

subsection \<open>A more computable version of @{term toFunction}.\<close>

(* If R is a relation and the image of x is unique then take that, else take the fallback *)
abbreviation "toFunctionWithFallback R fallback ==
              (% x. if (R``{x} = {R,,x}) then (R,,x) else fallback)"
notation
  toFunctionWithFallback (infix "Else" 75)

abbreviation sum' where
  "sum' R X == sum (R Else 0) X"

lemma lm129:
  assumes "runiq f" "x \<in> Domain f"
  shows "(f Else 0) x = (toFunction f) x"
  using assms by (metis Image_runiq_eq_eval toFunction_def)

lemma lm130:
  assumes "runiq f"
  shows "sum (f Else 0) (X\<inter>(Domain f))  =  sum (toFunction f) (X\<inter>(Domain f))"
  using assms sum.cong lm129 by fastforce

lemma lm131:
  assumes "Y \<subseteq> f-`{0}"
  shows "sum f Y  =  0"
  using assms by (metis rev_subsetD sum.neutral vimage_singleton_eq)

lemma lm132:
  assumes "Y \<subseteq> f-`{0}" "finite X"
  shows "sum f X = sum f (X-Y)"
  using Int_lower2 add.comm_neutral assms(1) assms(2) lm078 lm131 order_trans
  by (metis (no_types))

(* - means the complement of a set. *)
lemma lm133:
  "-(Domain f) \<subseteq> (f Else 0)-`{0}"
  by fastforce

corollary lm134:
  assumes "finite X"
  shows "sum (f Else 0) X    =   sum (f Else 0) (X\<inter>Domain f)"
proof -
  have "X\<inter>Domain f=X-(-Domain f)" by simp
  thus ?thesis using assms lm133 lm132 by fastforce
qed

corollary lm135:
  assumes "finite X"
  shows "sum (f Else 0) (X\<inter>Domain f)   =   sum (f Else 0) X"
  (is "?L=?R")
proof -
  have "?R=?L" using assms by (rule lm134)
  thus ?thesis by simp
qed

corollary lm136:
  assumes "finite X" "runiq f"
  shows "sum (f Else 0) X = sum (toFunction f) (X\<inter>Domain f)"
  (is "?L=?R")
proof -
  have "?R = sum (f Else 0) (X\<inter>Domain f) " using assms(2) lm130 by fastforce
  moreover have "... = ?L" using assms(1) by (rule lm135)
  ultimately show ?thesis by presburger
qed

lemma lm137:
  "sum (f Else 0) X = sum' f X"
  by fast

corollary lm138:
  assumes "finite X" "runiq f"
  shows "sum (toFunction f) (X\<inter>Domain f)   =   sum' f X"
  using assms lm137 lm136 by fastforce

lemma lm139:
  "argmax (sum' b) = (argmax \<circ> sum') b"
  by simp

lemma domainConstant:
  "Domain (Y \<times> {0::nat}) = Y & Domain (X \<times> {1}) = X"
  by blast

lemma domainCharacteristicFunction:
  "Domain (X <|| Y) = X \<union> Y"
  using domainConstant paste_Domain sup_commute by metis

lemma functionEquivalenceOnSets:
  assumes "\<forall>x \<in> X. f x = g x"
  shows "f`X = g`X"
  using assms by (metis image_cong)

subsection \<open>Cardinalities of sets.\<close>
lemma lm140:
  assumes "runiq R" "runiq (R^-1)"
  shows "(R``A) \<inter> (R``B) = R``(A\<inter>B)"
  using assms rightUniqueInjectiveOnFirst converse_Image by force

lemma intersectionEmptyRelationIntersectionEmpty:
  assumes "runiq (R^-1)" "runiq R" "X1 \<inter> X2 = {}"
  shows "(R``X1) \<inter> (R``X2) = {}"
  using assms by (metis disj_Domain_imp_disj_Image inf_assoc inf_bot_right)

lemma lm141:
  assumes "runiq f" "trivial Y"
  shows "trivial (f `` (f^-1 `` Y))"
  using assms by (metis rightUniqueFunctionAfterInverse trivial_subset)

lemma lm142:
  assumes "trivial X"
  shows "card (Pow X)\<in>{1,2}"
  using trivial_empty_or_singleton card_Pow Pow_empty assms trivial_implies_finite
        cardinalityOneTheElemIdentity power_one_right the_elem_eq
  by (metis insert_iff)

lemma lm143:
  assumes "card (Pow A) = 1"
  shows "A = {}"
  using assms by (metis Pow_bottom Pow_top cardinalityOneTheElemIdentity singletonD)

(* Note that in Isabelle infinite sets have cardinality 0 *)
lemma lm144:
  "(\<not> (finite A)) = (card (Pow A) = 0)"
  by auto

corollary lm145:
  "(finite A) = (card (Pow A) \<noteq> 0)"
  using lm144 by metis

lemma lm146:
  assumes "card (Pow A) \<noteq> 0"
  shows "card A=Discrete.log (card (Pow A))"
  using assms log_exp card_Pow by (metis card.infinite finite_Pow_iff)

lemma log_2 [simp]:
  "Discrete.log 2 = 1"
  using log_exp [of 1] by simp

lemma lm147:
  assumes "card (Pow A) = 2"
  shows "card A = 1"
  using assms lm146 [of A] by simp

lemma lm148:
  assumes "card (Pow X) = 1 \<or> card (Pow X) = 2"
  shows "trivial X"
  using assms trivial_empty_or_singleton lm143 lm147 cardinalityOneTheElemIdentity by metis

lemma lm149:
  "trivial A = (card (Pow A) \<in> {1,2})"
  using lm148 lm142 by blast

lemma lm150:
  assumes "R \<subseteq> f" "runiq f" "Domain f = Domain R"
  shows "runiq R"
  using assms by (metis subrel_runiq)

lemma lm151:
  assumes "f \<subseteq> g" "runiq g" "Domain f = Domain g"
  shows "g \<subseteq> f"
  using assms Domain_iff contra_subsetD runiq_wrt_ex1 subrelI
  by (metis (full_types,opaque_lifting))

lemma lm152:
  assumes "R \<subseteq> f" "runiq f" "Domain f \<subseteq> Domain R"
  shows "f = R"
  using assms lm151 by (metis Domain_mono dual_order.antisym)

lemma lm153:
  "graph X f = (Graph f) || X"
  using inf_top.left_neutral lm005 domainOfGraph restrictedDomain lm152 graphIntersection
        restriction_is_subrel subrel_runiq subset_iff
  by (metis (erased, lifting))

lemma lm154:
  "graph (X \<inter> Y) f = (graph X f) || Y"
  using doubleRestriction lm153 by metis

lemma restrictionVsIntersection:
  "{(x, f x)| x. x \<in> X2} || X1 = {(x, f x)| x. x \<in> X2 \<inter> X1}"
  using graph_def lm154 by metis

lemma lm155:
  assumes "runiq f" "X \<subseteq> Domain f"
  shows "graph X (toFunction f) = (f||X)"
proof -
  have "\<And>v w. (v::'a set) \<subseteq> w \<longrightarrow> w \<inter> v = v" by (simp add: Int_commute inf.absorb1)
  thus "graph X (toFunction f) = f || X" by (metis assms(1) assms(2) doubleRestriction lm004 lm153)
qed

lemma lm156:
  "(Graph f) `` X = f ` X"
  unfolding Graph_def image_def by auto

lemma lm157:
  assumes "X \<subseteq> Domain f" "runiq f"
  shows "f``X = (eval_rel f)`X"
  using assms lm156 by (metis restrictedRange lm153 lm155 toFunction_def)

lemma cardOneImageCardOne:
  assumes "card A = 1"
  shows "card (f`A) = 1"
  using assms card_image card_image_le
proof -
  have "finite (f`A)" using assms One_nat_def Suc_not_Zero card.infinite finite_imageI
       by (metis(no_types))
  moreover have "f`A \<noteq> {}" using assms by fastforce
  moreover have "card (f`A) \<le> 1" using assms card_image_le One_nat_def Suc_not_Zero card.infinite
       by (metis)
  ultimately show ?thesis by (metis assms image_empty image_insert
                                    cardinalityOneTheElemIdentity the_elem_eq)
qed

lemma cardOneTheElem:
  assumes "card A = 1"
  shows "the_elem (f`A) = f (the_elem A)"
  using assms image_empty image_insert the_elem_eq by (metis cardinalityOneTheElemIdentity)

(* With split being the inverse of curry we have with g as swap f,  (g x y) = (f y x) *)
abbreviation
  "swap f == curry ((case_prod f) \<circ> flip)" (*swaps the two arguments of a function*)

(* X is finite if and only if X is the set of elements of some list. *)
lemma lm158:
  "finite X   =  (X \<in> range set)"
  by (metis List.finite_set finite_list image_iff rangeI)

(* as above, just as lambda expression *)
lemma lm159:
  "finite = (%X. X\<in>range set)"
  using lm158 by metis

lemma lm160:
  "swap f = (%x. %y. f y x)"
  by (metis comp_eq_dest_lhs curry_def flip_def fst_conv old.prod.case snd_conv)

subsection \<open>Some easy properties on real numbers\<close>
lemma lm161:
  fixes a::real
  fixes b c
  shows "a*b - a*c=a*(b-c)"
  by (metis real_scaleR_def real_vector.scale_right_diff_distrib)

lemma lm162:
  fixes a::real
  fixes b c
  shows "a*b - c*b=(a-c)*b"
  using lm161 by (metis mult.commute)

end


(*  Title:      FOL/IFOL.thy
    Author:     Lawrence C Paulson and Markus Wenzel
*)

section {* Intuitionistic first-order logic *}

theory IFOL
imports Pure
begin

ML_file "~~/src/Tools/misc_legacy.ML"
ML_file "~~/src/Provers/splitter.ML"
ML_file "~~/src/Provers/hypsubst.ML"
ML_file "~~/src/Tools/IsaPlanner/zipper.ML"
ML_file "~~/src/Tools/IsaPlanner/isand.ML"
ML_file "~~/src/Tools/IsaPlanner/rw_inst.ML"
ML_file "~~/src/Provers/quantifier1.ML"
ML_file "~~/src/Tools/intuitionistic.ML"
ML_file "~~/src/Tools/project_rule.ML"
ML_file "~~/src/Tools/atomize_elim.ML"

subsection {* Syntax and axiomatic basis *}

setup Pure_Thy.old_appl_syntax_setup

class "term"
default_sort "term"

typedecl o

judgment
  Trueprop      :: "o => prop"                  ("(_)" 5)

subsubsection {* Equality *}

axiomatization
  eq :: "['a, 'a] => o"  (infixl "=" 50)
where
  refl:         "a=a" and
  subst:        "a=b \<Longrightarrow> P(a) \<Longrightarrow> P(b)"

subsubsection {* Propositional logic *}

axiomatization
  False :: o and
  conj :: "[o, o] => o"  (infixr "&" 35) and
  disj :: "[o, o] => o"  (infixr "|" 30) and
  imp :: "[o, o] => o"  (infixr "-->" 25)
where
  conjI: "[| P;  Q |] ==> P&Q" and
  conjunct1: "P&Q ==> P" and
  conjunct2: "P&Q ==> Q" and

  disjI1: "P ==> P|Q" and
  disjI2: "Q ==> P|Q" and
  disjE: "[| P|Q;  P ==> R;  Q ==> R |] ==> R" and

  impI: "(P ==> Q) ==> P-->Q" and
  mp: "[| P-->Q;  P |] ==> Q" and

  FalseE: "False ==> P"

subsubsection {* Quantifiers *}

axiomatization
  All :: "('a => o) => o"  (binder "ALL " 10) and
  Ex :: "('a => o) => o"  (binder "EX " 10)
where
  allI: "(!!x. P(x)) ==> (ALL x. P(x))" and
  spec: "(ALL x. P(x)) ==> P(x)" and
  exI: "P(x) ==> (EX x. P(x))" and
  exE: "[| EX x. P(x);  !!x. P(x) ==> R |] ==> R"

subsubsection {* Definitions *}

definition "True == False-->False"
definition Not ("~ _" [40] 40) where not_def: "~P == P-->False"
definition iff  (infixr "<->" 25) where "P<->Q == (P-->Q) & (Q-->P)"

definition Ex1 :: "('a => o) => o"  (binder "EX! " 10)
  where ex1_def: "EX! x. P(x) == EX x. P(x) & (ALL y. P(y) --> y=x)"

axiomatization where  -- {* Reflection, admissible *}
  eq_reflection: "(x=y) ==> (x==y)" and
  iff_reflection: "(P<->Q) ==> (P==Q)"

subsubsection {* Additional notation *}

abbreviation not_equal :: "['a, 'a] => o"  (infixl "~=" 50)
  where "x ~= y == ~ (x = y)"

notation (xsymbols)
  not_equal  (infixl "\<noteq>" 50)

notation (HTML output)
  not_equal  (infixl "\<noteq>" 50)

notation (xsymbols)
  Not  ("\<not> _" [40] 40) and
  conj  (infixr "\<and>" 35) and
  disj  (infixr "\<or>" 30) and
  All  (binder "\<forall>" 10) and
  Ex  (binder "\<exists>" 10) and
  Ex1  (binder "\<exists>!" 10) and
  imp  (infixr "\<longrightarrow>" 25) and
  iff  (infixr "\<longleftrightarrow>" 25)

notation (HTML output)
  Not  ("\<not> _" [40] 40) and
  conj  (infixr "\<and>" 35) and
  disj  (infixr "\<or>" 30) and
  All  (binder "\<forall>" 10) and
  Ex  (binder "\<exists>" 10) and
  Ex1  (binder "\<exists>!" 10)

subsection {* Lemmas and proof tools *}

lemmas strip = impI allI

lemma TrueI: True
  unfolding True_def by (rule impI)

(*** Sequent-style elimination rules for & --> and ALL ***)

lemma conjE:
  assumes major: "P & Q"
    and r: "[| P; Q |] ==> R"
  shows R
  apply (rule r)
   apply (rule major [THEN conjunct1])
  apply (rule major [THEN conjunct2])
  done

lemma impE:
  assumes major: "P --> Q"
    and P
  and r: "Q ==> R"
  shows R
  apply (rule r)
  apply (rule major [THEN mp])
  apply (rule `P`)
  done

lemma allE:
  assumes major: "ALL x. P(x)"
    and r: "P(x) ==> R"
  shows R
  apply (rule r)
  apply (rule major [THEN spec])
  done

(*Duplicates the quantifier; for use with eresolve_tac*)
lemma all_dupE:
  assumes major: "ALL x. P(x)"
    and r: "[| P(x); ALL x. P(x) |] ==> R"
  shows R
  apply (rule r)
   apply (rule major [THEN spec])
  apply (rule major)
  done

(*** Negation rules, which translate between ~P and P-->False ***)

lemma notI: "(P ==> False) ==> ~P"
  unfolding not_def by (erule impI)

lemma notE: "[| ~P;  P |] ==> R"
  unfolding not_def by (erule mp [THEN FalseE])

lemma rev_notE: "[| P; ~P |] ==> R"
  by (erule notE)

(*This is useful with the special implication rules for each kind of P. *)
lemma not_to_imp:
  assumes "~P"
    and r: "P --> False ==> Q"
  shows Q
  apply (rule r)
  apply (rule impI)
  apply (erule notE [OF `~P`])
  done

(* For substitution into an assumption P, reduce Q to P-->Q, substitute into
   this implication, then apply impI to move P back into the assumptions.*)
lemma rev_mp: "[| P;  P --> Q |] ==> Q"
  by (erule mp)

(*Contrapositive of an inference rule*)
lemma contrapos:
  assumes major: "~Q"
    and minor: "P ==> Q"
  shows "~P"
  apply (rule major [THEN notE, THEN notI])
  apply (erule minor)
  done

(*** Modus Ponens Tactics ***)

(*Finds P-->Q and P in the assumptions, replaces implication by Q *)
ML {*
  fun mp_tac i = eresolve_tac [@{thm notE}, @{thm impE}] i  THEN  atac i
  fun eq_mp_tac i = eresolve_tac [@{thm notE}, @{thm impE}] i  THEN  eq_assume_tac i
*}

(*** If-and-only-if ***)

lemma iffI: "[| P ==> Q; Q ==> P |] ==> P<->Q"
  apply (unfold iff_def)
  apply (rule conjI)
   apply (erule impI)
  apply (erule impI)
  done

lemma iffE:
  assumes major: "P <-> Q"
    and r: "P-->Q ==> Q-->P ==> R"
  shows R
  apply (insert major, unfold iff_def)
  apply (erule conjE)
  apply (erule r)
  apply assumption
  done

(* Destruct rules for <-> similar to Modus Ponens *)

lemma iffD1: "[| P <-> Q;  P |] ==> Q"
  apply (unfold iff_def)
  apply (erule conjunct1 [THEN mp])
  apply assumption
  done

lemma iffD2: "[| P <-> Q;  Q |] ==> P"
  apply (unfold iff_def)
  apply (erule conjunct2 [THEN mp])
  apply assumption
  done

lemma rev_iffD1: "[| P; P <-> Q |] ==> Q"
  apply (erule iffD1)
  apply assumption
  done

lemma rev_iffD2: "[| Q; P <-> Q |] ==> P"
  apply (erule iffD2)
  apply assumption
  done

lemma iff_refl: "P <-> P"
  by (rule iffI)

lemma iff_sym: "Q <-> P ==> P <-> Q"
  apply (erule iffE)
  apply (rule iffI)
  apply (assumption | erule mp)+
  done

lemma iff_trans: "[| P <-> Q;  Q<-> R |] ==> P <-> R"
  apply (rule iffI)
  apply (assumption | erule iffE | erule (1) notE impE)+
  done

(*** Unique existence.  NOTE THAT the following 2 quantifications
   EX!x such that [EX!y such that P(x,y)]     (sequential)
   EX!x,y such that P(x,y)                    (simultaneous)
 do NOT mean the same thing.  The parser treats EX!x y.P(x,y) as sequential.
***)

lemma ex1I:
  "P(a) \<Longrightarrow> (!!x. P(x) ==> x=a) \<Longrightarrow> EX! x. P(x)"
  apply (unfold ex1_def)
  apply (assumption | rule exI conjI allI impI)+
  done

(*Sometimes easier to use: the premises have no shared variables.  Safe!*)
lemma ex_ex1I:
  "EX x. P(x) \<Longrightarrow> (!!x y. [| P(x); P(y) |] ==> x=y) \<Longrightarrow> EX! x. P(x)"
  apply (erule exE)
  apply (rule ex1I)
   apply assumption
  apply assumption
  done

lemma ex1E:
  "EX! x. P(x) \<Longrightarrow> (!!x. [| P(x);  ALL y. P(y) --> y=x |] ==> R) \<Longrightarrow> R"
  apply (unfold ex1_def)
  apply (assumption | erule exE conjE)+
  done

(*** <-> congruence rules for simplification ***)

(*Use iffE on a premise.  For conj_cong, imp_cong, all_cong, ex_cong*)
ML {*
  fun iff_tac prems i =
    resolve_tac (prems RL @{thms iffE}) i THEN
    REPEAT1 (eresolve_tac [@{thm asm_rl}, @{thm mp}] i)
*}

lemma conj_cong:
  assumes "P <-> P'"
    and "P' ==> Q <-> Q'"
  shows "(P&Q) <-> (P'&Q')"
  apply (insert assms)
  apply (assumption | rule iffI conjI | erule iffE conjE mp |
    tactic {* iff_tac @{thms assms} 1 *})+
  done

(*Reversed congruence rule!   Used in ZF/Order*)
lemma conj_cong2:
  assumes "P <-> P'"
    and "P' ==> Q <-> Q'"
  shows "(Q&P) <-> (Q'&P')"
  apply (insert assms)
  apply (assumption | rule iffI conjI | erule iffE conjE mp |
    tactic {* iff_tac @{thms assms} 1 *})+
  done

lemma disj_cong:
  assumes "P <-> P'" and "Q <-> Q'"
  shows "(P|Q) <-> (P'|Q')"
  apply (insert assms)
  apply (erule iffE disjE disjI1 disjI2 | assumption | rule iffI | erule (1) notE impE)+
  done

lemma imp_cong:
  assumes "P <-> P'"
    and "P' ==> Q <-> Q'"
  shows "(P-->Q) <-> (P'-->Q')"
  apply (insert assms)
  apply (assumption | rule iffI impI | erule iffE | erule (1) notE impE |
    tactic {* iff_tac @{thms assms} 1 *})+
  done

lemma iff_cong: "[| P <-> P'; Q <-> Q' |] ==> (P<->Q) <-> (P'<->Q')"
  apply (erule iffE | assumption | rule iffI | erule (1) notE impE)+
  done

lemma not_cong: "P <-> P' ==> ~P <-> ~P'"
  apply (assumption | rule iffI notI | erule (1) notE impE | erule iffE notE)+
  done

lemma all_cong:
  assumes "!!x. P(x) <-> Q(x)"
  shows "(ALL x. P(x)) <-> (ALL x. Q(x))"
  apply (assumption | rule iffI allI | erule (1) notE impE | erule allE |
    tactic {* iff_tac @{thms assms} 1 *})+
  done

lemma ex_cong:
  assumes "!!x. P(x) <-> Q(x)"
  shows "(EX x. P(x)) <-> (EX x. Q(x))"
  apply (erule exE | assumption | rule iffI exI | erule (1) notE impE |
    tactic {* iff_tac @{thms assms} 1 *})+
  done

lemma ex1_cong:
  assumes "!!x. P(x) <-> Q(x)"
  shows "(EX! x. P(x)) <-> (EX! x. Q(x))"
  apply (erule ex1E spec [THEN mp] | assumption | rule iffI ex1I | erule (1) notE impE |
    tactic {* iff_tac @{thms assms} 1 *})+
  done

(*** Equality rules ***)

lemma sym: "a=b ==> b=a"
  apply (erule subst)
  apply (rule refl)
  done

lemma trans: "[| a=b;  b=c |] ==> a=c"
  apply (erule subst, assumption)
  done

(**  **)
lemma not_sym: "b ~= a ==> a ~= b"
  apply (erule contrapos)
  apply (erule sym)
  done

(* Two theorms for rewriting only one instance of a definition:
   the first for definitions of formulae and the second for terms *)

lemma def_imp_iff: "(A == B) ==> A <-> B"
  apply unfold
  apply (rule iff_refl)
  done

lemma meta_eq_to_obj_eq: "(A == B) ==> A = B"
  apply unfold
  apply (rule refl)
  done

lemma meta_eq_to_iff: "x==y ==> x<->y"
  by unfold (rule iff_refl)

(*substitution*)
lemma ssubst: "[| b = a; P(a) |] ==> P(b)"
  apply (drule sym)
  apply (erule (1) subst)
  done

(*A special case of ex1E that would otherwise need quantifier expansion*)
lemma ex1_equalsE:
    "[| EX! x. P(x);  P(a);  P(b) |] ==> a=b"
  apply (erule ex1E)
  apply (rule trans)
   apply (rule_tac [2] sym)
   apply (assumption | erule spec [THEN mp])+
  done

(** Polymorphic congruence rules **)

lemma subst_context: "[| a=b |]  ==>  t(a)=t(b)"
  apply (erule ssubst)
  apply (rule refl)
  done

lemma subst_context2: "[| a=b;  c=d |]  ==>  t(a,c)=t(b,d)"
  apply (erule ssubst)+
  apply (rule refl)
  done

lemma subst_context3: "[| a=b;  c=d;  e=f |]  ==>  t(a,c,e)=t(b,d,f)"
  apply (erule ssubst)+
  apply (rule refl)
  done

(*Useful with eresolve_tac for proving equalties from known equalities.
        a = b
        |   |
        c = d   *)
lemma box_equals: "[| a=b;  a=c;  b=d |] ==> c=d"
  apply (rule trans)
   apply (rule trans)
    apply (rule sym)
    apply assumption+
  done

(*Dual of box_equals: for proving equalities backwards*)
lemma simp_equals: "[| a=c;  b=d;  c=d |] ==> a=b"
  apply (rule trans)
   apply (rule trans)
    apply assumption+
  apply (erule sym)
  done

(** Congruence rules for predicate letters **)

lemma pred1_cong: "a=a' ==> P(a) <-> P(a')"
  apply (rule iffI)
   apply (erule (1) subst)
  apply (erule (1) ssubst)
  done

lemma pred2_cong: "[| a=a';  b=b' |] ==> P(a,b) <-> P(a',b')"
  apply (rule iffI)
   apply (erule subst)+
   apply assumption
  apply (erule ssubst)+
  apply assumption
  done

lemma pred3_cong: "[| a=a';  b=b';  c=c' |] ==> P(a,b,c) <-> P(a',b',c')"
  apply (rule iffI)
   apply (erule subst)+
   apply assumption
  apply (erule ssubst)+
  apply assumption
  done

(*special case for the equality predicate!*)
lemma eq_cong: "[| a = a'; b = b' |] ==> a = b <-> a' = b'"
  apply (erule (1) pred2_cong)
  done

(*** Simplifications of assumed implications.
     Roy Dyckhoff has proved that conj_impE, disj_impE, and imp_impE
     used with mp_tac (restricted to atomic formulae) is COMPLETE for
     intuitionistic propositional logic.  See
   R. Dyckhoff, Contraction-free sequent calculi for intuitionistic logic
    (preprint, University of St Andrews, 1991)  ***)

lemma conj_impE:
  assumes major: "(P&Q)-->S"
    and r: "P-->(Q-->S) ==> R"
  shows R
  by (assumption | rule conjI impI major [THEN mp] r)+

lemma disj_impE:
  assumes major: "(P|Q)-->S"
    and r: "[| P-->S; Q-->S |] ==> R"
  shows R
  by (assumption | rule disjI1 disjI2 impI major [THEN mp] r)+

(*Simplifies the implication.  Classical version is stronger.
  Still UNSAFE since Q must be provable -- backtracking needed.  *)
lemma imp_impE:
  assumes major: "(P-->Q)-->S"
    and r1: "[| P; Q-->S |] ==> Q"
    and r2: "S ==> R"
  shows R
  by (assumption | rule impI major [THEN mp] r1 r2)+

(*Simplifies the implication.  Classical version is stronger.
  Still UNSAFE since ~P must be provable -- backtracking needed.  *)
lemma not_impE:
  "~P --> S \<Longrightarrow> (P ==> False) \<Longrightarrow> (S ==> R) \<Longrightarrow> R"
  apply (drule mp)
   apply (rule notI)
   apply assumption
  apply assumption
  done

(*Simplifies the implication.   UNSAFE.  *)
lemma iff_impE:
  assumes major: "(P<->Q)-->S"
    and r1: "[| P; Q-->S |] ==> Q"
    and r2: "[| Q; P-->S |] ==> P"
    and r3: "S ==> R"
  shows R
  apply (assumption | rule iffI impI major [THEN mp] r1 r2 r3)+
  done

(*What if (ALL x.~~P(x)) --> ~~(ALL x.P(x)) is an assumption? UNSAFE*)
lemma all_impE:
  assumes major: "(ALL x. P(x))-->S"
    and r1: "!!x. P(x)"
    and r2: "S ==> R"
  shows R
  apply (rule allI impI major [THEN mp] r1 r2)+
  done

(*Unsafe: (EX x.P(x))-->S  is equivalent to  ALL x.P(x)-->S.  *)
lemma ex_impE:
  assumes major: "(EX x. P(x))-->S"
    and r: "P(x)-->S ==> R"
  shows R
  apply (assumption | rule exI impI major [THEN mp] r)+
  done

(*** Courtesy of Krzysztof Grabczewski ***)

lemma disj_imp_disj:
  "P|Q \<Longrightarrow> (P==>R) \<Longrightarrow> (Q==>S) \<Longrightarrow> R|S"
  apply (erule disjE)
  apply (rule disjI1) apply assumption
  apply (rule disjI2) apply assumption
  done

ML {*
structure Project_Rule = Project_Rule
(
  val conjunct1 = @{thm conjunct1}
  val conjunct2 = @{thm conjunct2}
  val mp = @{thm mp}
)
*}

ML_file "fologic.ML"

lemma thin_refl: "[|x=x; PROP W|] ==> PROP W" .

ML {*
structure Hypsubst = Hypsubst
(
  val dest_eq = FOLogic.dest_eq
  val dest_Trueprop = FOLogic.dest_Trueprop
  val dest_imp = FOLogic.dest_imp
  val eq_reflection = @{thm eq_reflection}
  val rev_eq_reflection = @{thm meta_eq_to_obj_eq}
  val imp_intr = @{thm impI}
  val rev_mp = @{thm rev_mp}
  val subst = @{thm subst}
  val sym = @{thm sym}
  val thin_refl = @{thm thin_refl}
);
open Hypsubst;
*}

ML_file "intprover.ML"

subsection {* Intuitionistic Reasoning *}

setup {* Intuitionistic.method_setup @{binding iprover} *}

lemma impE':
  assumes 1: "P --> Q"
    and 2: "Q ==> R"
    and 3: "P --> Q ==> P"
  shows R
proof -
  from 3 and 1 have P .
  with 1 have Q by (rule impE)
  with 2 show R .
qed

lemma allE':
  assumes 1: "ALL x. P(x)"
    and 2: "P(x) ==> ALL x. P(x) ==> Q"
  shows Q
proof -
  from 1 have "P(x)" by (rule spec)
  from this and 1 show Q by (rule 2)
qed

lemma notE':
  assumes 1: "~ P"
    and 2: "~ P ==> P"
  shows R
proof -
  from 2 and 1 have P .
  with 1 show R by (rule notE)
qed

lemmas [Pure.elim!] = disjE iffE FalseE conjE exE
  and [Pure.intro!] = iffI conjI impI TrueI notI allI refl
  and [Pure.elim 2] = allE notE' impE'
  and [Pure.intro] = exI disjI2 disjI1

setup {* Context_Rules.addSWrapper (fn ctxt => fn tac => hyp_subst_tac ctxt ORELSE' tac) *}

lemma iff_not_sym: "~ (Q <-> P) ==> ~ (P <-> Q)"
  by iprover

lemmas [sym] = sym iff_sym not_sym iff_not_sym
  and [Pure.elim?] = iffD1 iffD2 impE

lemma eq_commute: "a=b <-> b=a"
apply (rule iffI)
apply (erule sym)+
done

subsection {* Atomizing meta-level rules *}

lemma atomize_all [atomize]: "(!!x. P(x)) == Trueprop (ALL x. P(x))"
proof
  assume "!!x. P(x)"
  then show "ALL x. P(x)" ..
next
  assume "ALL x. P(x)"
  then show "!!x. P(x)" ..
qed

lemma atomize_imp [atomize]: "(A ==> B) == Trueprop (A --> B)"
proof
  assume "A ==> B"
  then show "A --> B" ..
next
  assume "A --> B" and A
  then show B by (rule mp)
qed

lemma atomize_eq [atomize]: "(x == y) == Trueprop (x = y)"
proof
  assume "x == y"
  show "x = y" unfolding `x == y` by (rule refl)
next
  assume "x = y"
  then show "x == y" by (rule eq_reflection)
qed

lemma atomize_iff [atomize]: "(A == B) == Trueprop (A <-> B)"
proof
  assume "A == B"
  show "A <-> B" unfolding `A == B` by (rule iff_refl)
next
  assume "A <-> B"
  then show "A == B" by (rule iff_reflection)
qed

lemma atomize_conj [atomize]: "(A &&& B) == Trueprop (A & B)"
proof
  assume conj: "A &&& B"
  show "A & B"
  proof (rule conjI)
    from conj show A by (rule conjunctionD1)
    from conj show B by (rule conjunctionD2)
  qed
next
  assume conj: "A & B"
  show "A &&& B"
  proof -
    from conj show A ..
    from conj show B ..
  qed
qed

lemmas [symmetric, rulify] = atomize_all atomize_imp
  and [symmetric, defn] = atomize_all atomize_imp atomize_eq atomize_iff

subsection {* Atomizing elimination rules *}

lemma atomize_exL[atomize_elim]: "(!!x. P(x) ==> Q) == ((EX x. P(x)) ==> Q)"
  by rule iprover+

lemma atomize_conjL[atomize_elim]: "(A ==> B ==> C) == (A & B ==> C)"
  by rule iprover+

lemma atomize_disjL[atomize_elim]: "((A ==> C) ==> (B ==> C) ==> C) == ((A | B ==> C) ==> C)"
  by rule iprover+

lemma atomize_elimL[atomize_elim]: "(!!B. (A ==> B) ==> B) == Trueprop(A)" ..

subsection {* Calculational rules *}

lemma forw_subst: "a = b ==> P(b) ==> P(a)"
  by (rule ssubst)

lemma back_subst: "P(a) ==> a = b ==> P(b)"
  by (rule subst)

text {*
  Note that this list of rules is in reverse order of priorities.
*}

lemmas basic_trans_rules [trans] =
  forw_subst
  back_subst
  rev_mp
  mp
  trans

subsection {* ``Let'' declarations *}

nonterminal letbinds and letbind

definition Let :: "['a::{}, 'a => 'b] => ('b::{})" where
    "Let(s, f) == f(s)"

syntax
  "_bind"       :: "[pttrn, 'a] => letbind"           ("(2_ =/ _)" 10)
  ""            :: "letbind => letbinds"              ("_")
  "_binds"      :: "[letbind, letbinds] => letbinds"  ("_;/ _")
  "_Let"        :: "[letbinds, 'a] => 'a"             ("(let (_)/ in (_))" 10)

translations
  "_Let(_binds(b, bs), e)"  == "_Let(b, _Let(bs, e))"
  "let x = a in e"          == "CONST Let(a, %x. e)"

lemma LetI:
  assumes "!!x. x=t ==> P(u(x))"
  shows "P(let x=t in u(x))"
  apply (unfold Let_def)
  apply (rule refl [THEN assms])
  done

subsection {* Intuitionistic simplification rules *}

lemma conj_simps:
  "P & True <-> P"
  "True & P <-> P"
  "P & False <-> False"
  "False & P <-> False"
  "P & P <-> P"
  "P & P & Q <-> P & Q"
  "P & ~P <-> False"
  "~P & P <-> False"
  "(P & Q) & R <-> P & (Q & R)"
  by iprover+

lemma disj_simps:
  "P | True <-> True"
  "True | P <-> True"
  "P | False <-> P"
  "False | P <-> P"
  "P | P <-> P"
  "P | P | Q <-> P | Q"
  "(P | Q) | R <-> P | (Q | R)"
  by iprover+

lemma not_simps:
  "~(P|Q)  <-> ~P & ~Q"
  "~ False <-> True"
  "~ True <-> False"
  by iprover+

lemma imp_simps:
  "(P --> False) <-> ~P"
  "(P --> True) <-> True"
  "(False --> P) <-> True"
  "(True --> P) <-> P"
  "(P --> P) <-> True"
  "(P --> ~P) <-> ~P"
  by iprover+

lemma iff_simps:
  "(True <-> P) <-> P"
  "(P <-> True) <-> P"
  "(P <-> P) <-> True"
  "(False <-> P) <-> ~P"
  "(P <-> False) <-> ~P"
  by iprover+

(*The x=t versions are needed for the simplification procedures*)
lemma quant_simps:
  "!!P. (ALL x. P) <-> P"
  "(ALL x. x=t --> P(x)) <-> P(t)"
  "(ALL x. t=x --> P(x)) <-> P(t)"
  "!!P. (EX x. P) <-> P"
  "EX x. x=t"
  "EX x. t=x"
  "(EX x. x=t & P(x)) <-> P(t)"
  "(EX x. t=x & P(x)) <-> P(t)"
  by iprover+

(*These are NOT supplied by default!*)
lemma distrib_simps:
  "P & (Q | R) <-> P&Q | P&R"
  "(Q | R) & P <-> Q&P | R&P"
  "(P | Q --> R) <-> (P --> R) & (Q --> R)"
  by iprover+

text {* Conversion into rewrite rules *}

lemma P_iff_F: "~P ==> (P <-> False)" by iprover
lemma iff_reflection_F: "~P ==> (P == False)" by (rule P_iff_F [THEN iff_reflection])

lemma P_iff_T: "P ==> (P <-> True)" by iprover
lemma iff_reflection_T: "P ==> (P == True)" by (rule P_iff_T [THEN iff_reflection])

text {* More rewrite rules *}

lemma conj_commute: "P&Q <-> Q&P" by iprover
lemma conj_left_commute: "P&(Q&R) <-> Q&(P&R)" by iprover
lemmas conj_comms = conj_commute conj_left_commute

lemma disj_commute: "P|Q <-> Q|P" by iprover
lemma disj_left_commute: "P|(Q|R) <-> Q|(P|R)" by iprover
lemmas disj_comms = disj_commute disj_left_commute

lemma conj_disj_distribL: "P&(Q|R) <-> (P&Q | P&R)" by iprover
lemma conj_disj_distribR: "(P|Q)&R <-> (P&R | Q&R)" by iprover

lemma disj_conj_distribL: "P|(Q&R) <-> (P|Q) & (P|R)" by iprover
lemma disj_conj_distribR: "(P&Q)|R <-> (P|R) & (Q|R)" by iprover

lemma imp_conj_distrib: "(P --> (Q&R)) <-> (P-->Q) & (P-->R)" by iprover
lemma imp_conj: "((P&Q)-->R)   <-> (P --> (Q --> R))" by iprover
lemma imp_disj: "(P|Q --> R)   <-> (P-->R) & (Q-->R)" by iprover

lemma de_Morgan_disj: "(~(P | Q)) <-> (~P & ~Q)" by iprover

lemma not_ex: "(~ (EX x. P(x))) <-> (ALL x.~P(x))" by iprover
lemma imp_ex: "((EX x. P(x)) --> Q) <-> (ALL x. P(x) --> Q)" by iprover

lemma ex_disj_distrib:
  "(EX x. P(x) | Q(x)) <-> ((EX x. P(x)) | (EX x. Q(x)))" by iprover

lemma all_conj_distrib:
  "(ALL x. P(x) & Q(x)) <-> ((ALL x. P(x)) & (ALL x. Q(x)))" by iprover

end


(*  Title:      HOL/Library/RBT_Set.thy
    Author:     Ondrej Kuncar
*)

section \<open>Implementation of sets using RBT trees\<close>

theory RBT_Set
imports RBT Product_Lexorder
begin

(*
  Users should be aware that by including this file all code equations
  outside of List.thy using 'a list as an implementation of sets cannot be
  used for code generation. If such equations are not needed, they can be
  deleted from the code generator. Otherwise, a user has to provide their
  own equations using RBT trees.
*)

section \<open>Definition of code datatype constructors\<close>

definition Set :: "('a::linorder, unit) rbt \<Rightarrow> 'a set"
  where "Set t = {x . RBT.lookup t x = Some ()}"

definition Coset :: "('a::linorder, unit) rbt \<Rightarrow> 'a set"
  where [simp]: "Coset t = - Set t"

section \<open>Deletion of already existing code equations\<close>

declare [[code drop: Set.empty Set.is_empty uminus_set_inst.uminus_set
  Set.member Set.insert Set.remove UNIV Set.filter image
  Set.subset_eq Ball Bex can_select Set.union minus_set_inst.minus_set Set.inter
  card the_elem Pow sum prod Product_Type.product Id_on
  Image trancl relcomp wf Min Inf_fin Max Sup_fin
  "(Inf :: 'a set set \<Rightarrow> 'a set)" "(Sup :: 'a set set \<Rightarrow> 'a set)"
  sorted_list_of_set List.map_project List.Bleast]]

section \<open>Lemmas\<close>

subsection \<open>Auxiliary lemmas\<close>

lemma Set_set_keys: "Set x = dom (RBT.lookup x)"
by (auto simp: Set_def)

lemma finite_Set [simp, intro!]: "finite (Set x)"
by (simp add: Set_set_keys)

lemma set_keys: "Set t = set(RBT.keys t)"
by (simp add: Set_set_keys lookup_keys)

subsection \<open>fold and filter\<close>

lemma finite_fold_rbt_fold_eq:
  assumes "comp_fun_commute f"
  shows "Finite_Set.fold f A (set (RBT.entries t)) = RBT.fold (curry f) t A"
proof -
  interpret comp_fun_commute: comp_fun_commute f
    by (fact assms)
  have *: "remdups (RBT.entries t) = RBT.entries t"
    using distinct_entries distinct_map by (auto intro: distinct_remdups_id)
  show ?thesis using assms by (auto simp: fold_def_alt comp_fun_commute.fold_set_fold_remdups *)
qed

definition fold_keys :: "('a :: linorder \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a, _) rbt \<Rightarrow> 'b \<Rightarrow> 'b"
  where [code_unfold]:"fold_keys f t A = RBT.fold (\<lambda>k _ t. f k t) t A"

lemma fold_keys_def_alt:
  "fold_keys f t s = List.fold f (RBT.keys t) s"
by (auto simp: fold_map o_def split_def fold_def_alt keys_def_alt fold_keys_def)

lemma finite_fold_fold_keys:
  assumes "comp_fun_commute f"
  shows "Finite_Set.fold f A (Set t) = fold_keys f t A"
using assms
proof -
  interpret comp_fun_commute f by fact
  have "set (RBT.keys t) = fst ` (set (RBT.entries t))" by (auto simp: fst_eq_Domain keys_entries)
  moreover have "inj_on fst (set (RBT.entries t))" using distinct_entries distinct_map by auto
  ultimately show ?thesis
    by (auto simp add: set_keys fold_keys_def curry_def fold_image finite_fold_rbt_fold_eq
      comp_comp_fun_commute)
qed

definition rbt_filter :: "('a :: linorder \<Rightarrow> bool) \<Rightarrow> ('a, 'b) rbt \<Rightarrow> 'a set" where
  "rbt_filter P t = RBT.fold (\<lambda>k _ A'. if P k then Set.insert k A' else A') t {}"

lemma Set_filter_rbt_filter:
  "Set.filter P (Set t) = rbt_filter P t"
by (simp add: fold_keys_def Set_filter_fold rbt_filter_def
  finite_fold_fold_keys[OF comp_fun_commute_filter_fold])

subsection \<open>foldi and Ball\<close>

lemma Ball_False: "RBT_Impl.fold (\<lambda>k v s. s \<and> P k) t False = False"
by (induction t) auto

lemma rbt_foldi_fold_conj:
  "RBT_Impl.foldi (\<lambda>s. s = True) (\<lambda>k v s. s \<and> P k) t val = RBT_Impl.fold (\<lambda>k v s. s \<and> P k) t val"
proof (induction t arbitrary: val)
  case (Branch c t1) then show ?case
    by (cases "RBT_Impl.fold (\<lambda>k v s. s \<and> P k) t1 True") (simp_all add: Ball_False)
qed simp

lemma foldi_fold_conj: "RBT.foldi (\<lambda>s. s = True) (\<lambda>k v s. s \<and> P k) t val = fold_keys (\<lambda>k s. s \<and> P k) t val"
unfolding fold_keys_def including rbt.lifting by transfer (rule rbt_foldi_fold_conj)

subsection \<open>foldi and Bex\<close>

lemma Bex_True: "RBT_Impl.fold (\<lambda>k v s. s \<or> P k) t True = True"
by (induction t) auto

lemma rbt_foldi_fold_disj:
  "RBT_Impl.foldi (\<lambda>s. s = False) (\<lambda>k v s. s \<or> P k) t val = RBT_Impl.fold (\<lambda>k v s. s \<or> P k) t val"
proof (induction t arbitrary: val)
  case (Branch c t1) then show ?case
    by (cases "RBT_Impl.fold (\<lambda>k v s. s \<or> P k) t1 False") (simp_all add: Bex_True)
qed simp

lemma foldi_fold_disj: "RBT.foldi (\<lambda>s. s = False) (\<lambda>k v s. s \<or> P k) t val = fold_keys (\<lambda>k s. s \<or> P k) t val"
unfolding fold_keys_def including rbt.lifting by transfer (rule rbt_foldi_fold_disj)

subsection \<open>folding over non empty trees and selecting the minimal and maximal element\<close>

subsubsection \<open>concrete\<close>

text \<open>The concrete part is here because it's probably not general enough to be moved to \<open>RBT_Impl\<close>\<close>

definition rbt_fold1_keys :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a::linorder, 'b) RBT_Impl.rbt \<Rightarrow> 'a"
  where "rbt_fold1_keys f t = List.fold f (tl(RBT_Impl.keys t)) (hd(RBT_Impl.keys t))"

paragraph \<open>minimum\<close>

definition rbt_min :: "('a::linorder, unit) RBT_Impl.rbt \<Rightarrow> 'a"
  where "rbt_min t = rbt_fold1_keys min t"

lemma key_le_right: "rbt_sorted (Branch c lt k v rt) \<Longrightarrow> (\<And>x. x \<in>set (RBT_Impl.keys rt) \<Longrightarrow> k \<le> x)"
by  (auto simp: rbt_greater_prop less_imp_le)

lemma left_le_key: "rbt_sorted (Branch c lt k v rt) \<Longrightarrow> (\<And>x. x \<in>set (RBT_Impl.keys lt) \<Longrightarrow> x \<le> k)"
by (auto simp: rbt_less_prop less_imp_le)

lemma fold_min_triv:
  fixes k :: "_ :: linorder"
  shows "(\<forall>x\<in>set xs. k \<le> x) \<Longrightarrow> List.fold min xs k = k"
by (induct xs) (auto simp add: min_def)

lemma rbt_min_simps:
  "is_rbt (Branch c RBT_Impl.Empty k v rt) \<Longrightarrow> rbt_min (Branch c RBT_Impl.Empty k v rt) = k"
by (auto intro: fold_min_triv dest: key_le_right is_rbt_rbt_sorted simp: rbt_fold1_keys_def rbt_min_def)

fun rbt_min_opt where
  "rbt_min_opt (Branch c RBT_Impl.Empty k v rt) = k" |
  "rbt_min_opt (Branch c (Branch lc llc lk lv lrt) k v rt) = rbt_min_opt (Branch lc llc lk lv lrt)"

lemma rbt_min_opt_Branch:
  "t1 \<noteq> rbt.Empty \<Longrightarrow> rbt_min_opt (Branch c t1 k () t2) = rbt_min_opt t1"
by (cases t1) auto

lemma rbt_min_opt_induct [case_names empty left_empty left_non_empty]:
  fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
  assumes "P rbt.Empty"
  assumes "\<And>color t1 a b t2. P t1 \<Longrightarrow> P t2 \<Longrightarrow> t1 = rbt.Empty \<Longrightarrow> P (Branch color t1 a b t2)"
  assumes "\<And>color t1 a b t2. P t1 \<Longrightarrow> P t2 \<Longrightarrow> t1 \<noteq> rbt.Empty \<Longrightarrow> P (Branch color t1 a b t2)"
  shows "P t"
  using assms
proof (induct t)
  case Empty
  then show ?case by simp
next
  case (Branch x1 t1 x3 x4 t2)
  then show ?case by (cases "t1 = rbt.Empty") simp_all
qed

lemma rbt_min_opt_in_set:
  fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
  assumes "t \<noteq> rbt.Empty"
  shows "rbt_min_opt t \<in> set (RBT_Impl.keys t)"
using assms by (induction t rule: rbt_min_opt.induct) (auto)

lemma rbt_min_opt_is_min:
  fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
  assumes "rbt_sorted t"
  assumes "t \<noteq> rbt.Empty"
  shows "\<And>y. y \<in> set (RBT_Impl.keys t) \<Longrightarrow> y \<ge> rbt_min_opt t"
using assms
proof (induction t rule: rbt_min_opt_induct)
  case empty
  then show ?case by simp
next
  case left_empty
  then show ?case by (auto intro: key_le_right simp del: rbt_sorted.simps)
next
  case (left_non_empty c t1 k v t2 y)
  then consider "y = k" | "y \<in> set (RBT_Impl.keys t1)" | "y \<in> set (RBT_Impl.keys t2)"
    by auto
  then show ?case
  proof cases
    case 1
    with left_non_empty show ?thesis
      by (auto simp add: rbt_min_opt_Branch intro: left_le_key rbt_min_opt_in_set)
  next
    case 2
    with left_non_empty show ?thesis
      by (auto simp add: rbt_min_opt_Branch)
  next
    case y: 3
    have "rbt_min_opt t1 \<le> k"
      using left_non_empty by (simp add: left_le_key rbt_min_opt_in_set)
    moreover have "k \<le> y"
      using left_non_empty y by (simp add: key_le_right)
    ultimately show ?thesis
      using left_non_empty y by (simp add: rbt_min_opt_Branch)
  qed
qed

lemma rbt_min_eq_rbt_min_opt:
  assumes "t \<noteq> RBT_Impl.Empty"
  assumes "is_rbt t"
  shows "rbt_min t = rbt_min_opt t"
proof -
  from assms have "hd (RBT_Impl.keys t) # tl (RBT_Impl.keys t) = RBT_Impl.keys t" by (cases t) simp_all
  with assms show ?thesis
    by (simp add: rbt_min_def rbt_fold1_keys_def rbt_min_opt_is_min
      Min.set_eq_fold [symmetric] Min_eqI rbt_min_opt_in_set)
qed

paragraph \<open>maximum\<close>

definition rbt_max :: "('a::linorder, unit) RBT_Impl.rbt \<Rightarrow> 'a"
  where "rbt_max t = rbt_fold1_keys max t"

lemma fold_max_triv:
  fixes k :: "_ :: linorder"
  shows "(\<forall>x\<in>set xs. x \<le> k) \<Longrightarrow> List.fold max xs k = k"
by (induct xs) (auto simp add: max_def)

lemma fold_max_rev_eq:
  fixes xs :: "('a :: linorder) list"
  assumes "xs \<noteq> []"
  shows "List.fold max (tl xs) (hd xs) = List.fold max (tl (rev xs)) (hd (rev xs))"
  using assms by (simp add: Max.set_eq_fold [symmetric])

lemma rbt_max_simps:
  assumes "is_rbt (Branch c lt k v RBT_Impl.Empty)"
  shows "rbt_max (Branch c lt k v RBT_Impl.Empty) = k"
proof -
  have "List.fold max (tl (rev(RBT_Impl.keys lt @ [k]))) (hd (rev(RBT_Impl.keys lt @ [k]))) = k"
    using assms by (auto intro!: fold_max_triv dest!: left_le_key is_rbt_rbt_sorted)
  then show ?thesis by (auto simp add: rbt_max_def rbt_fold1_keys_def fold_max_rev_eq)
qed

fun rbt_max_opt where
  "rbt_max_opt (Branch c lt k v RBT_Impl.Empty) = k" |
  "rbt_max_opt (Branch c lt k v (Branch rc rlc rk rv rrt)) = rbt_max_opt (Branch rc rlc rk rv rrt)"

lemma rbt_max_opt_Branch:
  "t2 \<noteq> rbt.Empty \<Longrightarrow> rbt_max_opt (Branch c t1 k () t2) = rbt_max_opt t2"
by (cases t2) auto

lemma rbt_max_opt_induct [case_names empty right_empty right_non_empty]:
  fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
  assumes "P rbt.Empty"
  assumes "\<And>color t1 a b t2. P t1 \<Longrightarrow> P t2 \<Longrightarrow> t2 = rbt.Empty \<Longrightarrow> P (Branch color t1 a b t2)"
  assumes "\<And>color t1 a b t2. P t1 \<Longrightarrow> P t2 \<Longrightarrow> t2 \<noteq> rbt.Empty \<Longrightarrow> P (Branch color t1 a b t2)"
  shows "P t"
  using assms
proof (induct t)
  case Empty
  then show ?case by simp
next
  case (Branch x1 t1 x3 x4 t2)
  then show ?case by (cases "t2 = rbt.Empty") simp_all
qed

lemma rbt_max_opt_in_set:
  fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
  assumes "t \<noteq> rbt.Empty"
  shows "rbt_max_opt t \<in> set (RBT_Impl.keys t)"
using assms by (induction t rule: rbt_max_opt.induct) (auto)

lemma rbt_max_opt_is_max:
  fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
  assumes "rbt_sorted t"
  assumes "t \<noteq> rbt.Empty"
  shows "\<And>y. y \<in> set (RBT_Impl.keys t) \<Longrightarrow> y \<le> rbt_max_opt t"
using assms
proof (induction t rule: rbt_max_opt_induct)
  case empty
  then show ?case by simp
next
  case right_empty
  then show ?case by (auto intro: left_le_key simp del: rbt_sorted.simps)
next
  case (right_non_empty c t1 k v t2 y)
  then consider "y = k" | "y \<in> set (RBT_Impl.keys t2)" | "y \<in> set (RBT_Impl.keys t1)"
    by auto
  then show ?case
  proof cases
    case 1
    with right_non_empty show ?thesis
      by (auto simp add: rbt_max_opt_Branch intro: key_le_right rbt_max_opt_in_set)
  next
    case 2
    with right_non_empty show ?thesis
      by (auto simp add: rbt_max_opt_Branch)
  next
    case y: 3
    have "rbt_max_opt t2 \<ge> k"
      using right_non_empty by (simp add: key_le_right rbt_max_opt_in_set)
    moreover have "y \<le> k"
      using right_non_empty y by (simp add: left_le_key)
    ultimately show ?thesis
      using right_non_empty by (simp add: rbt_max_opt_Branch)
  qed
qed

lemma rbt_max_eq_rbt_max_opt:
  assumes "t \<noteq> RBT_Impl.Empty"
  assumes "is_rbt t"
  shows "rbt_max t = rbt_max_opt t"
proof -
  from assms have "hd (RBT_Impl.keys t) # tl (RBT_Impl.keys t) = RBT_Impl.keys t" by (cases t) simp_all
  with assms show ?thesis
    by (simp add: rbt_max_def rbt_fold1_keys_def rbt_max_opt_is_max
      Max.set_eq_fold [symmetric] Max_eqI rbt_max_opt_in_set)
qed

subsubsection \<open>abstract\<close>

context includes rbt.lifting begin
lift_definition fold1_keys :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> 'a"
  is rbt_fold1_keys .

lemma fold1_keys_def_alt:
  "fold1_keys f t = List.fold f (tl (RBT.keys t)) (hd (RBT.keys t))"
  by transfer (simp add: rbt_fold1_keys_def)

lemma finite_fold1_fold1_keys:
  assumes "semilattice f"
  assumes "\<not> RBT.is_empty t"
  shows "semilattice_set.F f (Set t) = fold1_keys f t"
proof -
  from \<open>semilattice f\<close> interpret semilattice_set f by (rule semilattice_set.intro)
  show ?thesis using assms
    by (auto simp: fold1_keys_def_alt set_keys fold_def_alt non_empty_keys set_eq_fold [symmetric])
qed

paragraph \<open>minimum\<close>

lift_definition r_min :: "('a :: linorder, unit) rbt \<Rightarrow> 'a" is rbt_min .

lift_definition r_min_opt :: "('a :: linorder, unit) rbt \<Rightarrow> 'a" is rbt_min_opt .

lemma r_min_alt_def: "r_min t = fold1_keys min t"
by transfer (simp add: rbt_min_def)

lemma r_min_eq_r_min_opt:
  assumes "\<not> (RBT.is_empty t)"
  shows "r_min t = r_min_opt t"
using assms unfolding is_empty_empty by transfer (auto intro: rbt_min_eq_rbt_min_opt)

lemma fold_keys_min_top_eq:
  fixes t :: "('a::{linorder,bounded_lattice_top}, unit) rbt"
  assumes "\<not> (RBT.is_empty t)"
  shows "fold_keys min t top = fold1_keys min t"
proof -
  have *: "\<And>t. RBT_Impl.keys t \<noteq> [] \<Longrightarrow> List.fold min (RBT_Impl.keys t) top =
      List.fold min (hd (RBT_Impl.keys t) # tl (RBT_Impl.keys t)) top"
    by (simp add: hd_Cons_tl[symmetric])
  have **: "List.fold min (x # xs) top = List.fold min xs x" for x :: 'a and xs
    by (simp add: inf_min[symmetric])
  show ?thesis
    using assms
    unfolding fold_keys_def_alt fold1_keys_def_alt is_empty_empty
    apply transfer
    apply (case_tac t)
     apply simp
    apply (subst *)
     apply simp
    apply (subst **)
    apply simp
    done
qed

paragraph \<open>maximum\<close>

lift_definition r_max :: "('a :: linorder, unit) rbt \<Rightarrow> 'a" is rbt_max .

lift_definition r_max_opt :: "('a :: linorder, unit) rbt \<Rightarrow> 'a" is rbt_max_opt .

lemma r_max_alt_def: "r_max t = fold1_keys max t"
by transfer (simp add: rbt_max_def)

lemma r_max_eq_r_max_opt:
  assumes "\<not> (RBT.is_empty t)"
  shows "r_max t = r_max_opt t"
using assms unfolding is_empty_empty by transfer (auto intro: rbt_max_eq_rbt_max_opt)

lemma fold_keys_max_bot_eq:
  fixes t :: "('a::{linorder,bounded_lattice_bot}, unit) rbt"
  assumes "\<not> (RBT.is_empty t)"
  shows "fold_keys max t bot = fold1_keys max t"
proof -
  have *: "\<And>t. RBT_Impl.keys t \<noteq> [] \<Longrightarrow> List.fold max (RBT_Impl.keys t) bot =
      List.fold max (hd(RBT_Impl.keys t) # tl(RBT_Impl.keys t)) bot"
    by (simp add: hd_Cons_tl[symmetric])
  have **: "List.fold max (x # xs) bot = List.fold max xs x" for x :: 'a and xs
    by (simp add: sup_max[symmetric])
  show ?thesis
    using assms
    unfolding fold_keys_def_alt fold1_keys_def_alt is_empty_empty
    apply transfer
    apply (case_tac t)
     apply simp
    apply (subst *)
     apply simp
    apply (subst **)
    apply simp
    done
qed

end

section \<open>Code equations\<close>

code_datatype Set Coset

declare list.set[code] (* needed? *)

lemma empty_Set [code]:
  "Set.empty = Set RBT.empty"
by (auto simp: Set_def)

lemma UNIV_Coset [code]:
  "UNIV = Coset RBT.empty"
by (auto simp: Set_def)

lemma is_empty_Set [code]:
  "Set.is_empty (Set t) = RBT.is_empty t"
  unfolding Set.is_empty_def by (auto simp: fun_eq_iff Set_def intro: lookup_empty_empty[THEN iffD1])

lemma compl_code [code]:
  "- Set xs = Coset xs"
  "- Coset xs = Set xs"
by (simp_all add: Set_def)

lemma member_code [code]:
  "x \<in> (Set t) = (RBT.lookup t x = Some ())"
  "x \<in> (Coset t) = (RBT.lookup t x = None)"
by (simp_all add: Set_def)

lemma insert_code [code]:
  "Set.insert x (Set t) = Set (RBT.insert x () t)"
  "Set.insert x (Coset t) = Coset (RBT.delete x t)"
by (auto simp: Set_def)

lemma remove_code [code]:
  "Set.remove x (Set t) = Set (RBT.delete x t)"
  "Set.remove x (Coset t) = Coset (RBT.insert x () t)"
by (auto simp: Set_def)

lemma union_Set [code]:
  "Set t \<union> A = fold_keys Set.insert t A"
proof -
  interpret comp_fun_idem Set.insert
    by (fact comp_fun_idem_insert)
  from finite_fold_fold_keys[OF comp_fun_commute_axioms]
  show ?thesis by (auto simp add: union_fold_insert)
qed

lemma inter_Set [code]:
  "A \<inter> Set t = rbt_filter (\<lambda>k. k \<in> A) t"
by (simp add: inter_Set_filter Set_filter_rbt_filter)

lemma minus_Set [code]:
  "A - Set t = fold_keys Set.remove t A"
proof -
  interpret comp_fun_idem Set.remove
    by (fact comp_fun_idem_remove)
  from finite_fold_fold_keys[OF comp_fun_commute_axioms]
  show ?thesis by (auto simp add: minus_fold_remove)
qed

lemma union_Coset [code]:
  "Coset t \<union> A = - rbt_filter (\<lambda>k. k \<notin> A) t"
proof -
  have *: "\<And>A B. (-A \<union> B) = -(-B \<inter> A)" by blast
  show ?thesis by (simp del: boolean_algebra_class.compl_inf add: * inter_Set)
qed

lemma union_Set_Set [code]:
  "Set t1 \<union> Set t2 = Set (RBT.union t1 t2)"
by (auto simp add: lookup_union map_add_Some_iff Set_def)

lemma inter_Coset [code]:
  "A \<inter> Coset t = fold_keys Set.remove t A"
by (simp add: Diff_eq [symmetric] minus_Set)

lemma inter_Coset_Coset [code]:
  "Coset t1 \<inter> Coset t2 = Coset (RBT.union t1 t2)"
by (auto simp add: lookup_union map_add_Some_iff Set_def)

lemma minus_Coset [code]:
  "A - Coset t = rbt_filter (\<lambda>k. k \<in> A) t"
by (simp add: inter_Set[simplified Int_commute])

lemma filter_Set [code]:
  "Set.filter P (Set t) = (rbt_filter P t)"
by (auto simp add: Set_filter_rbt_filter)

lemma image_Set [code]:
  "image f (Set t) = fold_keys (\<lambda>k A. Set.insert (f k) A) t {}"
proof -
  have "comp_fun_commute (\<lambda>k. Set.insert (f k))"
    by standard auto
  then show ?thesis
    by (auto simp add: image_fold_insert intro!: finite_fold_fold_keys)
qed

lemma Ball_Set [code]:
  "Ball (Set t) P \<longleftrightarrow> RBT.foldi (\<lambda>s. s = True) (\<lambda>k v s. s \<and> P k) t True"
proof -
  have "comp_fun_commute (\<lambda>k s. s \<and> P k)"
    by standard auto
  then show ?thesis
    by (simp add: foldi_fold_conj[symmetric] Ball_fold finite_fold_fold_keys)
qed

lemma Bex_Set [code]:
  "Bex (Set t) P \<longleftrightarrow> RBT.foldi (\<lambda>s. s = False) (\<lambda>k v s. s \<or> P k) t False"
proof -
  have "comp_fun_commute (\<lambda>k s. s \<or> P k)"
    by standard auto
  then show ?thesis
    by (simp add: foldi_fold_disj[symmetric] Bex_fold finite_fold_fold_keys)
qed

lemma subset_code [code]:
  "Set t \<le> B \<longleftrightarrow> (\<forall>x\<in>Set t. x \<in> B)"
  "A \<le> Coset t \<longleftrightarrow> (\<forall>y\<in>Set t. y \<notin> A)"
by auto

lemma subset_Coset_empty_Set_empty [code]:
  "Coset t1 \<le> Set t2 \<longleftrightarrow> (case (RBT.impl_of t1, RBT.impl_of t2) of
    (rbt.Empty, rbt.Empty) \<Rightarrow> False |
    (_, _) \<Rightarrow> Code.abort (STR ''non_empty_trees'') (\<lambda>_. Coset t1 \<le> Set t2))"
proof -
  have *: "\<And>t. RBT.impl_of t = rbt.Empty \<Longrightarrow> t = RBT rbt.Empty"
    by (subst(asm) RBT_inverse[symmetric]) (auto simp: impl_of_inject)
  have **: "eq_onp is_rbt rbt.Empty rbt.Empty" unfolding eq_onp_def by simp
  show ?thesis
    by (auto simp: Set_def lookup.abs_eq[OF **] dest!: * split: rbt.split)
qed

text \<open>A frequent case -- avoid intermediate sets\<close>
lemma [code_unfold]:
  "Set t1 \<subseteq> Set t2 \<longleftrightarrow> RBT.foldi (\<lambda>s. s = True) (\<lambda>k v s. s \<and> k \<in> Set t2) t1 True"
by (simp add: subset_code Ball_Set)

lemma card_Set [code]:
  "card (Set t) = fold_keys (\<lambda>_ n. n + 1) t 0"
  by (auto simp add: card.eq_fold intro: finite_fold_fold_keys comp_fun_commute_const)

lemma sum_Set [code]:
  "sum f (Set xs) = fold_keys (plus \<circ> f) xs 0"
proof -
  have "comp_fun_commute (\<lambda>x. (+) (f x))"
    by standard (auto simp: ac_simps)
  then show ?thesis
    by (auto simp add: sum.eq_fold finite_fold_fold_keys o_def)
qed

lemma the_elem_set [code]:
  fixes t :: "('a :: linorder, unit) rbt"
  shows "the_elem (Set t) = (case RBT.impl_of t of
    (Branch RBT_Impl.B RBT_Impl.Empty x () RBT_Impl.Empty) \<Rightarrow> x
    | _ \<Rightarrow> Code.abort (STR ''not_a_singleton_tree'') (\<lambda>_. the_elem (Set t)))"
proof -
  {
    fix x :: "'a :: linorder"
    let ?t = "Branch RBT_Impl.B RBT_Impl.Empty x () RBT_Impl.Empty"
    have *:"?t \<in> {t. is_rbt t}" unfolding is_rbt_def by auto
    then have **:"eq_onp is_rbt ?t ?t" unfolding eq_onp_def by auto

    have "RBT.impl_of t = ?t \<Longrightarrow> the_elem (Set t) = x"
      by (subst(asm) RBT_inverse[symmetric, OF *])
        (auto simp: Set_def the_elem_def lookup.abs_eq[OF **] impl_of_inject)
  }
  then show ?thesis
    by(auto split: rbt.split unit.split color.split)
qed

lemma Pow_Set [code]: "Pow (Set t) = fold_keys (\<lambda>x A. A \<union> Set.insert x ` A) t {{}}"
  by (simp add: Pow_fold finite_fold_fold_keys[OF comp_fun_commute_Pow_fold])

lemma product_Set [code]:
  "Product_Type.product (Set t1) (Set t2) =
    fold_keys (\<lambda>x A. fold_keys (\<lambda>y. Set.insert (x, y)) t2 A) t1 {}"
proof -
  have *: "comp_fun_commute (\<lambda>y. Set.insert (x, y))" for x
    by standard auto
  show ?thesis using finite_fold_fold_keys[OF comp_fun_commute_product_fold, of "Set t2" "{}" "t1"]
    by (simp add: product_fold Product_Type.product_def finite_fold_fold_keys[OF *])
qed

lemma Id_on_Set [code]: "Id_on (Set t) =  fold_keys (\<lambda>x. Set.insert (x, x)) t {}"
proof -
  have "comp_fun_commute (\<lambda>x. Set.insert (x, x))"
    by standard auto
  then show ?thesis
    by (auto simp add: Id_on_fold intro!: finite_fold_fold_keys)
qed

lemma Image_Set [code]:
  "(Set t) `` S = fold_keys (\<lambda>(x,y) A. if x \<in> S then Set.insert y A else A) t {}"
by (auto simp add: Image_fold finite_fold_fold_keys[OF comp_fun_commute_Image_fold])

lemma trancl_set_ntrancl [code]:
  "trancl (Set t) = ntrancl (card (Set t) - 1) (Set t)"
by (simp add: finite_trancl_ntranl)

lemma relcomp_Set[code]:
  "(Set t1) O (Set t2) = fold_keys
    (\<lambda>(x,y) A. fold_keys (\<lambda>(w,z) A'. if y = w then Set.insert (x,z) A' else A') t2 A) t1 {}"
proof -
  interpret comp_fun_idem Set.insert
    by (fact comp_fun_idem_insert)
  have *: "\<And>x y. comp_fun_commute (\<lambda>(w, z) A'. if y = w then Set.insert (x, z) A' else A')"
    by standard (auto simp add: fun_eq_iff)
  show ?thesis
    using finite_fold_fold_keys[OF comp_fun_commute_relcomp_fold, of "Set t2" "{}" t1]
    by (simp add: relcomp_fold finite_fold_fold_keys[OF *])
qed

lemma wf_set [code]:
  "wf (Set t) = acyclic (Set t)"
by (simp add: wf_iff_acyclic_if_finite)

lemma Min_fin_set_fold [code]:
  "Min (Set t) =
  (if RBT.is_empty t
   then Code.abort (STR ''not_non_empty_tree'') (\<lambda>_. Min (Set t))
   else r_min_opt t)"
proof -
  have *: "semilattice (min :: 'a \<Rightarrow> 'a \<Rightarrow> 'a)" ..
  with finite_fold1_fold1_keys [OF *, folded Min_def]
  show ?thesis
    by (simp add: r_min_alt_def r_min_eq_r_min_opt [symmetric])
qed

lemma Inf_fin_set_fold [code]:
  "Inf_fin (Set t) = Min (Set t)"
by (simp add: inf_min Inf_fin_def Min_def)

lemma Inf_Set_fold:
  fixes t :: "('a :: {linorder, complete_lattice}, unit) rbt"
  shows "Inf (Set t) = (if RBT.is_empty t then top else r_min_opt t)"
proof -
  have "comp_fun_commute (min :: 'a \<Rightarrow> 'a \<Rightarrow> 'a)"
    by standard (simp add: fun_eq_iff ac_simps)
  then have "t \<noteq> RBT.empty \<Longrightarrow> Finite_Set.fold min top (Set t) = fold1_keys min t"
    by (simp add: finite_fold_fold_keys fold_keys_min_top_eq)
  then show ?thesis
    by (auto simp add: Inf_fold_inf inf_min empty_Set[symmetric]
      r_min_eq_r_min_opt[symmetric] r_min_alt_def)
qed

lemma Max_fin_set_fold [code]:
  "Max (Set t) =
  (if RBT.is_empty t
   then Code.abort (STR ''not_non_empty_tree'') (\<lambda>_. Max (Set t))
   else r_max_opt t)"
proof -
  have *: "semilattice (max :: 'a \<Rightarrow> 'a \<Rightarrow> 'a)" ..
  with finite_fold1_fold1_keys [OF *, folded Max_def]
  show ?thesis
    by (simp add: r_max_alt_def r_max_eq_r_max_opt [symmetric])
qed

lemma Sup_fin_set_fold [code]:
  "Sup_fin (Set t) = Max (Set t)"
by (simp add: sup_max Sup_fin_def Max_def)

lemma Sup_Set_fold:
  fixes t :: "('a :: {linorder, complete_lattice}, unit) rbt"
  shows "Sup (Set t) = (if RBT.is_empty t then bot else r_max_opt t)"
proof -
  have "comp_fun_commute (max :: 'a \<Rightarrow> 'a \<Rightarrow> 'a)"
    by standard (simp add: fun_eq_iff ac_simps)
  then have "t \<noteq> RBT.empty \<Longrightarrow> Finite_Set.fold max bot (Set t) = fold1_keys max t"
    by (simp add: finite_fold_fold_keys fold_keys_max_bot_eq)
  then show ?thesis
    by (auto simp add: Sup_fold_sup sup_max empty_Set[symmetric]
      r_max_eq_r_max_opt[symmetric] r_max_alt_def)
qed

context
begin

declare [[code drop: Gcd_fin Lcm_fin \<open>Gcd :: _ \<Rightarrow> nat\<close> \<open>Gcd :: _ \<Rightarrow> int\<close> \<open>Lcm :: _ \<Rightarrow> nat\<close> \<open>Lcm :: _ \<Rightarrow> int\<close>]]

lemma [code]:
  "Gcd (Set t) = (Gcd\<^sub>f\<^sub>i\<^sub>n (Set t) :: int)"
  by simp

lemma [code]:
  "Lcm\<^sub>f\<^sub>i\<^sub>n (Set t) = fold_keys lcm t (1::'a::{semiring_gcd, linorder})"
proof -
  have "comp_fun_commute (lcm :: 'a \<Rightarrow> _)"
    by standard (simp add: fun_eq_iff ac_simps)
  with finite_fold_fold_keys [of _ 1 t]
  have "Finite_Set.fold lcm 1 (Set t) = fold_keys lcm t 1"
    by blast
  then show ?thesis
    by (simp add: Lcm_fin.eq_fold)
qed

lemma [code drop: "Lcm :: _ \<Rightarrow> nat", code]:
  "Lcm (Set t) = (Lcm\<^sub>f\<^sub>i\<^sub>n (Set t) :: nat)"
  by simp

lemma [code drop: "Lcm :: _ \<Rightarrow> int", code]:
  "Lcm (Set t) = (Lcm\<^sub>f\<^sub>i\<^sub>n (Set t) :: int)"
  by simp

qualified definition Inf' :: "'a :: {linorder, complete_lattice} set \<Rightarrow> 'a"
  where [code_abbrev]: "Inf' = Inf"

lemma Inf'_Set_fold [code]:
  "Inf' (Set t) = (if RBT.is_empty t then top else r_min_opt t)"
  by (simp add: Inf'_def Inf_Set_fold)

qualified definition Sup' :: "'a :: {linorder, complete_lattice} set \<Rightarrow> 'a"
  where [code_abbrev]: "Sup' = Sup"

lemma Sup'_Set_fold [code]:
  "Sup' (Set t) = (if RBT.is_empty t then bot else r_max_opt t)"
  by (simp add: Sup'_def Sup_Set_fold)

end

lemma sorted_list_set[code]: "sorted_list_of_set (Set t) = RBT.keys t"
  by (auto simp add: set_keys intro: sorted_distinct_set_unique)

lemma Bleast_code [code]:
  "Bleast (Set t) P =
    (case List.filter P (RBT.keys t) of
      x # xs \<Rightarrow> x
    | [] \<Rightarrow> abort_Bleast (Set t) P)"
proof (cases "List.filter P (RBT.keys t)")
  case Nil
  thus ?thesis by (simp add: Bleast_def abort_Bleast_def)
next
  case (Cons x ys)
  have "(LEAST x. x \<in> Set t \<and> P x) = x"
  proof (rule Least_equality)
    show "x \<in> Set t \<and> P x"
      using Cons[symmetric]
      by (auto simp add: set_keys Cons_eq_filter_iff)
    next
      fix y
      assume "y \<in> Set t \<and> P y"
      then show "x \<le> y"
        using Cons[symmetric]
        by(auto simp add: set_keys Cons_eq_filter_iff)
          (metis sorted_wrt.simps(2) sorted_append sorted_keys)
  qed
  thus ?thesis using Cons by (simp add: Bleast_def)
qed

hide_const (open) RBT_Set.Set RBT_Set.Coset

end


theory E imports Main       (* Aqvist's System E: C. Benzmüller & X. Parent, 2019 *)
begin
typedecl i (*Possible worlds.*) type_synonym \<sigma> = "(i\<Rightarrow>bool)"
consts aw::i (*Actual world.*)
abbreviation etrue  :: "\<sigma>" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
abbreviation efalse :: "\<sigma>" ("\<^bold>\<bottom>")  where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
abbreviation enot :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>_"[52]53)  where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w)"
abbreviation eand :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<and>\<psi>(w)"
abbreviation eor  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<or>\<psi>(w)"
abbreviation eimp :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<rightarrow>"49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longrightarrow>\<psi>(w)"
abbreviation eequ :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<leftrightarrow>"48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longleftrightarrow>\<psi>(w)"

(*Possibilist--constant domain--quantification.*)
abbreviation eforall ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w.\<forall>x. (\<Phi> x w)"
abbreviation eforallB (binder"\<^bold>\<forall>"[8]9) where "\<^bold>\<forall>x. \<phi>(x) \<equiv> \<^bold>\<forall>\<phi>"
abbreviation eexists ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>w.\<exists>x. (\<Phi> x w)"
abbreviation eexistsB (binder"\<^bold>\<exists>"[8]9) where "\<^bold>\<exists>x. \<phi>(x) \<equiv> \<^bold>\<exists>\<phi>"

abbreviation ebox :: "\<sigma>\<Rightarrow>\<sigma>" ("\<box>") where "\<box> \<equiv> \<lambda>\<phi> w.  \<forall>v. \<phi>(v)"
consts R :: "i\<Rightarrow>\<sigma>" (infixr "R" 70) (*Betterness relation, cf. def. of \<circle><_|_>.*)
abbreviation eopt  :: "\<sigma>\<Rightarrow>\<sigma>" ("opt<_>")
  where "opt<\<phi>> \<equiv> (\<lambda>v. ( (\<phi>)(v) \<and> (\<forall>x. ((\<phi>)(x)  \<longrightarrow>  v R x) )) )"
abbreviation esubset :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" (infix "\<^bold>\<subseteq>" 53)
  where "\<phi> \<^bold>\<subseteq> \<psi> \<equiv> \<forall>x. \<phi> x \<longrightarrow> \<psi> x"
abbreviation econd  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\<circle><_|_>")
  where "\<circle><\<psi>|\<phi>> \<equiv>  \<lambda>w. opt<\<phi>> \<^bold>\<subseteq> \<psi>"
abbreviation euncobl :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<circle><_>")
  where "\<^bold>\<circle><\<phi>> \<equiv> \<circle><\<phi>|\<^bold>\<top>>"

abbreviation evalid :: "\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>"[8]109)  (*Global validity.*)
  where "\<lfloor>p\<rfloor> \<equiv> \<forall>w. p w"
abbreviation ecjactual :: "\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sub>l"[7]105) (*Local validity — in world aw.*)
  where "\<lfloor>p\<rfloor>\<^sub>l \<equiv> p(aw)"

lemma True nitpick [satisfy,user_axioms,expect=genuine] oops (*Consistency conf.*)

(*Correspondence theory.*)
lemma assumes "\<forall>x y z. x R y \<and> y R z \<longrightarrow> x R z"
      shows "\<lfloor>((\<circle><\<psi>|\<phi>>) \<^bold>\<and> \<^bold>\<not>(\<circle><\<^bold>\<not>\<xi>|\<phi>>)) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<xi>>\<rfloor>"
  using assms by blast

lemma assumes "\<lfloor>((\<circle><\<psi>|\<phi>>) \<^bold>\<and> \<^bold>\<not>(\<circle><\<^bold>\<not>\<xi>|\<phi>>)) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<xi>>\<rfloor>"
      shows "\<forall>x y z. x R y \<and> y R z \<longrightarrow> x R z"
  nitpick [show_all,format=2] oops (*Countermodel presented by Nitpick.*)
end