section \<open>Type Classes\<close>

theory Type_Classes
  imports HOLCF_Main
begin

subsection \<open>Eq class\<close>

class Eq =
  fixes eq :: "'a \<rightarrow> 'a \<rightarrow> tr"

text \<open>
  The Haskell type class does allow /= to be specified separately. For now, we assume
  that all modeled type classes use the default implementation, or an equivalent.
\<close>
fixrec neq :: "'a::Eq \<rightarrow> 'a \<rightarrow> tr" where
  "neq\<cdot>x\<cdot>y = neg\<cdot>(eq\<cdot>x\<cdot>y)"

class Eq_strict = Eq +
  assumes eq_strict [simp]:
    "eq\<cdot>x\<cdot>\<bottom> = \<bottom>"
    "eq\<cdot>\<bottom>\<cdot>y = \<bottom>"

class Eq_sym = Eq_strict +
  assumes eq_sym: "eq\<cdot>x\<cdot>y = eq\<cdot>y\<cdot>x"

class Eq_equiv = Eq_sym +
  assumes eq_self_neq_FF [simp]: "eq\<cdot>x\<cdot>x \<noteq> FF"
    and eq_trans: "eq\<cdot>x\<cdot>y = TT \<Longrightarrow> eq\<cdot>y\<cdot>z = TT \<Longrightarrow> eq\<cdot>x\<cdot>z = TT"
begin

lemma eq_refl: "eq\<cdot>x\<cdot>x \<noteq> \<bottom> \<Longrightarrow> eq\<cdot>x\<cdot>x = TT"
  by (cases "eq\<cdot>x\<cdot>x") simp+

end

class Eq_eq = Eq_sym +
  assumes eq_self_neq_FF': "eq\<cdot>x\<cdot>x \<noteq> FF"
    and eq_TT_dest: "eq\<cdot>x\<cdot>y = TT \<Longrightarrow> x = y"
begin

subclass Eq_equiv
  by standard (auto simp: eq_self_neq_FF' dest: eq_TT_dest)

lemma eqD [dest]:
  "eq\<cdot>x\<cdot>y = TT \<Longrightarrow> x = y"
  "eq\<cdot>x\<cdot>y = FF \<Longrightarrow> x \<noteq> y"
  by (auto elim: eq_TT_dest)

end

subsubsection \<open>Class instances\<close>

instantiation lift :: (countable) Eq_eq
begin

definition "eq \<equiv> (\<Lambda>(Def x) (Def y). Def (x = y))"

instance
  by standard (auto simp: eq_lift_def flift1_def split: lift.splits)

end

lemma eq_ONE_ONE [simp]: "eq\<cdot>ONE\<cdot>ONE = TT"
  unfolding ONE_def eq_lift_def by simp

subsection \<open>Ord class\<close>

domain Ordering = LT | EQ | GT

definition oppOrdering :: "Ordering \<rightarrow> Ordering" where
  "oppOrdering = (\<Lambda> x. case x of LT \<Rightarrow> GT | EQ \<Rightarrow> EQ | GT \<Rightarrow> LT)"

lemma oppOrdering_simps [simp]:
  "oppOrdering\<cdot>LT = GT"
  "oppOrdering\<cdot>EQ = EQ"
  "oppOrdering\<cdot>GT = LT"
  "oppOrdering\<cdot>\<bottom> = \<bottom>"
  unfolding oppOrdering_def by simp_all

class Ord = Eq +
  fixes compare :: "'a \<rightarrow> 'a \<rightarrow> Ordering"
begin

definition lt :: "'a \<rightarrow> 'a \<rightarrow> tr" where
  "lt = (\<Lambda> x y. case compare\<cdot>x\<cdot>y of LT \<Rightarrow> TT | EQ \<Rightarrow> FF | GT \<Rightarrow> FF)"

definition le :: "'a \<rightarrow> 'a \<rightarrow> tr" where
  "le = (\<Lambda> x y. case compare\<cdot>x\<cdot>y of LT \<Rightarrow> TT | EQ \<Rightarrow> TT | GT \<Rightarrow> FF)"

lemma lt_eq_TT_iff: "lt\<cdot>x\<cdot>y = TT \<longleftrightarrow> compare\<cdot>x\<cdot>y = LT"
  by (cases "compare\<cdot>x\<cdot>y") (simp add: lt_def)+

end

class Ord_strict = Ord +
  assumes compare_strict [simp]:
    "compare\<cdot>\<bottom>\<cdot>y = \<bottom>"
    "compare\<cdot>x\<cdot>\<bottom> = \<bottom>"
begin

lemma lt_strict [simp]:
  shows "lt\<cdot>\<bottom>\<cdot>x = \<bottom>"
    and "lt\<cdot>x\<cdot>\<bottom> = \<bottom>"
  by (simp add: lt_def)+

lemma le_strict [simp]:
  shows "le\<cdot>\<bottom>\<cdot>x = \<bottom>"
    and "le\<cdot>x\<cdot>\<bottom> = \<bottom>"
  by (simp add: le_def)+

end

text \<open>TODO: It might make sense to have a class for preorders too,
analogous to class \<open>eq_equiv\<close>.\<close>

class Ord_linear = Ord_strict +
  assumes eq_conv_compare: "eq\<cdot>x\<cdot>y = is_EQ\<cdot>(compare\<cdot>x\<cdot>y)"
    and oppOrdering_compare [simp]:
    "oppOrdering\<cdot>(compare\<cdot>x\<cdot>y) = compare\<cdot>y\<cdot>x"
    and compare_EQ_dest: "compare\<cdot>x\<cdot>y = EQ \<Longrightarrow> x = y"
    and compare_self_below_EQ: "compare\<cdot>x\<cdot>x \<sqsubseteq> EQ"
    and compare_LT_trans:
    "compare\<cdot>x\<cdot>y = LT \<Longrightarrow> compare\<cdot>y\<cdot>z = LT \<Longrightarrow> compare\<cdot>x\<cdot>z = LT"
  (*BH: Is this set of axioms complete?*)
  (*CS: How about totality of the order?*)
begin

lemma eq_TT_dest: "eq\<cdot>x\<cdot>y = TT \<Longrightarrow> x = y"
  by (cases "compare\<cdot>x\<cdot>y") (auto dest: compare_EQ_dest simp: eq_conv_compare)+

lemma le_iff_lt_or_eq:
  "le\<cdot>x\<cdot>y = TT \<longleftrightarrow> lt\<cdot>x\<cdot>y = TT \<or> eq\<cdot>x\<cdot>y = TT"
  by (cases "compare\<cdot>x\<cdot>y") (simp add: le_def lt_def eq_conv_compare)+

lemma compare_sym:
  "compare\<cdot>x\<cdot>y = (case compare\<cdot>y\<cdot>x of LT \<Rightarrow> GT | EQ \<Rightarrow> EQ | GT \<Rightarrow> LT)"
  by (subst oppOrdering_compare [symmetric]) (simp add: oppOrdering_def)

lemma compare_self_neq_LT [simp]: "compare\<cdot>x\<cdot>x \<noteq> LT"
  using compare_self_below_EQ [of x] by clarsimp

lemma compare_self_neq_GT [simp]: "compare\<cdot>x\<cdot>x \<noteq> GT"
  using compare_self_below_EQ [of x] by clarsimp

declare compare_self_below_EQ [simp]

lemma lt_trans: "lt\<cdot>x\<cdot>y = TT \<Longrightarrow> lt\<cdot>y\<cdot>z = TT \<Longrightarrow> lt\<cdot>x\<cdot>z = TT"
  unfolding lt_eq_TT_iff by (rule compare_LT_trans)

lemma compare_GT_iff_LT: "compare\<cdot>x\<cdot>y = GT \<longleftrightarrow> compare\<cdot>y\<cdot>x = LT"
  by (cases "compare\<cdot>x\<cdot>y", simp_all add: compare_sym [of y x])

lemma compare_GT_trans:
  "compare\<cdot>x\<cdot>y = GT \<Longrightarrow> compare\<cdot>y\<cdot>z = GT \<Longrightarrow> compare\<cdot>x\<cdot>z = GT"
  unfolding compare_GT_iff_LT by (rule compare_LT_trans)

lemma compare_EQ_iff_eq_TT:
  "compare\<cdot>x\<cdot>y = EQ \<longleftrightarrow> eq\<cdot>x\<cdot>y = TT"
  by (cases "compare\<cdot>x\<cdot>y") (simp add: is_EQ_def eq_conv_compare)+

lemma compare_EQ_trans:
  "compare\<cdot>x\<cdot>y = EQ \<Longrightarrow> compare\<cdot>y\<cdot>z = EQ \<Longrightarrow> compare\<cdot>x\<cdot>z = EQ"
  by (blast dest: compare_EQ_dest)

lemma le_trans:
  "le\<cdot>x\<cdot>y = TT \<Longrightarrow> le\<cdot>y\<cdot>z = TT \<Longrightarrow> le\<cdot>x\<cdot>z = TT"
  by (auto dest: eq_TT_dest lt_trans simp: le_iff_lt_or_eq)

lemma neg_lt: "neg\<cdot>(lt\<cdot>x\<cdot>y) = le\<cdot>y\<cdot>x"
  by (cases "compare\<cdot>x\<cdot>y", simp_all add: le_def lt_def compare_sym [of y x])

lemma neg_le: "neg\<cdot>(le\<cdot>x\<cdot>y) = lt\<cdot>y\<cdot>x"
  by (cases "compare\<cdot>x\<cdot>y", simp_all add: le_def lt_def compare_sym [of y x])

subclass Eq_eq
proof
  fix x y
  show "eq\<cdot>x\<cdot>y = eq\<cdot>y\<cdot>x"
    unfolding eq_conv_compare
    by (cases "compare\<cdot>x\<cdot>y", simp_all add: compare_sym [of y x])
  show "eq\<cdot>x\<cdot>\<bottom> = \<bottom>"
    unfolding eq_conv_compare by simp
  show "eq\<cdot>\<bottom>\<cdot>y = \<bottom>"
    unfolding eq_conv_compare by simp
  show "eq\<cdot>x\<cdot>x \<noteq> FF"
    unfolding eq_conv_compare
    by (cases "compare\<cdot>x\<cdot>x", simp_all)
  { assume "eq\<cdot>x\<cdot>y = TT" then show "x = y"
      unfolding eq_conv_compare
      by (cases "compare\<cdot>x\<cdot>y", auto dest: compare_EQ_dest) }
qed

end

text \<open>A combinator for defining Ord instances for datatypes.\<close>

definition thenOrdering :: "Ordering \<rightarrow> Ordering \<rightarrow> Ordering" where
  "thenOrdering = (\<Lambda> x y. case x of LT \<Rightarrow> LT | EQ \<Rightarrow> y | GT \<Rightarrow> GT)"

lemma thenOrdering_simps [simp]:
  "thenOrdering\<cdot>LT\<cdot>y = LT"
  "thenOrdering\<cdot>EQ\<cdot>y = y"
  "thenOrdering\<cdot>GT\<cdot>y = GT"
  "thenOrdering\<cdot>\<bottom>\<cdot>y = \<bottom>"
  unfolding thenOrdering_def by simp_all

lemma thenOrdering_LT_iff [simp]:
  "thenOrdering\<cdot>x\<cdot>y = LT \<longleftrightarrow> x = LT \<or> x = EQ \<and> y = LT"
  by (cases x, simp_all)

lemma thenOrdering_EQ_iff [simp]:
  "thenOrdering\<cdot>x\<cdot>y = EQ \<longleftrightarrow> x = EQ \<and> y = EQ"
  by (cases x, simp_all)

lemma thenOrdering_GT_iff [simp]:
  "thenOrdering\<cdot>x\<cdot>y = GT \<longleftrightarrow> x = GT \<or> x = EQ \<and> y = GT"
  by (cases x, simp_all)

lemma thenOrdering_below_EQ_iff [simp]:
  "thenOrdering\<cdot>x\<cdot>y \<sqsubseteq> EQ \<longleftrightarrow> x \<sqsubseteq> EQ \<and> (x = \<bottom> \<or> y \<sqsubseteq> EQ)"
  by (cases x) simp_all

lemma is_EQ_thenOrdering [simp]:
  "is_EQ\<cdot>(thenOrdering\<cdot>x\<cdot>y) = (is_EQ\<cdot>x andalso is_EQ\<cdot>y)"
  by (cases x) simp_all

lemma oppOrdering_thenOrdering:
  "oppOrdering\<cdot>(thenOrdering\<cdot>x\<cdot>y) =
    thenOrdering\<cdot>(oppOrdering\<cdot>x)\<cdot>(oppOrdering\<cdot>y)"
  by (cases x) simp_all

instantiation lift :: ("{linorder,countable}") Ord_linear
begin

definition
  "compare \<equiv> (\<Lambda> (Def x) (Def y).
    if x < y then LT else if x > y then GT else EQ)"

instance proof
  fix x y z :: "'a lift"
  show "compare\<cdot>\<bottom>\<cdot>y = \<bottom>"
    unfolding compare_lift_def by simp
  show "compare\<cdot>x\<cdot>\<bottom> = \<bottom>"
    unfolding compare_lift_def by (cases x, simp_all)
  show "oppOrdering\<cdot>(compare\<cdot>x\<cdot>y) = compare\<cdot>y\<cdot>x"
    unfolding compare_lift_def
    by (cases x, cases y, simp, simp,
      cases y, simp, simp add: not_less less_imp_le)
  { assume "compare\<cdot>x\<cdot>y = EQ" then show "x = y"
      unfolding compare_lift_def
      by (cases x, cases y, simp, simp,
        cases y, simp, simp split: if_splits) }
  { assume "compare\<cdot>x\<cdot>y = LT" and "compare\<cdot>y\<cdot>z = LT" then show "compare\<cdot>x\<cdot>z = LT"
      unfolding compare_lift_def
      by (cases x, simp, cases y, simp, cases z, simp,
        auto split: if_splits) }
  show "eq\<cdot>x\<cdot>y = is_EQ\<cdot>(compare\<cdot>x\<cdot>y)"
    unfolding eq_lift_def compare_lift_def
    by (cases x, simp, cases y, simp, auto)
  show "compare\<cdot>x\<cdot>x \<sqsubseteq> EQ"
    unfolding compare_lift_def
    by (cases x, simp_all)
qed

end

lemma lt_le:
  "lt\<cdot>(x::'a::Ord_linear)\<cdot>y = (le\<cdot>x\<cdot>y andalso neq\<cdot>x\<cdot>y)"
  by (cases "compare\<cdot>x\<cdot>y")
     (auto simp: lt_def le_def eq_conv_compare)

end


theory Chapter11
imports "HOL-IMP.Denotational" "HOL-IMP.Vars" "Short_Theory"
begin

text\<open>
\section*{Chapter 11}

\begin{exercise}
Building on Exercise~\ref{exe:IMP:REPEAT}, extend the denotational
semantics and the equivalence proof with the big-step semantics
with a @{text REPEAT} loop.
\end{exercise}

\exercise
Consider Example~11.14 and prove the following equation by induction on @{text n}:
\<close>
lemma "((W (\<lambda>s. s ''x'' \<noteq> 0) ({(s,t). t = s(''x'' := s ''x'' - 1)}))^^n) {} =
  {(s,t). 0 \<le> s ''x'' & s ''x'' < int n & t = s(''x'' := 0)}"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
Consider Example~11.14 but with the loop condition
@{prop"b = Less (N 0) (V ''x'')"}. Find a closed expression @{text M}
(containing @{text n})
for @{prop"(f ^^ n) {}"} and prove @{prop"(f ^^ n) {} = M"}.
\<close>

text \<open>
\endexercise

\exercise
Define an operator @{text B} such that you
can express the equation for @{term "D (IF b THEN c1 ELSE c2)"}
in a point free way.
\<close>
definition B :: "bexp \<Rightarrow> (state \<times> state) set"  where
(* your definition/proof here *)

lemma
  "D (IF b THEN c1 ELSE c2) = (B b O D c1) \<union> (B (Not b) O D c2)"
(* your definition/proof here *)

text \<open>
  Similarly, find a point free equation for @{term "W (bval b) dc"}
  and use it to write down a point free version of
  @{term "D (WHILE b DO c)"} (still using @{text lfp}).
  Prove that your equations are equivalent to the old ones.
\<close>

(* your definition/proof here *)

text\<open>
\endexercise

\exercise
Let the 'thin' part of a relation be its single-valued subset:
\<close>

definition thin :: "'a rel \<Rightarrow> 'a rel" where
"thin R = {(a,b) . (a,b) \<in> R \<and> (\<forall> c. (a,c) \<in> R \<longrightarrow> c = b)}"

text\<open> Prove \<close>

lemma fixes f :: "'a rel \<Rightarrow> 'a rel"
assumes "mono f" and thin_f: "\<And> R. f (thin R) \<subseteq> thin (f R)"
shows "single_valued (lfp f)"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
Generalise our set-theoretic treatment of continuity and least fixpoints to
\concept{chain-complete partial order}s (\concept{cpo}s),
i.e.\ partial orders @{text"\<le>"} that have a least element @{text "\<bottom>"} and
where every chain @{text"c 0 \<le> c 1 \<le> \<dots>"} has a least upper bound
@{term"lub c"} where \noquotes{@{term[source]"c :: nat \<Rightarrow> 'a"}}.
This setting is described by the following type class @{text cpo}
which is an extension of the type class @{class order} of partial orders.
For details see the decription of type classes in Chapter~13.
\<close>

context order
begin
definition chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
"chain c = (\<forall>n. c n \<le> c (Suc n))"
end

class cpo = order +
fixes bot :: 'a and lub :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a"
assumes bot_least: "bot \<le> x"
and lub_ub: "chain c \<Longrightarrow> c n \<le> lub c"
and lub_least: "chain c \<Longrightarrow> (\<And>n. c n \<le> u) \<Longrightarrow> lub c \<le> u"

text\<open>
A function \noquotes{@{term[source] "f :: 'a \<Rightarrow> 'b"}}
between two cpos @{typ 'a} and @{typ 'b}
is called \concept{continuous} if @{prop"f(lub c) = lub (f o c)"}.
Prove that if @{text f} is monotone and continuous then
\ \mbox{@{text"lub (\<lambda>n. (f ^^ n) \<bottom>)"}} \ is the least (pre)fixpoint of @{text f}:
\<close>

definition cont :: "('a::cpo \<Rightarrow> 'b::cpo) \<Rightarrow> bool" where
"cont f = (\<forall>c. chain c \<longrightarrow> f (lub c) = lub (f o c))"

abbreviation "fix f \<equiv> lub (\<lambda>n. (f^^n) bot)"

lemma fix_lpfp: assumes "mono f" and "f p \<le> p" shows "fix f \<le> p"
(* your definition/proof here *)

theorem fix_fp: assumes "mono f" and "cont f" shows "f(fix f) = fix f"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
We define a dependency analysis @{text Dep} that maps commands to relations
between variables such that @{term "(x,y) : Dep c"} means that in
the execution of @{text c}
the initial value of @{text x} can influence the final value of @{text y}:
\<close>

fun Dep :: "com \<Rightarrow> (vname * vname) set" where
"Dep SKIP = Id" |
"Dep (x::=a) = {(u,v). if v = x then u \<in> vars a else u = v}" |
"Dep (c1;;c2) = Dep c1 O Dep c2" |
"Dep (IF b THEN c1 ELSE c2) = Dep c1 \<union> Dep c2 \<union> vars b \<times> UNIV" |
"Dep (WHILE b DO c) = lfp(\<lambda>R. Id \<union> vars b \<times> UNIV \<union> Dep c O R)"

text\<open>
where @{text"\<times>"} is the cross product of two sets.
Prove monotonicity of the function @{const lfp} is applied to.
\<close>

text\<open> For the correctness statement define \<close>

abbreviation Deps :: "com \<Rightarrow> vname set \<Rightarrow> vname set" where
"Deps c X \<equiv> (\<Union> x\<in>X. {y. (y,x) : Dep c})"

text\<open> and prove \<close>

lemma "\<lbrakk> (c,s) \<Rightarrow> s';  (c,t) \<Rightarrow> t';  s = t on Deps c X \<rbrakk> \<Longrightarrow> s' = t' on X"
(* your definition/proof here *)

text\<open>

Give an example that the following stronger termination-sensitive property
@{prop[display] "\<lbrakk> (c,s) \<Rightarrow> s'; s = t on Deps c X \<rbrakk>
  \<Longrightarrow> \<exists>t'. (c,t) \<Rightarrow> t' \<and> s' = t' on X"}
does not hold. Hint: @{prop"X = {}"}.

In the definition of @{term"Dep(IF b THEN c1 ELSE c2)"} the variables
in @{text b} can influence all variables (@{text UNIV}). However,
if a variable is not assigned to in @{text c1} and @{text c2}
it is not influenced by @{text b} (ignoring termination).
Theory @{short_theory "Vars"} defines a function @{const lvars} such
that @{term"lvars c"} is the set of variables on the left-hand side
of an assignment in @{text c}.
Modify the definition of @{const Dep} as follows:
replace @{const UNIV} by @{term"lvars c1 \<union> lvars c2"}
(in the case @{term"IF b THEN c1 ELSE c2"}) and by \mbox{@{term"lvars c"}}
(in the case @{term"WHILE b DO c"}).
Adjust the proof of the above correctness statement.
\<close>

text\<open>
\endexercise
\<close>

end


theory Swap
imports Helper "HOL-Combinatorics.Transposition" BeispielTac
begin

section\<open>Swap\<close>
text\<open>In diesem Abschnitt werden wir eine swap Funktion bauen,
welche es erlaubt Eigenschaften von Personen auszutauschen.
Wenn wir beispielsweise eine Funktion haben welche Personen ihren Besitz zuordnet,
beispielsweise \<^term_type>\<open>besitz :: 'person \<Rightarrow> int\<close>,
so soll die swap Funktion es erlauben, den Besitz von zwei Personen \<^term_type>\<open>p1::'person\<close> und
\<^term_type>\<open>p2::'person\<close> zu vertauschen.
So soll \<^term>\<open>swap (p1::'person) (p2::'person) (besitz :: 'person \<Rightarrow> int)\<close>
die \<^term>\<open>besitz :: 'person \<Rightarrow> int\<close> Funktion zurückgeben,
allerdings mit dem Besitz von \<^term>\<open>p1::'person\<close> und \<^term>\<open>p2::'person\<close> vertauscht.
\<close>

(*
Initially, I introduced my own swap implementation as `swap a b f = f(a:=f b, b:= f a)`.
But then I found that Isabelle/HOL already provides this implementation.
*)

definition swap :: \<open>'a \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b\<close> where
  \<open>swap a b f \<equiv> Fun.swap a b f\<close>

beispiel \<open>swap a b f = f(a:=f b, b:= f a)\<close>
  by (simp add: Fun.swap_def swap_def)

lemma swap1[simp]: \<open>swap a b (swap a b f) = f\<close>
  by (simp add: swap_def swap_nilpotent)
lemma swap2[simp]: \<open>swap b a (swap a b f) = f\<close>
  by (simp add: swap_def swap_nilpotent transpose_commute)

beispiel \<open>(swap p1 p2 swap) p1 p2 x = x\<close> (*wow, types*)
  by(simp add: swap_def)
beispiel \<open>(swap p2 p1 swap) p1 p2 x = x\<close> (*wow, types*)
  by(simp add: swap_def)

lemma swap_id[simp]: \<open>swap a a f = f\<close>
  by(simp add: swap_def)

beispiel \<open>f_swapped = (swap a b f) \<Longrightarrow> f_swapped a = f b \<and> f_swapped b = f a\<close>
  by(simp add: swap_def)

(*TODO rename*)
lemma swap_symmetric: \<open>swap a b = swap b a\<close>
  unfolding swap_def
  by (simp add: swap_commute)
lemma map_swap_none: \<open>a \<notin> set P \<Longrightarrow> b \<notin> set P \<Longrightarrow> map (swap a b f) P = map f P\<close>
  by (simp add: swap_def Fun.swap_def)

lemma map_swap_one: \<open>a \<notin> set P \<Longrightarrow>  map (swap a b f) P = map (f(b:=f a)) P\<close>
  by(simp add: swap_def Fun.swap_def)

lemma swap_a: \<open>swap a b f a = f b\<close>
  by(simp add: swap_def)
lemma swap_b: \<open>swap a b f b = f a\<close>
  by(simp add: swap_def)

lemma sum_swap_none: \<open>a \<notin> P \<Longrightarrow> b \<notin> P \<Longrightarrow> sum (swap a b f) P = sum f P\<close>
  apply(rule sum.cong, simp)
  apply(simp add: swap_def Fun.swap_def)
  by fastforce
lemma swap_nothing: \<open>a \<noteq> p1 \<Longrightarrow> a \<noteq> p2 \<Longrightarrow> swap p1 p2 f a = f a\<close>
  by(simp add: swap_def)

lemma swap_id_comp: \<open>swap a a = id\<close>
  by(simp add: fun_eq_iff)
lemma swap_fun_comp_id:
  \<open>swap p1 p2 (f \<circ> swap p1 p2 (f \<circ> kons)) = f \<circ> (f \<circ> kons)\<close>
  apply(simp add: comp_def fun_eq_iff)
  apply(simp add: swap_def)
  done
lemma swap_fun_map_comp_id:
  \<open>swap p1 p2 (map (swap p1 p2) \<circ> swap p1 p2 (map (swap p1 p2) \<circ> kons)) = kons\<close>
  apply(simp add: comp_def fun_eq_iff)
  apply(simp add: swap_def swap_id_comp)
  by (simp add: map_idI)

lemma swap_forall: \<open>(\<forall>p. P (swap p1 p2 a p) (swap p1 p2 b p)) \<longleftrightarrow> (\<forall>p. P (a p) (b p))\<close>
  apply(simp add: swap_def)
  by (metis transpose_involutory)

(*
whenever a prove can be solved by (metis swap_a swap_b swap_nothing)
maybe by(rule swap_cases, simp_all add: swap_a swap_b swap_nothing)
can be faster
*)
lemma swap_cases:
  \<open>(p = p1 \<Longrightarrow> P (f p2)) \<Longrightarrow> (p = p2 \<Longrightarrow> P (f p1)) \<Longrightarrow> (p \<noteq> p1 \<Longrightarrow> p \<noteq> p2 \<Longrightarrow> P (f p))\<Longrightarrow> P (swap p1 p2 f p)\<close>
apply(case_tac \<open>p=p1\<close>, simp add: swap_a)
apply(case_tac \<open>p=p2\<close>, simp add: swap_b)
apply(simp add: swap_nothing)
done

lemma swap_in_set_of_functions:
  \<open>swap p2 p1 x \<in> A \<longleftrightarrow> x \<in> swap p1 p2 ` A\<close>
  using image_iff by fastforce

lemma swap_image: \<open>p1 \<in> A \<Longrightarrow> p2 \<in> A \<Longrightarrow> swap p1 p2 f ` A = f ` A\<close>
  apply(simp add: image_def)
  apply(rule Collect_cong)
  by (metis swap_a swap_b swap_nothing)

lemma swap_id_eq_simp: \<open>swap p1 p2 id a = swap p1 p2 id b \<longleftrightarrow> a = b\<close>
  by (metis id_apply swap_a swap_nothing swap_symmetric)

lemma swap_id_in_set:
  \<open>swap p2 p1 id x \<in> swap p1 p2 id ` A \<longleftrightarrow> x \<in> A\<close>
  apply(simp add: image_iff)
  by (simp add: swap_id_eq_simp swap_symmetric)

thm sum.remove
lemma sum_swap_a: \<open>finite P \<Longrightarrow> a \<notin> P \<Longrightarrow> b \<in> P \<Longrightarrow> sum (swap a b f) P = f a + sum f (P - {b})\<close>
  apply(subst sum.remove[of \<open>P\<close> \<open>b\<close>])
  by(simp_all add: swap_b sum_swap_none)

lemma sum_list_swap: \<open>p1 \<in> set P \<Longrightarrow> p2 \<in> set P \<Longrightarrow> distinct P \<Longrightarrow>
        sum_list (map (swap p1 p2 f) P) = sum_list (map (f::'a\<Rightarrow>int) P)\<close>
  apply(simp add: sum_list_map_eq_sum_count_int)
  apply(simp add: count_list_distinct)
  thm sum.cong
  apply(induction \<open>P\<close> arbitrary: \<open>p1\<close> \<open>p2\<close>)
   apply(simp)
  apply(simp)
  apply(elim disjE)
     apply(simp_all)
    apply(simp add: swap_a sum_swap_a sum.remove[symmetric]; fail)
   apply(simp add: swap_symmetric swap_a sum_swap_a sum.remove[symmetric]; fail)
  apply(rule swap_nothing)
  by auto

lemma min_list_swap_int:
  fixes f::\<open>'person \<Rightarrow> int\<close>
  shows \<open>p1 \<in> set ps \<Longrightarrow> p2 \<in> set ps \<Longrightarrow> min_list (map (swap p1 p2 f) ps) = min_list (map f ps)\<close>
  apply(cases \<open>ps = []\<close>)
   apply(simp; fail)
  apply(simp add: min_list_Min)
  apply(cases \<open>p1 = p2\<close>)
   apply(simp; fail)
  apply(rule arg_cong[where f=\<open>Min\<close>])
  apply(simp add: swap_image)
  done

lemma min_list_swap_int_enum:
  fixes f::\<open>'person::enum \<Rightarrow> int\<close>
  shows \<open>min_list (map (swap p1 p2 f) enum_class.enum) = min_list (map f enum_class.enum)\<close>
  apply(subst min_list_swap_int)
  by(simp_all add: enum_class.enum_UNIV)

lemma remove1_swap:
  \<open>remove1 (swap p1 p2 a) (map (swap p1 p2) ks)
    = map (swap p1 p2) (remove1 a ks)\<close>
  apply(induction \<open>ks\<close>)
   apply(simp)
  apply(simp)
  by (metis swap2)

lemma remove1_swap2:
  \<open>map (swap p1 p2) (remove1 (swap p1 p2 a) (map (swap p1 p2) ks))
    =  remove1 a ks\<close>
  apply(induction \<open>ks\<close>)
   apply(simp)
  apply(simp add: comp_def)
  by (metis (mono_tags, lifting) swap2)

lemma swap_if_move_inner:
  \<open>swap p2 p1 (\<lambda>p. if P p then A p else B p)
    = (\<lambda>p. if P (swap p2 p1 id p) then A (swap p2 p1 id p) else B (swap p2 p1 id p))\<close>
  by(simp add: swap_def fun_eq_iff)

lemma swap_fun_swap_id: \<open>swap p1 p2 konsens (swap p1 p2 id p) = konsens p\<close>
  apply(cases \<open>p=p1\<close>)
   apply(simp add: swap_a swap_b)
  apply(cases \<open>p=p2\<close>)
   apply(simp add: swap_a swap_b)
  by(simp add: swap_nothing)

(*TODO: baut swap eine Permutation und gibt es darauf lemmata?
TODO: HOL-Combinatorics.Permutations
*)
lemma \<open>distinct [p1,p2,p3,p4] \<Longrightarrow> swap p1 p2 (swap p3 p4 welt) = swap p3 p4 (swap p1 p2 welt)\<close>
  by(auto simp add: swap_def Fun.swap_def)

lemma swap_comm: \<open>p1 \<noteq> p3 \<Longrightarrow> p1 \<noteq> p4 \<Longrightarrow> p2 \<noteq> p3 \<Longrightarrow> p2 \<noteq> p4 \<Longrightarrow>
  swap p1 p2 (swap p3 p4 welt) = swap p3 p4 (swap p1 p2 welt)\<close>
  by(auto simp add: swap_def Fun.swap_def)

lemma swap_unrelated_im_kreis:
  \<open>p \<noteq> p1 \<Longrightarrow> p \<noteq> p2 \<Longrightarrow>
    swap p2 p (swap p1 p2 (swap p p1 (swap p1 p2 welt))) = welt\<close>
  by(simp add: swap_def Fun.swap_def)

end


section \<open>Boolean Programs\<close>
theory BoolProgs
imports
  CAVA_Base.CAVA_Base
begin

subsection \<open>Syntax and Semantics\<close>

datatype bexp = TT | FF | V nat | Not bexp | And bexp bexp | Or bexp bexp

type_synonym state = "bitset"

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval TT s = True" |
"bval FF s = False" |
"bval (V n) s = bs_mem n s" |
"bval (Not b) s = (\<not> bval b s)" |
"bval (And b\<^sub>1 b\<^sub>2) s = (bval b\<^sub>1 s & bval b\<^sub>2 s)" |
"bval (Or b\<^sub>1 b\<^sub>2) s = (bval b\<^sub>1 s | bval b\<^sub>2 s)"

datatype instr =
  AssI "nat list" "bexp list" |
  TestI bexp int |
  ChoiceI "(bexp * int) list" |
  GotoI int

type_synonym config = "nat * state"
type_synonym bprog = "instr array"

text \<open>
  Semantics Notice:
  To be equivalent in semantics with SPIN, there is no such thing as a
  finite run:
  \begin{itemize}
    \item Deadlocks (i.e. empty Choice) are self-loops
    \item program termination is self-loop
  \end{itemize}
\<close>

fun exec :: "instr \<Rightarrow> config \<Rightarrow> config list" where
"exec instr (pc,s) = (case instr of
  AssI ns bs \<Rightarrow> let bvs = zip ns (map (\<lambda>b. bval b s) bs) in
               [(pc + 1, foldl (\<lambda>s (n,bv). set_bit s n bv) s bvs)] |
  TestI b d \<Rightarrow> [if bval b s then (pc+1, s) else (nat(int(pc+1)+d), s)] |
  ChoiceI bis \<Rightarrow> let succs = [(nat(int(pc+1)+i), s) . (b,i) <- bis, bval b s]
                in if succs = [] then [(pc,s)] else succs |
  GotoI d \<Rightarrow> [(nat(int(pc+1)+d),s)])"

(* exec' is merely a stuttering optimization. It summarizes chains of choices
  or jumps, as long as they go forward in the program. The forward-condition is
  to ensure termination.

  TODO: Make this explicit, and prove stuttering equivalence!
*)
function exec' :: "bprog \<Rightarrow> state \<Rightarrow> nat \<Rightarrow> nat list" where
"exec' ins s pc = (
  if pc < array_length ins then (
    case (array_get ins pc) of
      AssI ns bs \<Rightarrow> [pc] |
      TestI b d \<Rightarrow> (
        if bval b s then exec' ins s (pc+1)
        else let pc'=(nat(int(pc+1)+d)) in if pc'>pc then exec' ins s pc'
        else [pc']
      ) |
      ChoiceI bis \<Rightarrow> let succs = [(nat(int(pc+1)+i)) . (b,i) <- bis, bval b s]
                    in if succs = [] then [pc] else concat (map (\<lambda>pc'. if pc'>pc then exec' ins s pc' else [pc']) succs) |
      GotoI d \<Rightarrow> let pc' = nat(int(pc+1)+d) in (if pc'>pc then exec' ins s pc' else [pc'])
  ) else [pc]
)"
by pat_completeness auto
termination
  apply (relation "measure (%(ins,s,pc). array_length ins - pc)")
  apply auto
  done

fun nexts1 :: "bprog \<Rightarrow> config \<Rightarrow> config list" where
"nexts1 ins (pc,s) = (
  if pc < array_length ins then
    exec (array_get ins pc) (pc,s)
  else
    [(pc,s)])"

fun nexts :: "bprog \<Rightarrow> config \<Rightarrow> config list" where
  "nexts ins (pc,s) = concat (
    map
      (\<lambda>(pc,s). map (\<lambda>pc. (pc,s)) (exec' ins s pc))
      (nexts1 ins (pc,s))
  )"

declare nexts.simps [simp del]

datatype
  com = SKIP
      | Assign "nat list" "bexp list"
      | Seq    com  com
      | GC  "(bexp * com)list"
      | IfTE  bexp com com
      | While  bexp com

locale BoolProg_Syntax begin
  notation
        Assign       ("_ ::= _" [999, 61] 61)
    and Seq          ("_;/ _"  [60, 61] 60)
    and GC           ("IF _ FI")
    and IfTE         ("(IF _/ THEN _/ ELSE _)"  [0, 61, 61] 61)
    and While        ("(WHILE _/ DO _)"  [0, 61] 61)
end

context begin interpretation BoolProg_Syntax .
fun comp' :: "com \<Rightarrow> instr list" where
"comp' SKIP = []" |
"comp' (Assign n b) = [AssI n b]" |
"comp' (c1;c2) = comp' c1 @ comp' c2" |
"comp' (IF gcs FI) =
  (let cgcs = map (\<lambda>(b,c). (b,comp' c)) gcs in
   let addbc = (\<lambda>(b,cc) (bis,ins).
         let cc' = cc @ (if ins = [] then [] else [GotoI (int(length ins))]) in
         let bis' = map (\<lambda>(b,i). (b, i + int(length cc'))) bis
         in ((b,0)#bis', cc' @ ins)) in
   let (bis,ins) = foldr addbc cgcs ([],[])
   in ChoiceI bis # ins)" |
"comp' (IF b THEN c1 ELSE c2) =
  (let ins1 = comp' c1 in let ins2 = comp' c2 in
   let i1 = int(length ins1 + 1) in let i2 = int(length ins2)
   in TestI b i1 # ins1 @ GotoI i2 # ins2)" |
"comp' (WHILE b DO c) =
  (let ins = comp' c in
   let i = int(length ins + 1)
   in TestI b i # ins @ [GotoI (-(i+1))])"

(* a test: *)
value "comp' (IF [(V 0, [1,0] ::= [TT, FF]), (V 1, [0] ::= [TT])] FI)"

end

definition comp :: "com \<Rightarrow> bprog" where
  "comp = array_of_list \<circ> comp'"

(*
  Optimization

- Gotos: Resolve Goto-Chains: If a Goto referres to another Goto -- add the second offset to the first one.
                              If a Goto has a negative offset ignore it, to avoid problems with loops.

*)

fun opt' where
  "opt' (GotoI d) ys = (let next = \<lambda>i. (case i of GotoI d \<Rightarrow> d + 1 | _ \<Rightarrow> 0)
                        in if d < 0 \<or> nat d \<ge> length ys then (GotoI d)#ys
                           else let d' = d + next (ys ! nat d)
                           in (GotoI d' # ys))"
| "opt' x ys = x#ys"

definition opt :: "instr list \<Rightarrow> instr list" where
  "opt instr = foldr opt' instr []"

definition optcomp :: "com \<Rightarrow> bprog" where
  "optcomp \<equiv> array_of_list \<circ> opt \<circ> comp'"

subsection \<open>Finiteness of reachable configurations\<close>

inductive_set reachable_configs
  for bp :: bprog
  and c\<^sub>s :: config \<comment> \<open>start configuration\<close>
where
"c\<^sub>s \<in> reachable_configs bp c\<^sub>s" |
"c \<in> reachable_configs bp c\<^sub>s \<Longrightarrow> x \<in> set (nexts bp c) \<Longrightarrow> x \<in> reachable_configs bp c\<^sub>s"

lemmas reachable_configs_induct = reachable_configs.induct[split_format(complete),case_names 0 1]

fun offsets :: "instr \<Rightarrow> int set" where
"offsets (AssI _ _) = {0}" |
"offsets (TestI _ i) = {0,i}" |
"offsets (ChoiceI bis) = set(map snd bis) \<union> {0}" |
"offsets (GotoI i) = {i}"

definition offsets_is :: "instr list \<Rightarrow> int set" where
"offsets_is ins = (UN instr : set ins. offsets instr)"

definition max_next_pcs :: "instr list \<Rightarrow> nat set" where
"max_next_pcs ins = {nat(int(length ins + 1) + i) |i. i : offsets_is ins}"

(* TODO: Move *)
lemma (in linorder) le_Max_insertI1: "\<lbrakk> finite A; x \<le> b \<rbrakk> \<Longrightarrow> x \<le> Max (insert b A)"
by (metis Max_ge finite.insertI insert_iff order_trans)
lemma (in linorder) le_Max_insertI2: "\<lbrakk> finite A; A \<noteq> {}; x \<le> Max A \<rbrakk> \<Longrightarrow> x \<le> Max (insert b A)"
by(auto simp add: max_def not_le simp del: Max_less_iff)

lemma max_next_pcs_not_empty:
  "pc<length bp \<Longrightarrow> x : set (exec (bp!pc) (pc,s)) \<Longrightarrow> max_next_pcs bp \<noteq> {}"
apply(drule nth_mem)
apply(fastforce simp: max_next_pcs_def offsets_is_def split: instr.splits)
done

lemma Max_lem2:
  assumes "pc < length bp"
  and "(pc', s') \<in> set (exec (bp!pc) (pc, s))"
  shows "pc' \<le> Max (max_next_pcs bp)"
using assms
proof (cases "bp ! pc")
  case (ChoiceI l)
  show ?thesis
  proof (cases "pc' = pc")
    case True with assms ChoiceI show ?thesis
      by (auto simp: Max_ge_iff max_next_pcs_not_empty finite_max_next_pcs)
         (force simp add: max_next_pcs_def offsets_is_def dest: nth_mem)
  next
    case False with ChoiceI assms obtain b i where
      bi: "bval b s" "(b,i) \<in> set l" "pc' = nat(int(pc+1)+i)"
      by (auto split: if_split_asm)
    with ChoiceI assms have "i \<in> \<Union>(offsets ` (set bp))" by (force dest: nth_mem)
    with bi assms have "\<exists>a. (a \<in> max_next_pcs bp \<and> pc' \<le> a)"
      unfolding max_next_pcs_def offsets_is_def by force
    thus ?thesis
      by (auto simp: Max_ge_iff max_next_pcs_not_empty[OF assms] finite_max_next_pcs)
    qed
qed (auto simp: Max_ge_iff max_next_pcs_not_empty finite_max_next_pcs,
     (force simp add: max_next_pcs_def offsets_is_def dest: nth_mem split: if_split_asm)+)

lemma Max_lem1: "\<lbrakk> pc < length bp; (pc', s') \<in> set (exec (bp ! pc) (pc, s))\<rbrakk>
    \<Longrightarrow> pc' \<le> Max (insert x (max_next_pcs bp))"
  apply(rule le_Max_insertI2)
  apply (simp add: finite_max_next_pcs)
  apply(simp add: max_next_pcs_not_empty)
  apply(auto intro!: Max_lem2 simp del:exec.simps)
  done

definition "pc_bound bp \<equiv> max
    (Max (max_next_pcs (list_of_array bp)) + 1)
    (array_length bp + 1)"

declare exec'.simps[simp del]

lemma aux2:
  assumes A: "pc < array_length ins"
  assumes B: "ofs \<in> offsets_is (list_of_array ins)"
  shows "nat (1 + int pc + ofs) < pc_bound ins"
proof -
  have "nat (int (1 + array_length ins) + ofs)
    \<in> max_next_pcs (list_of_array ins)"
    using B unfolding max_next_pcs_def
    by auto
  with A show ?thesis
    unfolding pc_bound_def
    apply -
    apply (rule max.strict_coboundedI1)
    apply auto
    apply (drule Max_ge[OF finite_max_next_pcs])
    apply simp
    done
qed

lemma array_idx_in_set:
  "\<lbrakk> pc < array_length ins; array_get ins pc = x \<rbrakk>
  \<Longrightarrow> x \<in> set (list_of_array ins)"
  by (induct ins) auto

lemma rcs_aux:
  assumes "pc < pc_bound bp"
  assumes "pc'\<in>set (exec' bp s pc)"
  shows "pc' < pc_bound bp"
  using assms
proof (induction bp s pc arbitrary: pc' rule: exec'.induct[case_names C])
  case (C ins s pc pc')
  from C.prems show ?case
    apply (subst (asm) exec'.simps)
    apply (split if_split_asm instr.split_asm)+
    apply (simp add: pc_bound_def)

    apply (simp split: if_split_asm add: Let_def)
    apply (frule (2) C.IH(1), auto) []
    apply (auto simp: pc_bound_def) []
    apply (frule (2) C.IH(2), auto) []
    apply (rename_tac bexp int)
    apply (subgoal_tac "int \<in> offsets_is (list_of_array ins)")
    apply (blast intro: aux2)
    apply (auto simp: offsets_is_def) []
    apply (rule_tac x="TestI bexp int" in bexI, auto simp: array_idx_in_set) []

    apply (rename_tac list)
    apply (clarsimp split: if_split_asm simp add: Let_def)
    apply (elim disjE conjE, auto) []
    apply (frule (1) C.IH(3), auto) []
    apply (force)
    apply (force)
    apply (subgoal_tac "ba \<in> offsets_is (list_of_array ins)")
    apply (blast intro: aux2)
    apply (auto simp: offsets_is_def) []
    apply (rule_tac x="ChoiceI list" in bexI, auto simp: array_idx_in_set) []

    apply (rename_tac int)
    apply (simp split: if_split_asm add: Let_def)
    apply (frule (1) C.IH(4), auto) []
    apply (subgoal_tac "int \<in> offsets_is (list_of_array ins)")
    apply (blast intro: aux2)
    apply (auto simp: offsets_is_def) []
    apply (rule_tac x="GotoI int" in bexI, auto simp: array_idx_in_set) []

    apply simp
    done
qed

primrec bexp_vars :: "bexp \<Rightarrow> nat set" where
  "bexp_vars TT = {}"
| "bexp_vars FF = {}"
| "bexp_vars (V n) = {n}"
| "bexp_vars (Not b) = bexp_vars b"
| "bexp_vars (And b1 b2) = bexp_vars b1 \<union> bexp_vars b2"
| "bexp_vars (Or b1 b2) = bexp_vars b1 \<union> bexp_vars b2"

primrec instr_vars :: "instr \<Rightarrow> nat set" where
  "instr_vars (AssI xs bs) = set xs \<union> \<Union>(bexp_vars`set bs)"
| "instr_vars (TestI b _) = bexp_vars b"
| "instr_vars (ChoiceI cs) = \<Union>(bexp_vars`fst`set cs)"
| "instr_vars (GotoI _) = {}"

find_consts "'a array \<Rightarrow> 'a list"

definition bprog_vars :: "bprog \<Rightarrow> nat set" where
  "bprog_vars bp = \<Union>(instr_vars`set (list_of_array bp))"

definition "state_bound bp s0
  \<equiv> {s. bs_\<alpha> s - bprog_vars bp = bs_\<alpha> s0 - bprog_vars bp}"
abbreviation "config_bound bp s0 \<equiv> {0..< pc_bound bp} \<times> state_bound bp s0"

lemma exec_bound:
  assumes PCB: "pc < array_length bp"
  assumes SB: "s \<in> state_bound bp s0"
  shows "set (exec (array_get bp pc) (pc,s)) \<subseteq> config_bound bp s0"
proof (clarsimp simp del: exec.simps, intro conjI)

  obtain instrs where BP_eq[simp]: "bp = Array instrs" by (cases bp)
  from PCB have PCB'[simp]: "pc < length instrs" by simp

  fix pc' s'
  assume STEP: "(pc',s') \<in> set (exec (array_get bp pc) (pc,s))"
  hence STEP': "(pc',s') \<in> set (exec (instrs!pc) (pc,s))" by simp

  show "pc' < pc_bound bp"
    using Max_lem2[OF PCB' STEP']
    unfolding pc_bound_def by simp

  show "s' \<in> state_bound bp s0"
    using STEP' SB
  proof (cases "instrs!pc")
    case (AssI xs vs)

    have "set xs \<subseteq> instr_vars (instrs!pc)"
      by (simp add: AssI)
    also have "\<dots> \<subseteq> bprog_vars bp"
      apply (simp add: bprog_vars_def)
      by (metis PCB' UN_upper nth_mem)
    finally have XSB: "set xs \<subseteq> bprog_vars bp" .

    {
      fix x s v
      assume A: "x \<in> bprog_vars bp" "s \<in> state_bound bp s0"

      have SB_CNV: "bs_\<alpha> (set_bit s x v)
        = (if v then (insert x (bs_\<alpha> s)) else (bs_\<alpha> s - {x}))"
        apply (cases v)
        apply simp_all
        apply (fold bs_insert_def bs_delete_def)
        apply (simp_all add: bs_correct)
        done

      from A have "set_bit s x v \<in> state_bound bp s0"
        unfolding state_bound_def
        by (auto simp: SB_CNV)
    } note aux=this

    {
      fix vs
      have "foldl (\<lambda>s (x, y). set_bit s x y) s (zip xs vs)
        \<in> state_bound (Array instrs) s0"
        using SB XSB
        apply (induct xs arbitrary: vs s)
        apply simp
        apply (case_tac vs)
        apply simp
        using aux
        apply (auto)
        done
    } note aux2=this

    thus ?thesis using STEP'
      by (simp add: AssI)
  qed (auto split: if_split_asm)
qed

lemma in_bound_step:
  notes [simp del] = exec.simps
  assumes BOUND: "c \<in> config_bound bp s0"
  assumes STEP: "c'\<in>set (nexts bp c)"
  shows "c' \<in> config_bound bp s0"
  using BOUND STEP
  apply (cases c)
  apply (auto
    simp add: nexts.simps
    split: if_split_asm)
  apply (frule (2) exec_bound[THEN subsetD])
  apply clarsimp
  apply (frule (1) rcs_aux)
  apply simp

  apply (frule (2) exec_bound[THEN subsetD])
  apply clarsimp

  apply (frule (1) rcs_aux)
  apply simp
  done

lemma reachable_configs_in_bound:
  "c \<in> config_bound bp s0 \<Longrightarrow> reachable_configs bp c \<subseteq> config_bound bp s0"
proof
  fix c'
  assume "c' \<in> reachable_configs bp c" "c \<in> config_bound bp s0"
  thus "c' \<in> config_bound bp s0"
    apply induction
    apply simp
    by (rule in_bound_step)
qed

lemma reachable_configs_out_of_bound: "(pc',s')\<in>reachable_configs bp (pc,s)
  \<Longrightarrow> \<not> pc < pc_bound bp \<Longrightarrow> (pc',s') = (pc,s)"
proof (induct rule: reachable_configs_induct)
  case (1 pc' s' pc'' s'')
  hence [simp]: "pc'=pc" "s'=s" by auto
  from 1(4) have "\<not> pc < array_length bp" unfolding pc_bound_def by auto
  with 1(3) show ?case
    by (auto simp add: nexts.simps exec'.simps)
qed auto

lemma finite_bexp_vars[simp, intro!]: "finite (bexp_vars be)"
  by (induction be) auto

lemma finite_instr_vars[simp, intro!]: "finite (instr_vars ins)"
  by (cases ins) auto

lemma finite_state_bound[simp, intro!]: "finite (state_bound bp s0)"
  unfolding state_bound_def
  apply (rule finite_imageD[where f=bs_\<alpha>])
  apply (rule finite_subset[where
    B = "{s. s - bprog_vars bp = bs_\<alpha> s0 - bprog_vars bp}"])
  apply auto []
  apply (rule finite_if_eq_beyond_finite)
  apply simp

  apply (rule inj_onI)
  apply (fold bs_eq_def)
  apply (auto simp: bs_eq_correct)
  done

lemma finite_config_bound[simp, intro!]: "finite (config_bound bp s0)"
  by blast

definition "bpc_is_run bpc r \<equiv> let (bp,c)=bpc in r 0 = c \<and> (\<forall>i. r (Suc i) \<in> set (BoolProgs.nexts bp (r i)))"
definition "bpc_props c \<equiv> bs_\<alpha> (snd c)"
definition "bpc_lang bpc \<equiv> {bpc_props o r | r. bpc_is_run bpc r}"

(* Printing *)
(*definition print_list where
  "print_list f sep s = (let f' = (\<lambda>str s. if str = [] then f s
                                       else str @ sep @ f s)
                     in ''['' @ (foldl f' [] s) @ '']'')"

fun bool_list_to_prop_list where
  "bool_list_to_prop_list _ [] props = props"
| "bool_list_to_prop_list n (x#xs) props = (let props' = if x then n#props else props
                                            in bool_list_to_prop_list (Suc n) xs props')"
*)

fun print_config ::
  "(nat \<Rightarrow> string) \<Rightarrow> (bitset \<Rightarrow> string) \<Rightarrow> config \<Rightarrow> string" where
  "print_config f fx (p,s) = f p @ '' '' @ fx s"

end


theory Example_Lomuto
  imports Hnr_Diff_Arr Hnr_Array  Definition_Utils "HOL-Library.Multiset" "HOL-Library.Rewrite"
begin

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

fun partition :: "nat \<Rightarrow> nat \<Rightarrow> ('a::linorder) list \<Rightarrow> ('a list * nat)" where
  "partition i j xs = (if 1 < j then
      (if xs ! 0 < xs ! (j - 1)
       then partition (i - 1) (j - 1) (swap (i - 1) (j - 1) xs)
       else partition i (j - 1) xs)
    else (swap (i - 1) 0 xs, i - 1)
  )"
declare partition.simps[simp del]

abbreviation partition' where
  "partition' xs \<equiv> partition (length xs) (length xs) xs"

definition inv :: "nat \<Rightarrow> nat \<Rightarrow> ('a::linorder) list \<Rightarrow> bool" where
  "inv i j xs \<equiv>
    let p = xs ! 0 in
    0 < length xs \<and>
    0 < i \<and>
    i \<le> length xs \<and>
    j \<le> length xs \<and>
    j \<le> i \<and>
   (\<forall>h \<in> set (drop i xs). p < h) \<and>
   (\<forall>l \<in> set (take (i - j) (drop j xs)). l \<le> p)"

definition is_valid_partition where
  "is_valid_partition ys m \<equiv> \<forall>l \<in> set (take m ys). \<forall>h \<in> set (drop m ys). l \<le> h"

lemma mset_swap' [simp]:"i < length xs \<Longrightarrow> j < length xs \<Longrightarrow> mset (swap i j xs) = mset xs"
  unfolding swap_def
  using mset_swap by auto

lemma swap_length [simp]: "length (swap i j xs) = length xs"
  unfolding swap_def
  by auto

lemma swap_pivot: "swap (Suc i) (Suc j) (p#xs) = p # (swap i j xs)"
  unfolding swap_def
  by auto

lemma swap_pivot_2: "0 < i \<Longrightarrow> 0 < j \<Longrightarrow> swap i j (p#xs) = p # (swap (i - 1) (j - 1) xs)"
  unfolding swap_def
  apply(cases i; cases j)
  by auto

lemma swap_nth_absorb: "n < i \<Longrightarrow> n < j \<Longrightarrow> swap i j xs ! n = xs ! n"
  unfolding swap_def
  by auto

lemma drop_swap: "n \<le> i \<Longrightarrow> n \<le> j \<Longrightarrow> drop n (swap i j xs) = swap (i - n) (j - n) (drop n xs)"
  unfolding swap_def
  by (metis drop_eq_Nil drop_update_swap le_add_diff_inverse linorder_le_cases list_update_nonempty nth_drop)

lemma drop_swap': "\<lbrakk>
  Suc 0 < j;
  xs \<noteq> [];
  i \<le> length xs;
  j \<le> i\<rbrakk> \<Longrightarrow>
  drop (i - Suc 0) (swap (i - Suc 0) (j - Suc 0) xs) = xs ! (j - Suc 0) # (drop i xs)"
  unfolding swap_def
  by(smt (verit, best) Cons_nth_drop_Suc One_nat_def drop_upd_irrelevant dual_order.strict_trans1 le_add_diff_inverse le_eq_less_or_eq length_list_update less_eq_Suc_le linorder_not_less nth_list_update_eq plus_1_eq_Suc)

lemma drop_swap'_2: "\<lbrakk>
  Suc 0 < j;
  xs ! 0 < xs ! (j - Suc 0);
  xs \<noteq> [];
  i \<le> length xs;
  j \<le> i\<rbrakk> \<Longrightarrow> drop (j - Suc 0) (swap (i - Suc 0) (j - Suc 0) xs) = swap (i - 1 - (j - Suc 0)) 0 (drop (j - Suc 0) xs)"
  using drop_swap[of "j - 1" "i - 1" "j - 1" xs]
  by auto

lemma test_2: "n < length xs \<Longrightarrow> drop n xs = drop n xs ! 0 # drop (Suc n) xs"
  apply auto
  by (simp add: Cons_nth_drop_Suc)

lemma test_3: "\<lbrakk>Suc 0 < j; i \<le> length xs; j \<le> i\<rbrakk>
   \<Longrightarrow> (drop (j - Suc 0) xs)[0 := xs ! (i - 1)] = xs ! (i - 1) # drop j xs"
  by (smt (verit, ccfv_SIG) Cons_nth_drop_Suc Suc_diff_le Suc_le_eq diff_Suc_Suc le_trans list_update_code(2) minus_nat.diff_0 nat_less_le)

lemma test_3_1: "\<lbrakk>Suc 0 < j; j \<le> length xs\<rbrakk> \<Longrightarrow> (drop (j - Suc 0) xs)[0 := y] = y # drop j xs"
  by (metis dual_order.refl list_update_code(2) list_update_overwrite test_3)

lemma test_3_2: "(take (i - j) (drop (j - Suc 0) xs))[0 := xs ! (i - Suc 0)] = (take (i - j) ((drop (j - Suc 0) xs)[0 := xs ! (i - Suc 0)]))"
  by simp

lemma test_4: "\<lbrakk>Suc 0 < j; i \<le> length xs; j \<le> i\<rbrakk>
   \<Longrightarrow> take (i - j) (drop (j - Suc 0) (swap (i - Suc 0) (j - Suc 0) xs)) = take (i -j) (xs ! (i - 1) # drop j xs)"
  unfolding swap_def
  apply auto
  by (smt (z3) One_nat_def Suc_le_mono diff_Suc_Suc diff_self_eq_0 drop_update_swap dual_order.strict_trans1 le_add_diff_inverse less_or_eq_imp_le plus_1_eq_Suc take_update take_update_cancel test_3)

lemma test_5_1: "\<lbrakk>l \<in>\<^sub>L take (i - j) (xs ! (i - Suc 0) # drop j xs); l \<noteq> xs ! (i - Suc 0)\<rbrakk> \<Longrightarrow> l \<in>\<^sub>L take (i - j - 1) (drop j xs)"
  apply auto
  by (smt (verit) Suc_diff_Suc Suc_le_eq diff_is_0_eq less_or_eq_imp_le linorder_not_less set_ConsD take_Suc_Cons take_eq_Nil)

lemma test_5_2: "l \<in>\<^sub>L take (i - Suc j) (drop j xs) \<Longrightarrow> l \<in>\<^sub>L take (i - j) (drop j xs)"
  by (meson Suc_n_not_le_n diff_le_mono2 nle_le set_take_subset_set_take subset_code(1))

lemma test_5: "\<lbrakk>
  xs \<noteq> [];
  Suc 0 < j;
  i \<le> length xs;
  j \<le> i;
  i \<noteq> j;
  \<forall>l\<in>set (take (i - j) (drop j xs)). l \<le> xs ! 0;
  l \<in>\<^sub>L take (i - j) (xs ! (i - Suc 0) # drop j xs);
  xs ! (i - Suc 0) \<le> xs ! 0
\<rbrakk> \<Longrightarrow> (l::'a::linorder) \<le> xs ! 0"
  apply(cases "l = xs ! (i - Suc 0)")
   apply auto
  apply(drule test_5_1)
  by(auto simp: test_5_2)

lemma test_6_1: "j < i \<Longrightarrow> i \<le> length xs \<Longrightarrow> xs ! (i - Suc 0) \<in>\<^sub>L drop j xs"
  by (metis Suc_leI Suc_le_mono Suc_pred in_set_drop_conv_nth less_imp_Suc_add nz_le_conv_less zero_less_Suc)

lemma test_6: "j < i \<Longrightarrow> i \<le> length xs \<Longrightarrow> xs ! (i - Suc 0) \<in>\<^sub>L take (i - j) (drop j xs)"
  using test_6_1
  by (smt (verit, ccfv_SIG) diff_less drop_take le_SucE le_zero_eq length_take less_zeroE min.absorb2 nth_take zero_induct zero_less_iff_neq_zero)

lemma test_7: "\<lbrakk>\<forall>l\<in>set xs. P l; x \<in>\<^sub>L xs\<rbrakk> \<Longrightarrow> P x"
  by simp

lemma aux_1_1: "\<lbrakk>
  Suc 0 < j;
  xs ! 0 < xs ! (j - Suc 0);
  xs \<noteq> [];
  i \<le> length xs;
  j \<le> i;
  \<forall>x\<in>set (drop i xs). xs ! 0 < x;
  x \<in>\<^sub>L drop (i - Suc 0) (swap (i - Suc 0) (j - Suc 0) xs)
\<rbrakk> \<Longrightarrow> xs ! 0 < x"
  using drop_swap'[of j xs i]
  by auto

lemma aux_1_2: "\<lbrakk>
  Suc 0 < j;
  xs ! 0 < xs ! (j - Suc 0);
  xs \<noteq> [];
  i \<le> length xs;
  j \<le> i;
  \<forall>l\<in>set (take (i - j) (drop j xs)). l \<le> xs ! 0;
  l \<in>\<^sub>L take (i - j) (drop (j - Suc 0) (swap (i - Suc 0) (j - Suc 0) xs))
\<rbrakk> \<Longrightarrow> (l::'a::linorder) \<le> xs ! 0"
  apply(auto simp: test_4)
  apply(cases "i = j")
   apply auto
  apply(subgoal_tac "xs ! (i - Suc 0) \<le> xs ! 0")
  using test_5[of xs]
   apply simp
  using test_6[of j i xs]
  by simp

lemma aux_2_1:  "\<lbrakk>l \<in>\<^sub>L take n xs\<rbrakk>
  \<Longrightarrow>  l \<in>\<^sub>L take (Suc n) xs"
  apply(induction xs)
   apply auto
  by (metis lessI less_or_eq_imp_le set_ConsD set_take_subset_set_take subset_code(1) take_Suc_Cons)

lemma aux_2_2: "0 < j \<Longrightarrow> j \<le> length xs \<Longrightarrow> drop (j - Suc 0) xs =  xs ! (j - Suc 0) # drop j xs"
  by (metis Cons_nth_drop_Suc Suc_pred nz_le_conv_less)

lemma aux_3_1: "\<lbrakk>\<not> Suc 0 < j; xs \<noteq> []; 0 < i; i \<le> length xs; l \<in>\<^sub>L (take (i - Suc 0) xs)[0 := xs ! (i - Suc 0)]\<rbrakk>
   \<Longrightarrow> l \<in>\<^sub>L take (i - j) (drop j xs)"
  by (smt (verit, ccfv_threshold) Cons_nth_drop_Suc One_nat_def Suc_diff_Suc Suc_inject Suc_pred drop0 dual_order.strict_trans1 gr0I in_set_upd_cases list_update_code(2) set_ConsD take_Cons' take_eq_Nil2 take_update_swap test_5_2 test_6 zero_less_diff)

lemma aux_3_2: "\<lbrakk>
  \<not> Suc 0 < j;
  (xs::('a::linorder) list) \<noteq> []; 0 < i;
  i \<le> length xs;
  \<forall>h \<in>set (drop i xs). xs ! 0 \<le> h
\<rbrakk> \<Longrightarrow> \<forall>h \<in>set  (drop (i - Suc 0) (xs[i - Suc 0 := xs ! 0, 0 := xs ! (i - Suc 0)])). xs ! 0 \<le> h"
  apply(cases "i = 1")
   apply auto
  subgoal for x
    apply(cases "x = xs ! 0")
     apply auto
    by (metis Cons_nth_drop_Suc drop_0 length_pos_if_in_set set_ConsD)
  by (smt (verit, best) Nat.diff_diff_eq One_nat_def Suc_diff_Suc diff_diff_cancel drop_update_swap le_add_diff_inverse less_eq_Suc_le order_le_less plus_1_eq_Suc set_ConsD test_3_1)

lemma partition: "inv i j xs \<Longrightarrow> partition i j xs = (ys, m) \<Longrightarrow> is_valid_partition ys m"
proof(induction i j xs arbitrary: ys m rule: partition.induct)
  case (1 i j xs)
  then have unfolded_partition: "(
      if Suc 0 < j
      then if xs ! 0 < xs ! (j - 1)
           then partition (i - 1) (j - 1) (swap (i - 1) (j - 1) xs)
           else partition i (j - 1) xs
      else (swap (i - 1) 0 xs, i - 1)) = (ys, m)"
    by(simp add: partition.simps)

  have recursive_branch_1:
    "\<lbrakk>1 < j; xs ! 0 < xs ! (j - Suc 0)\<rbrakk>
        \<Longrightarrow>  inv (i - Suc 0) (j - Suc 0) (swap (i - Suc 0) (j - Suc 0) xs)"
  using "1.prems"
  unfolding inv_def Let_def
  apply(auto simp: swap_nth_absorb)
  by(auto simp: aux_1_1 aux_1_2)

  have recursive_branch_2:
    "\<lbrakk>1 < j; \<not> xs ! 0 < xs ! (j - Suc 0)\<rbrakk>
        \<Longrightarrow> inv i (j - Suc 0) xs"
  using "1.prems"
   unfolding inv_def Let_def
  apply auto
  subgoal for l
    apply(cases "l = xs ! (j - Suc 0)")
     apply(auto simp: aux_2_2)
    using take_Suc_Cons[of "i - j" "xs ! (j - Suc 0)"  "drop j xs"]
    by auto
  done

  have terminating_branch:
     "\<not> Suc 0 < j \<Longrightarrow> is_valid_partition (swap (i - Suc 0) 0 xs) (i - Suc 0)"
     using "1.prems"
    unfolding inv_def Let_def is_valid_partition_def
  apply(auto)
  unfolding swap_def
  subgoal for l h
  using aux_3_1[of j xs i l] aux_3_2[of j xs i]
  apply(auto)
  by (meson order_less_imp_le order_trans)
  done

  from unfolded_partition 1 recursive_branch_1 recursive_branch_2 terminating_branch
  show ?case
    by(auto split: if_splits)
qed

lemma inv: "inv (length (p#xs)) (length (p#xs)) (p#xs)"
  unfolding inv_def
  by auto

lemma partition':
  "partition' (p#xs) = (ys, m) \<Longrightarrow> is_valid_partition ys m"
  using inv[of p xs] partition[of "length (p # xs)" "length (p # xs)" "p # xs" ys m]
  by auto

(* TODO: If c2 and c3 exchange then not linear anymore *)
definition swap_opt :: "nat \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list option" where
  "swap_opt i j xs = do {
     let c1 = xs!j;
     let c2 = xs!i;
     let c3 = xs[i := c1];
     let c4 = c3[j := c2];
     Some c4
  }"

lemma swap_opt_termination: "swap_opt i j xs = Some (swap i j xs)"
  unfolding swap_opt_def swap_def
  by auto

synth_definition swap_impl is [hnr_rule_diff_arr]:
  "hnr (master_assn' (insert (xs, xsi) F) * id_assn i ii * id_assn j ji)(\<hole>:: ?'a Heap) ?\<Gamma>' (swap_opt i j xs)"
  unfolding swap_opt_def
  by hnr_diff_arr

synth_definition swap_impl_2 is [hnr_rule_arr]:
  "hnr (array_assn xs xsi * id_assn i ii * id_assn j ji)(\<hole>:: ?'a Heap) ?\<Gamma>' (swap_opt i j xs)"
  unfolding swap_opt_def
  by hnr_arr

definition partition_opt :: "nat \<times> nat \<times> ('a::linorder) list \<Rightarrow> (('a::linorder) list \<times> nat) option"
  where
    "partition_opt \<equiv> option.fixp_fun (\<lambda>partition_opt p. case p of (i, j, xs) \<Rightarrow> do {
      let c1 = 1;
      let c2 = c1 < j;
      if c2 then do {
        let c99 = 0;
        let c3 = xs ! c99;
        let c4 = 1;
        let c5 = j - c4;
        let c6 = xs ! c5;
        let c7 = c3 < c6;
        if c7 then do {
           let c8 = 1;
           let c9 = i - c8;
           let c10 = 1;
           let c11 = j - c10;
           c12 \<leftarrow> swap_opt c9 c11 xs;
           let c13 = (c9, c11, c12);
           partition_opt c13
        }
        else do {
          let c14 = 1;
          let c15 = j - c14;
          let c16 = (i, c15, xs);
          partition_opt c16
        }
      }
      else do {
        let c17 = 1;
        let c18 = i - c17;
        let c19 = 0;
        c20 \<leftarrow> swap_opt c18 c19 xs;
        Some (c20, c18)
      }
    }
   )"

schematic_goal partition_opt_unfold: "partition_opt p \<equiv> ?v"
  apply(rule gen_code_thm_option_fixp[OF partition_opt_def])
  by(partial_function_mono)

lemma partition_opt_termination: "partition_opt (i, j, xs) = Some (partition i j xs)"
  apply(induction i j xs rule: partition.induct)
  apply(rewrite partition_opt_unfold)
  apply(rewrite partition.simps)
  by(auto simp: Let_def swap_opt_termination)

context
  fixes xsi :: "('a::{linorder,heap}) cell ref"
begin

synth_definition partition_impl is [hnr_rule_diff_arr]:
  "hnr
    (master_assn' (insert (xs, xsi) F) * id_assn i ii * id_assn j ji)
    (\<hole>:: ?'a Heap)
    ?\<Gamma>'
    (partition_opt (i, j, xs))"
  unfolding partition_opt_def
  apply(hnr_recursion
          "(\<lambda>F p pi.
                master_assn' (insert (snd(snd p), snd (snd pi)) F) *
                id_assn (fst p) (fst pi) *
                id_assn (fst (snd p)) (fst (snd pi)))"
          "(\<lambda>F p pi r ri.
                master_assn' (insert (snd(snd p), snd (snd pi)) (insert (fst r, fst ri) F)) *
                id_assn (snd r) (snd ri) *
                id_assn (fst p) (fst pi) *
                id_assn (fst (snd p)) (fst (snd pi)) *
                true
                )"
          hnr_diff_arr_match_atom
        )
  by hnr_diff_arr

end

end


theory CJ_DDLplus  imports Main                                       (*David Fuenmayor and C. Benzmüller, 2019*)
begin
nitpick_params[user_axioms=true, show_all, expect=genuine, format = 3]

section \<open>Semantic Embedding of Carmo and Jones' Dyadic Deontic Logic (DDL) augmented with Kaplanian contexts\<close>
(**We introduce a modification of the semantic embedding developed by Benzm\"uller et al.
for the Dyadic Deontic Logic originally presented by Carmo and Jones. We extend this embedding
to a two-dimensional semantics as originally presented by David Kaplan.*)
subsection \<open>Definition of Types\<close>
 typedecl w   (** Type for possible worlds (Kaplan's "circumstances of evaluation" or "counterfactual situations") *)
 typedecl e   (** Type for individuals (entities eligible to become agents)*)
 typedecl c   (** Type for Kaplanian "contexts of use"*)
 type_synonym wo = "w\<Rightarrow>bool" (** contents/propositions are identified with their truth-sets*)
 type_synonym cwo = "c\<Rightarrow>wo"  (** sentence meaning (Kaplan's "character") is a function from contexts to contents*)
 type_synonym m = "cwo"      (** we use the letter 'm' for characters (reminiscent of "meaning")*)

subsection \<open>Semantic Characterisation of DDL\<close>
subsubsection \<open>Basic Set Operations\<close>
 abbreviation subset::"wo\<Rightarrow>wo\<Rightarrow>bool" (infix "\<sqsubseteq>" 46) where "\<alpha> \<sqsubseteq> \<beta> \<equiv> \<forall>w. \<alpha> w  \<longrightarrow> \<beta> w"
 abbreviation intersection::"wo\<Rightarrow>wo\<Rightarrow>wo" (infixr "\<sqinter>" 48) where "\<alpha> \<sqinter> \<beta> \<equiv> \<lambda>x. \<alpha> x \<and> \<beta> x"
 abbreviation union::"wo\<Rightarrow>wo\<Rightarrow>wo" (infixr "\<squnion>" 48) where "\<alpha> \<squnion> \<beta> \<equiv> \<lambda>x. \<alpha> x \<or> \<beta> x"
 abbreviation complement::"wo\<Rightarrow>wo" ("\<sim>_"[45]46) where "\<sim>\<alpha> \<equiv> \<lambda>x. \<not>\<alpha> x"
 abbreviation instantiated::"wo\<Rightarrow>bool" ("\<I>_"[45]46) where "\<I> \<phi> \<equiv> \<exists>x. \<phi> x"
 abbreviation setEq::"wo\<Rightarrow>wo\<Rightarrow>bool" (infix "=\<^sub>s" 46) where "\<alpha> =\<^sub>s \<beta> \<equiv> \<forall>x. \<alpha> x \<longleftrightarrow> \<beta> x"
 abbreviation univSet :: "wo" ("\<top>") where "\<top> \<equiv> \<lambda>w. True"
 abbreviation emptySet :: "wo" ("\<bottom>") where "\<bottom> \<equiv> \<lambda>w. False"

subsubsection \<open>Set-Theoretic Conditions for DDL\<close>
consts
 av::"w\<Rightarrow>wo"   (**set of worlds that are open alternatives (aka. actual versions) of w*)
 pv::"w\<Rightarrow>wo"   (**set of worlds that are possible alternatives (aka. potential versions) of w*)
 ob::"wo\<Rightarrow>wo\<Rightarrow>bool" (**set of propositions which are obligatory in a given context (of type wo) *)

axiomatization where
 sem_3a: "\<forall>w. \<I>(av w)" and (** av is serial: in every situation there is always an open alternative*)
 sem_4a: "\<forall>w. av w \<sqsubseteq> pv w" and (** open alternatives are possible alternatives*)
 sem_4b: "\<forall>w. pv w w" and (** pv is reflexive: every situation is a possible alternative to itself*)
 sem_5a: "\<forall>X. \<not>(ob X \<bottom>)" and (** contradictions cannot be obligatory*)
 sem_5b: "\<forall>X Y Z. (X \<sqinter> Y) =\<^sub>s (X \<sqinter> Z) \<longrightarrow> (ob X Y \<longleftrightarrow> ob X Z)" and
 sem_5c: "\<forall>X Y Z. \<I>(X \<sqinter> Y \<sqinter> Z) \<and> ob X Y \<and> ob X Z \<longrightarrow> ob X (Y \<sqinter> Z)" and
 sem_5d: "\<forall>X Y Z. (Y \<sqsubseteq> X \<and> ob X Y \<and> X \<sqsubseteq> Z) \<longrightarrow> ob Z ((Z \<sqinter> (\<sim>X)) \<squnion> Y)" and
 sem_5e: "\<forall>X Y Z. Y \<sqsubseteq> X \<and> ob X Z \<and> \<I>(Y \<sqinter> Z) \<longrightarrow> ob Y Z"

 lemma True nitpick[satisfy] oops (**model found: axioms are consistent*)

subsubsection \<open>Verifying Semantic Conditions\<close>
 lemma sem_5b1: "ob X Y \<longrightarrow> ob X (Y \<sqinter> X)" by (metis (no_types, lifting) sem_5b)
 lemma sem_5b2: "(ob X (Y \<sqinter> X) \<longrightarrow> ob X Y)" by (metis (no_types, lifting) sem_5b)
 lemma sem_5ab: "ob X Y \<longrightarrow> \<I>(X \<sqinter> Y)" by (metis (full_types) sem_5a sem_5b)
 lemma sem_5bd1: "Y \<sqsubseteq> X \<and> ob X Y \<and> X \<sqsubseteq> Z \<longrightarrow> ob Z ((\<sim>X) \<squnion> Y)" using sem_5b sem_5d by smt
 lemma sem_5bd2: "ob X Y \<and> X \<sqsubseteq> Z \<longrightarrow> ob Z ((Z \<sqinter> (\<sim>X)) \<squnion> Y)"  using sem_5b sem_5d  by (smt sem_5b1)
 lemma sem_5bd3: "ob X Y \<and> X \<sqsubseteq> Z \<longrightarrow> ob Z ((\<sim>X) \<squnion> Y)"  by (smt sem_5bd2 sem_5b)
 lemma sem_5bd4: "ob X Y \<and> X \<sqsubseteq> Z \<longrightarrow> ob Z ((\<sim>X) \<squnion> (X \<sqinter>  Y))" using sem_5bd3 by auto
 lemma sem_5bcd: "(ob X Z \<and> ob Y Z) \<longrightarrow> ob (X \<squnion> Y) Z" using sem_5b sem_5c sem_5d oops
 (** 5e and 5ab justify redefinition of @{text "O\<langle>\<phi>|\<sigma>\<rangle>"} as (ob A B)*)
 lemma "ob A B \<longleftrightarrow>  (\<I>(A \<sqinter> B) \<and> (\<forall>X. X \<sqsubseteq> A \<and> \<I>(X \<sqinter> B) \<longrightarrow> ob X B))" using sem_5e sem_5ab by blast

subsection \<open>(Shallow) Semantic Embedding of DDL\<close>

subsubsection \<open>Basic Propositional Logic\<close>
 abbreviation pand::"m\<Rightarrow>m\<Rightarrow>m" (infixr"\<^bold>\<and>" 51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>c w. (\<phi> c w)\<and>(\<psi> c w)"
 abbreviation por::"m\<Rightarrow>m\<Rightarrow>m" (infixr"\<^bold>\<or>" 50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>c w. (\<phi> c w)\<or>(\<psi> c w)"
 abbreviation pimp::"m\<Rightarrow>m\<Rightarrow>m" (infix"\<^bold>\<rightarrow>" 49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>c w. (\<phi> c w)\<longrightarrow>(\<psi> c w)"
 abbreviation pequ::"m\<Rightarrow>m\<Rightarrow>m" (infix"\<^bold>\<leftrightarrow>" 48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>c w. (\<phi> c w)\<longleftrightarrow>(\<psi> c w)"
 abbreviation pnot::"m\<Rightarrow>m" ("\<^bold>\<not>_" [52]53) where "\<^bold>\<not>\<phi> \<equiv> \<lambda>c w. \<not>(\<phi> c w)"

subsubsection \<open>Modal Operators\<close>
 abbreviation cjboxa :: "m\<Rightarrow>m" ("\<^bold>\<box>\<^sub>a_" [52]53) where "\<^bold>\<box>\<^sub>a\<phi> \<equiv> \<lambda>c w. \<forall>v. (av w) v \<longrightarrow> (\<phi> c v)"
 abbreviation cjdiaa :: "m\<Rightarrow>m" ("\<^bold>\<diamond>\<^sub>a_" [52]53) where "\<^bold>\<diamond>\<^sub>a\<phi> \<equiv> \<lambda>c w. \<exists>v. (av w) v \<and> (\<phi> c v)"
 abbreviation cjboxp :: "m\<Rightarrow>m" ("\<^bold>\<box>\<^sub>p_" [52]53) where "\<^bold>\<box>\<^sub>p\<phi> \<equiv> \<lambda>c w. \<forall>v. (pv w) v \<longrightarrow> (\<phi> c v)"
 abbreviation cjdiap :: "m\<Rightarrow>m" ("\<^bold>\<diamond>\<^sub>p_" [52]53) where "\<^bold>\<diamond>\<^sub>p\<phi> \<equiv> \<lambda>c w. \<exists>v. (pv w) v \<and> (\<phi> c v)"
 abbreviation cjtaut :: "m" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>c w. True"
 abbreviation cjcontr :: "m" ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<lambda>c w. False"

subsubsection \<open>Deontic Operators\<close>
 abbreviation cjod :: "m\<Rightarrow>m\<Rightarrow>m" ("\<^bold>O\<langle>_|_\<rangle>"54) where "\<^bold>O\<langle>\<phi>|\<sigma>\<rangle> \<equiv> \<lambda>c w. ob (\<sigma> c) (\<phi> c)"
 abbreviation cjoa :: "m\<Rightarrow>m" ("\<^bold>O\<^sub>a_" [53]54) where "\<^bold>O\<^sub>a\<phi> \<equiv> \<lambda>c w. (ob (av w)) (\<phi> c) \<and> (\<exists>x. (av w) x \<and> \<not>(\<phi> c x))"
 abbreviation cjop :: "m\<Rightarrow>m" ("\<^bold>O\<^sub>i_" [53]54) where "\<^bold>O\<^sub>i\<phi> \<equiv> \<lambda>c w. (ob (pv w)) (\<phi> c) \<and> (\<exists>x. (pv w) x \<and> \<not>(\<phi> c x))"

subsubsection \<open>Logical Validity (Classical)\<close>
 abbreviation modvalidctx :: "m\<Rightarrow>c\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sup>M") where "\<lfloor>\<phi>\<rfloor>\<^sup>M \<equiv> \<lambda>c. \<forall>w. \<phi> c w" (**context-dep. modal validity*)
 abbreviation modinvalidctx :: "m\<Rightarrow>c\<Rightarrow>bool" ("\<lceil>_\<rceil>\<^sup>M") where "\<lceil>\<phi>\<rceil>\<^sup>M \<equiv> \<lambda>c. \<forall>w. \<not>\<phi> c w" (**ctxt-dep. modal invalidity*)
 abbreviation modvalid :: "m\<Rightarrow>bool" ("\<lfloor>_\<rfloor>") where "\<lfloor>\<phi>\<rfloor> \<equiv> \<forall>c. \<lfloor>\<phi>\<rfloor>\<^sup>M c" (**general modal validity*)
 abbreviation modinvalid :: "m\<Rightarrow>bool" ("\<lceil>_\<rceil>") where "\<lceil>\<phi>\<rceil> \<equiv> \<forall>c. \<lceil>\<phi>\<rceil>\<^sup>M c" (**general modal invalidity*)

subsection \<open>Verifying the Embedding\<close>
subsubsection \<open>Avoiding Modal Collapse\<close>
 lemma "\<lfloor>P \<^bold>\<rightarrow> \<^bold>O\<^sub>aP\<rfloor>" nitpick oops (**(actual) deontic modal collapse is countersatisfiable*)
 lemma "\<lfloor>P \<^bold>\<rightarrow> \<^bold>O\<^sub>iP\<rfloor>" nitpick oops (**(ideal) deontic modal collapse is countersatisfiable*)
 lemma "\<lfloor>P \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>aP\<rfloor>" nitpick oops (**alethic modal collapse is countersatisf. (implies other necessity operators)*)

subsubsection \<open>Necessitation Rule\<close>
 lemma NecDDLa: "\<lfloor>A\<rfloor> \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sub>aA\<rfloor>"  by simp (** Valid only using classical (not LD) validity*)
 lemma NecDDLp:  "\<lfloor>A\<rfloor> \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sub>pA\<rfloor>" by simp (** Valid only using classical (not LD) validity*)

subsubsection \<open>Lemmas for Semantic Conditions\<close> (* extracted from Benzmüller et al. paper*)
 abbreviation mboxS5 :: "m\<Rightarrow>m" ("\<^bold>\<box>\<^sup>S\<^sup>5_" [52]53) where "\<^bold>\<box>\<^sup>S\<^sup>5\<phi> \<equiv> \<lambda>c w. \<forall>v. \<phi> c v"
 abbreviation mdiaS5 :: "m\<Rightarrow>m" ("\<^bold>\<diamond>\<^sup>S\<^sup>5_" [52]53) where "\<^bold>\<diamond>\<^sup>S\<^sup>5\<phi> \<equiv> \<lambda>c w. \<exists>v. \<phi> c v"
 lemma C_2: "\<lfloor>\<^bold>O\<langle>A | B\<rangle> \<^bold>\<rightarrow> \<^bold>\<diamond>\<^sup>S\<^sup>5(B \<^bold>\<and> A)\<rfloor>" by (simp add: sem_5ab)
 lemma C_3:  "\<lfloor>((\<^bold>\<diamond>\<^sup>S\<^sup>5(A \<^bold>\<and> B \<^bold>\<and> C)) \<^bold>\<and> \<^bold>O\<langle>B|A\<rangle> \<^bold>\<and> \<^bold>O\<langle>C|A\<rangle>) \<^bold>\<rightarrow> \<^bold>O\<langle>(B \<^bold>\<and> C)| A\<rangle>\<rfloor>" by (simp add: sem_5c)
 lemma C_4: "\<lfloor>(\<^bold>\<box>\<^sup>S\<^sup>5(A \<^bold>\<rightarrow> B) \<^bold>\<and> \<^bold>\<diamond>\<^sup>S\<^sup>5(A \<^bold>\<and> C) \<^bold>\<and> \<^bold>O\<langle>C|B\<rangle>) \<^bold>\<rightarrow> \<^bold>O\<langle>C|A\<rangle>\<rfloor>" using sem_5e by blast
 lemma C_5: "\<lfloor>\<^bold>\<box>\<^sup>S\<^sup>5(A \<^bold>\<leftrightarrow> B) \<^bold>\<rightarrow> (\<^bold>O\<langle>C|A\<rangle> \<^bold>\<rightarrow> \<^bold>O\<langle>C|B\<rangle>)\<rfloor>" using C_2 sem_5e by blast
 lemma C_6: "\<lfloor>\<^bold>\<box>\<^sup>S\<^sup>5(C \<^bold>\<rightarrow> (A \<^bold>\<leftrightarrow> B)) \<^bold>\<rightarrow> (\<^bold>O\<langle>A|C\<rangle> \<^bold>\<leftrightarrow> \<^bold>O\<langle>B|C\<rangle>)\<rfloor>" by (metis sem_5b)
 lemma C_7: "\<lfloor>\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>\<box>\<^sup>S\<^sup>5\<^bold>O\<langle>B|A\<rangle>\<rfloor>" by blast
 lemma C_8: "\<lfloor>\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>O\<langle>A \<^bold>\<rightarrow> B| \<^bold>\<top>\<rangle>\<rfloor>" using sem_5bd4 by presburger

subsubsection \<open>Verifying Axiomatic Characterisation\<close>
 (**The following theorems have been taken from the original Carmo and Jones' paper.*)
 lemma CJ_3: "\<lfloor>\<^bold>\<box>\<^sub>pA \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>aA\<rfloor>" by (simp add: sem_4a)
 lemma CJ_4: "\<lfloor>\<^bold>\<not>\<^bold>O\<langle>\<^bold>\<bottom>|A\<rangle>\<rfloor>" by (simp add: sem_5a)
 lemma CJ_5: "\<lfloor>(\<^bold>O\<langle>B|A\<rangle> \<^bold>\<and> \<^bold>O\<langle>C|A\<rangle>) \<^bold>\<rightarrow> \<^bold>O\<langle>B\<^bold>\<and>C|A\<rangle>\<rfloor>" nitpick oops (**countermodel found*)
 lemma CJ_5_minus: "\<lfloor>\<^bold>\<diamond>\<^sup>S\<^sup>5(A \<^bold>\<and> B \<^bold>\<and> C) \<^bold>\<and> (\<^bold>O\<langle>B|A\<rangle> \<^bold>\<and> \<^bold>O\<langle>C|A\<rangle>) \<^bold>\<rightarrow> \<^bold>O\<langle>B\<^bold>\<and>C|A\<rangle>\<rfloor>" by (simp add: sem_5c)
 lemma CJ_6: "\<lfloor>\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>O\<langle>B|A\<^bold>\<and>B\<rangle>\<rfloor>" by (smt C_2 C_4)
 lemma CJ_7: "\<lfloor>A \<^bold>\<leftrightarrow> B\<rfloor> \<longrightarrow> \<lfloor>\<^bold>O\<langle>C|A\<rangle> \<^bold>\<leftrightarrow> \<^bold>O\<langle>C|B\<rangle>\<rfloor>" using sem_5ab sem_5e by blast
 lemma CJ_8: "\<lfloor>C \<^bold>\<rightarrow> (A \<^bold>\<leftrightarrow> B)\<rfloor> \<longrightarrow> \<lfloor>\<^bold>O\<langle>A|C\<rangle> \<^bold>\<leftrightarrow> \<^bold>O\<langle>B|C\<rangle>\<rfloor>" using C_6 by simp
 lemma CJ_9a: "\<lfloor>\<^bold>\<diamond>\<^sub>p\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>p\<^bold>O\<langle>B|A\<rangle>\<rfloor>" by simp
 lemma CJ_9p: "\<lfloor>\<^bold>\<diamond>\<^sub>a\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>a\<^bold>O\<langle>B|A\<rangle>\<rfloor>" by simp
 lemma CJ_9_var_a: "\<lfloor>\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>a\<^bold>O\<langle>B|A\<rangle>\<rfloor>" by simp
 lemma CJ_9_var_b: "\<lfloor>\<^bold>O\<langle>B|A\<rangle> \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>p\<^bold>O\<langle>B|A\<rangle>\<rfloor>" by simp


theory TeoriaCompacidadIngles

  imports Main
"ExistenciaModelosIngles/ExistenciaModeloIngles"

begin

lemma NosatisfiableAtom:
  shows "\<not>(satisfiable {F, \<not>.F})"
proof (rule notI)
  assume hip: "satisfiable {F, \<not>.F}"
  show "False"
  proof -
    have  "\<exists>I. I model {F, \<not>.F}" using hip by(unfold satisfiable_def, auto)
    then obtain I where I: "(t_v_evaluation I F) = Ttrue"
      and "(t_v_evaluation I (\<not>.F)) = Ttrue"
      by(unfold model_def, auto)
    thus "False" by(auto simp add: v_negation_def)
  qed
qed

lemma comp1:
  assumes "\<forall> (A::'b formula set). (A\<subseteq> W \<and> finite A) \<longrightarrow> satisfiable A"
  shows "(\<forall>P. \<not> (Atom P \<in> W \<and> (\<not>. Atom P) \<in> W))"
proof (rule allI notI)+
  fix P
  assume h1: "Atom P \<in> W \<and> (\<not>.Atom P) \<in> W"
  show "False"
  proof -
    have "{Atom P, (\<not>.Atom P)} \<subseteq> W" using h1 by simp
    moreover
    have "finite {Atom P, (\<not>.Atom P)}" by simp
    ultimately
    have "{Atom P, (\<not>.Atom P)} \<subseteq> W \<and> finite {Atom P, (\<not>.Atom P)}" by simp
    moreover
    have "({Atom P, (\<not>.Atom P)}\<subseteq> W \<and> finite {Atom P, (\<not>.Atom P)}) \<longrightarrow>
          satisfiable {Atom P, (\<not>.Atom P)}"
      using assms by(rule_tac x = "{Atom P, (\<not>.Atom P)}" in allE, auto)
    ultimately
    have "satisfiable {Atom P, (\<not>.Atom P)}" by simp
    thus "False" using NosatisfiableAtom by auto
  qed
qed

lemma NosatisfiableFF:
  shows "\<not> (satisfiable {FF})"
proof -
  have "\<forall> I. t_v_evaluation I FF = Ffalse" by simp
  hence "\<forall> I. \<not> (I model {FF})"  by(unfold model_def, auto)
  thus ?thesis by(unfold satisfiable_def, auto)
qed

lemma comp2:
  assumes "\<forall> (A::'b formula set). (A\<subseteq> W \<and> finite A) \<longrightarrow> satisfiable A"
  shows "FF \<notin> W"
proof (rule notI)
  assume hip: "FF \<in> W"
  show "False"
  proof -
    have "{FF} \<subseteq> W" using hip by simp
    moreover
    have "finite {FF}" by simp
    ultimately
    have "{FF} \<subseteq> W \<and> finite {FF}" by simp
    moreover
    have "({FF::'b formula} \<subseteq> W \<and> finite {FF}) \<longrightarrow>
          satisfiable {FF::'b formula}"
      using assms by(rule_tac x = "{FF::'b formula}" in allE, auto)
    ultimately
    have "satisfiable {FF::'b formula}" by simp
    thus "False" using NosatisfiableFF by auto
  qed
qed

lemma NosatisfiableFFa:
  shows "\<not> (satisfiable {\<not>.TT})"
proof -
  have "\<forall> I. t_v_evaluation I TT = Ttrue" by simp
  have "\<forall> I. t_v_evaluation I (\<not>.TT) = Ffalse" by(auto simp add:v_negation_def)
  hence "\<forall> I. \<not> (I model {\<not>.TT})"  by(unfold model_def, auto)
  thus ?thesis by(unfold satisfiable_def, auto)
qed

lemma comp3:
  assumes "\<forall> (A::'b formula set). (A\<subseteq> W \<and> finite A) \<longrightarrow> satisfiable A"
  shows "\<not>.TT \<notin> W"
proof (rule notI)
  assume hip: "\<not>.TT \<in> W"
  show "False"
  proof -
    have "{\<not>.TT} \<subseteq> W" using hip by simp
    moreover
    have "finite {\<not>.TT}" by simp
    ultimately
    have "{\<not>.TT} \<subseteq> W \<and> finite {\<not>.TT}" by simp
    moreover
    have "({\<not>.TT::'b formula} \<subseteq> W \<and> finite {\<not>.TT}) \<longrightarrow>
          satisfiable {\<not>.TT::'b formula}"
      using assms by(rule_tac x = "{\<not>.TT::'b formula}" in allE, auto)
    ultimately
    have "satisfiable {\<not>.TT::'b formula}" by simp
    thus "False" using NosatisfiableFFa by auto
  qed
qed

lemma SubSatis:
  assumes hip1: "satisfiable S" and hip2: "S'\<subseteq> S"
  shows "satisfiable S'"
proof -
  have "\<exists>I. \<forall> F \<in> S. t_v_evaluation I F = Ttrue" using hip1
    by (unfold satisfiable_def, unfold model_def, auto)
  hence "\<exists>I. \<forall> F \<in> S'. t_v_evaluation I F = Ttrue" using hip2 by auto
  thus ?thesis by(unfold satisfiable_def, unfold model_def, auto)
qed
text\<open> \<close>
lemma satisfiableUnion1:
  assumes "satisfiable (A \<union> {\<not>.\<not>.F})"
  shows "satisfiable (A \<union> {F})"
proof -
  have "\<exists>I. \<forall> G \<in> (A \<union> {\<not>.\<not>.F}). t_v_evaluation I G = Ttrue"
    using assms by(unfold satisfiable_def, unfold model_def, auto)
  then obtain I where I: "\<forall> G \<in> (A \<union> {\<not>.\<not>.F}). t_v_evaluation I G = Ttrue"
    by auto
  hence 1: "\<forall> G \<in> A. t_v_evaluation I G = Ttrue"
    and 2: "t_v_evaluation I (\<not>.\<not>.F) = Ttrue"
    by auto
  have "tipoFormula (\<not>.\<not>.F) = NoNo" by auto
  hence "t_v_evaluation I  F = Ttrue" using EquivNoNoComp[of "\<not>.\<not>.F"] 2
    by (unfold equivalentes_def, unfold Comp1_def, auto)
  hence "\<forall> G \<in> A \<union> {F}. t_v_evaluation I G = Ttrue" using 1 by auto
  thus "satisfiable (A \<union> {F})"
    by(unfold satisfiable_def, unfold model_def, auto)
qed

lemma comp4:
  assumes hip1: "\<forall> (A::'b formula set). (A\<subseteq> W \<and> finite A) \<longrightarrow> satisfiable A"
  and hip2: "\<not>.\<not>.F \<in> W"
  shows "\<forall> (A::'b formula set). (A\<subseteq> W \<union> {F} \<and> finite A) \<longrightarrow> satisfiable A"
proof (rule allI, rule impI)+
  fix A
  assume hip: "A \<subseteq> W \<union> {F} \<and> finite A"
  show "satisfiable A"
  proof -
    have "A-{F} \<subseteq> W \<and> finite (A-{F})" using hip by auto
    hence "(A-{F}) \<union> {\<not>.\<not>.F} \<subseteq> W \<and> finite ((A-{F}) \<union> {\<not>.\<not>.F})"
      using hip2 by auto
    hence "satisfiable ((A-{F}) \<union> {\<not>.\<not>.F})" using hip1 by auto
    hence "satisfiable ((A-{F}) \<union> {F})" using  satisfiableUnion1 by blast
    moreover
    have "A\<subseteq> (A-{F}) \<union> {F}" by auto
    ultimately
    show "satisfiable A" using SubSatis by auto
  qed
qed

lemma satisfiableUnion2:
  assumes hip1: "FormulaAlfa F" and hip2: "satisfiable (A \<union> {F})"
  shows "satisfiable (A \<union> {Comp1 F,Comp2 F})"
proof -
  have "\<exists>I.\<forall> G \<in> A \<union> {F}. t_v_evaluation I G = Ttrue"
    using hip2 by(unfold satisfiable_def, unfold model_def, auto)
  then obtain I where I:  "\<forall> G \<in> A \<union> {F}. t_v_evaluation I G = Ttrue" by auto
  hence 1: "\<forall> G \<in> A. t_v_evaluation I G = Ttrue" and 2: "t_v_evaluation I F = Ttrue" by auto
  have "tipoFormula F = Alfa" using hip1 noAlfaBeta noAlfaNoNo by auto
  hence "equivalentes F (Comp1 F \<and>. Comp2 F)"
    using 2 EquivAlfaComp[of F] by auto
  hence  "t_v_evaluation I (Comp1 F \<and>. Comp2 F) = Ttrue"
    using 2 by( unfold equivalentes_def, auto)
  hence "t_v_evaluation I (Comp1 F) = Ttrue \<and> t_v_evaluation I (Comp2 F) = Ttrue"
    using ConjunctionValues by auto
  hence "\<forall> G \<in> A \<union> {Comp1 F, Comp2 F} . t_v_evaluation I G = Ttrue" using 1 by auto
  thus "satisfiable (A \<union> {Comp1 F,Comp2 F})"
    by (unfold satisfiable_def, unfold model_def, auto)
qed

lemma comp5:
  assumes hip0: "FormulaAlfa F"
  and hip1: "\<forall> (A::'b formula set). (A\<subseteq> W \<and> finite A) \<longrightarrow> satisfiable A"
  and hip2: "F \<in> W"
  shows "\<forall> (A::'b formula set). (A\<subseteq> W \<union> {Comp1 F, Comp2 F} \<and> finite A) \<longrightarrow>
  satisfiable A"
proof (rule allI, rule impI)+
  fix A
  assume hip: "A \<subseteq> W \<union> {Comp1 F, Comp2 F} \<and> finite A"
  show "satisfiable A"
  proof -
    have "A-{Comp1 F, Comp2 F} \<subseteq> W \<and> finite (A-{Comp1 F, Comp2 F})"
      using hip by auto
    hence "(A-{Comp1 F, Comp2 F}) \<union> {F} \<subseteq> W \<and>
           finite ((A-{Comp1 F, Comp2 F}) \<union> {F})"
      using hip2 by auto
    hence "satisfiable ((A-{Comp1 F, Comp2 F}) \<union> {F})"
      using hip1 by auto
    hence "satisfiable ((A-{Comp1 F, Comp2 F}) \<union> {Comp1 F, Comp2 F})"
      using hip0 satisfiableUnion2 by auto
    moreover
    have  "A \<subseteq> (A-{Comp1 F, Comp2 F}) \<union> {Comp1 F, Comp2 F}" by auto
    ultimately
    show "satisfiable A" using SubSatis by auto
  qed
qed

lemma satisfiableUnion3:
  assumes hip1: "FormulaBeta F" and hip2: "satisfiable (A \<union> {F})"
  shows "satisfiable (A \<union> {Comp1 F}) \<or> satisfiable (A \<union> {Comp2 F})"
proof -
  obtain I where I: "\<forall>G \<in> (A \<union> {F}). t_v_evaluation I G = Ttrue"
  using hip2 by(unfold satisfiable_def, unfold model_def, auto)
  hence S1: "\<forall>G \<in> A. t_v_evaluation I G = Ttrue"
    and S2: " t_v_evaluation I F = Ttrue"
    by auto
  have V: "t_v_evaluation I (Comp1 F) = Ttrue \<or> t_v_evaluation I (Comp2 F) = Ttrue"
    using hip1 S2 EquivBetaComp[of F] DisjunctionValues
    by (unfold equivalentes_def, auto)
  have "((\<forall>G \<in> A. t_v_evaluation I G = Ttrue) \<and> t_v_evaluation I (Comp1 F) = Ttrue) \<or>
        ((\<forall>G \<in> A. t_v_evaluation I G = Ttrue) \<and> t_v_evaluation I (Comp2 F) = Ttrue)"
    using V
  proof (rule disjE)
    assume "t_v_evaluation I (Comp1 F) = Ttrue"
    hence "(\<forall>G \<in> A. t_v_evaluation I G = Ttrue) \<and> t_v_evaluation I (Comp1 F) = Ttrue"
      using S1 by auto
    thus ?thesis by simp
  next
    assume "t_v_evaluation I (Comp2 F) = Ttrue"
    hence "(\<forall>G \<in> A. t_v_evaluation I G = Ttrue) \<and> t_v_evaluation I (Comp2 F) = Ttrue"
      using S1 by auto
    thus ?thesis by simp
  qed
  hence "(\<forall>G \<in> A \<union> {Comp1 F}. t_v_evaluation I G = Ttrue) \<or>
         (\<forall>G \<in> A \<union> {Comp2 F}. t_v_evaluation I G = Ttrue)"
    by auto
  hence "(\<exists>I.\<forall>G \<in> A \<union> {Comp1 F}. t_v_evaluation I G = Ttrue) \<or>
         (\<exists>I.\<forall>G \<in> A \<union> {Comp2 F}. t_v_evaluation I G = Ttrue)"
    by auto
  thus "satisfiable (A \<union> {Comp1 F}) \<or> satisfiable (A \<union> {Comp2 F})"
  by (unfold satisfiable_def, unfold model_def, auto)
qed

lemma comp6:
  assumes hip0: "FormulaBeta F"
  and hip1: "\<forall> (A::'b formula set). (A\<subseteq> W \<and> finite A) \<longrightarrow> satisfiable A"
  and hip2: "F \<in> W"
  shows "(\<forall> (A::'b formula set). (A\<subseteq> W \<union> {Comp1 F} \<and> finite A) \<longrightarrow>
  satisfiable A) \<or>
  (\<forall> (A::'b formula set). (A\<subseteq> W \<union> {Comp2 F} \<and> finite A) \<longrightarrow>
  satisfiable A)"
proof -
  { assume hip3:"\<not>((\<forall> (A::'b formula set). (A\<subseteq> W \<union> {Comp1 F} \<and> finite A) \<longrightarrow>
    satisfiable A) \<or>
    (\<forall> (A::'b formula set). (A\<subseteq> W \<union> {Comp2 F} \<and> finite A) \<longrightarrow>
    satisfiable A))"
    have "False"
    proof -
      obtain A B where A1: "A \<subseteq> W \<union> {Comp1 F}"
        and A2: "finite A"
        and A3:" \<not> satisfiable A"
        and B1: "B \<subseteq> W \<union> {Comp2 F}"
        and B2: "finite B"
        and B3: "\<not> satisfiable B"
        using hip3 by auto
      have a1: "A - {Comp1 F} \<subseteq> W"
        and a2: "finite (A - {Comp1 F})"
        using A1 and A2 by auto
      hence "satisfiable (A - {Comp1 F})" using hip1 by simp
      have b1: "B - {Comp2 F} \<subseteq> W"
        and b2: "finite (B - {Comp2 F})"
        using B1 and B2 by auto
      hence "satisfiable (B - {Comp2 F})" using hip1 by simp
      moreover
      have "(A - {Comp1 F}) \<union> (B - {Comp2 F}) \<union> {F} \<subseteq> W"
        and "finite ((A - {Comp1 F}) \<union> (B - {Comp2 F}) \<union> {F})"
        using a1 a2 b1 b2 hip2 by auto
      hence "satisfiable ((A - {Comp1 F}) \<union> (B - {Comp2 F}) \<union> {F})"
        using hip1 by simp
      hence "satisfiable ((A - {Comp1 F}) \<union> (B - {Comp2 F}) \<union> {Comp1 F})
      \<or> satisfiable ((A - {Comp1 F}) \<union> (B - {Comp2 F}) \<union> {Comp2 F})"
        using hip0 satisfiableUnion3 by auto
      moreover
      have "A \<subseteq> (A - {Comp1 F}) \<union> (B - {Comp2 F}) \<union> {Comp1 F}"
        and "B \<subseteq> (A - {Comp1 F}) \<union> (B - {Comp2 F}) \<union> {Comp2 F}"
        by auto
      ultimately
      have "satisfiable A \<or> satisfiable B" using SubSatis by auto
      thus "False" using A3 B3 by simp
    qed }
  thus ?thesis by auto
qed

lemma ConsistenciaCompacidad:
  shows "consistenceP{W::'b formula set. \<forall>A. (A\<subseteq> W \<and> finite A) \<longrightarrow>
  satisfiable A}"
proof (unfold consistenceP_def, rule allI, rule impI)
  let ?C = "{W::'b formula set.  \<forall>A. (A\<subseteq> W \<and> finite A) \<longrightarrow> satisfiable A}"
  fix W ::" 'b formula set"
  assume "W \<in> ?C"
  hence  hip: "\<forall>A. (A\<subseteq> W \<and> finite A) \<longrightarrow> satisfiable A" by simp
  show "(\<forall>P. \<not> (atom P \<in> W \<and> (\<not>.atom P ) \<in> W)) \<and>
        FF \<notin> W \<and>
        \<not>.TT \<notin> W \<and>
        (\<forall>F. \<not>.\<not>.F \<in> W \<longrightarrow> W \<union> {F} \<in> ?C) \<and>
        (\<forall>F. (FormulaAlfa F) \<and> F \<in> W \<longrightarrow>
        (W \<union>  {Comp1 F, Comp2 F} \<in> ?C)) \<and>
        (\<forall>F. (FormulaBeta F) \<and> F \<in> W \<longrightarrow>
        (W \<union> {Comp1 F} \<in> ?C \<or> W \<union> {Comp2 F} \<in> ?C))"
  proof -
    have "(\<forall>P. \<not> (atom P \<in> W \<and> (\<not>. atom P) \<in> W))"
      using hip  comp1 by simp
    moreover
    have "FF \<notin> W" using hip comp2 by auto
    moreover
    have "\<not>. TT \<notin> W" using hip comp3 by auto
    moreover
    have "\<forall>F. (\<not>.\<not>.F) \<in> W \<longrightarrow> W \<union> {F} \<in> ?C"
    proof (rule allI impI)+
      fix F
      assume hip1: "\<not>.\<not>.F \<in> W"
      show "W \<union> {F} \<in> ?C" using hip hip1 comp4 by simp
    qed
    moreover
    have
    "\<forall>F. (FormulaAlfa F) \<and> F \<in> W \<longrightarrow> (W \<union>  {Comp1 F, Comp2 F} \<in> ?C)"
    proof (rule allI impI)+
      fix F
      assume "FormulaAlfa F \<and> F \<in> W"
      thus "W \<union> {Comp1 F, Comp2 F} \<in> ?C" using hip comp5[of F] by blast
    qed
    moreover
    have "\<forall>F. (FormulaBeta F) \<and> F \<in> W \<longrightarrow>
              (W \<union> {Comp1 F} \<in> ?C \<or> W \<union> {Comp2 F} \<in> ?C)"
    proof (rule allI impI)+
      fix F
      assume "(FormulaBeta F) \<and> F \<in> W"
      thus "W \<union> {Comp1 F} \<in> ?C \<or> W \<union> {Comp2 F} \<in> ?C"
        using hip comp6[of F] by blast
    qed
    ultimately
    show ?thesis by auto
  qed
qed

theorem Compacteness_Theorem:
  assumes hip1: "\<exists>g. enumeration (g:: nat \<Rightarrow> 'b formula)"
  and hip2: "\<forall>A. (A \<subseteq> (S:: 'b formula set) \<and> finite A) \<longrightarrow> satisfiable A"
  shows "satisfiable S"
proof -
  let ?C = "{W:: 'b formula set.  \<forall>A. (A \<subseteq> W \<and> finite A) \<longrightarrow> satisfiable A}"
  have "consistenceP ?C"
    using ConsistenciaCompacidad by simp
  moreover
  have "S \<in> ?C" using hip2 by simp
  ultimately
  show "satisfiable S" using  hip1 and TeoremaExistenciaModelos[of ?C S] by auto
qed

corollary TeoremaCompacidad2:
  assumes "\<forall>A. (A \<subseteq> (S:: nat formula set) \<and> finite A) \<longrightarrow> satisfiable A"
  shows "satisfiable S"
using assms and EnumeracionFormulasNat and Compacteness_Theorem
by auto

end