(*<*)theory CTLind imports CTL begin(*>*)

subsection{*CTL Revisited*}

text{*\label{sec:CTL-revisited}
\index{CTL|(}%
The purpose of this section is twofold: to demonstrate
some of the induction principles and heuristics discussed above and to
show how inductive definitions can simplify proofs.
In \S\ref{sec:CTL} we gave a fairly involved proof of the correctness of a
model checker for CTL\@. In particular the proof of the
@{thm[source]infinity_lemma} on the way to @{thm[source]AF_lemma2} is not as
simple as one might expect, due to the @{text SOME} operator
involved. Below we give a simpler proof of @{thm[source]AF_lemma2}
based on an auxiliary inductive definition.

Let us call a (finite or infinite) path \emph{@{term A}-avoiding} if it does
not touch any node in the set @{term A}. Then @{thm[source]AF_lemma2} says
that if no infinite path from some state @{term s} is @{term A}-avoiding,
then @{prop"s \<in> lfp(af A)"}. We prove this by inductively defining the set
@{term"Avoid s A"} of states reachable from @{term s} by a finite @{term
A}-avoiding path:
% Second proof of opposite direction, directly by well-founded induction
% on the initial segment of M that avoids A.
*}

inductive_set
  Avoid :: "state \<Rightarrow> state set \<Rightarrow> state set"
  for s :: state and A :: "state set"
where
    "s \<in> Avoid s A"
  | "\<lbrakk> t \<in> Avoid s A; t \<notin> A; (t,u) \<in> M \<rbrakk> \<Longrightarrow> u \<in> Avoid s A"

text{*
It is easy to see that for any infinite @{term A}-avoiding path @{term f}
with @{prop"f(0::nat) \<in> Avoid s A"} there is an infinite @{term A}-avoiding path
starting with @{term s} because (by definition of @{const Avoid}) there is a
finite @{term A}-avoiding path from @{term s} to @{term"f(0::nat)"}.
The proof is by induction on @{prop"f(0::nat) \<in> Avoid s A"}. However,
this requires the following
reformulation, as explained in \S\ref{sec:ind-var-in-prems} above;
the @{text rule_format} directive undoes the reformulation after the proof.
*}

lemma ex_infinite_path[rule_format]:
  "t \<in> Avoid s A  \<Longrightarrow>
   \<forall>f\<in>Paths t. (\<forall>i. f i \<notin> A) \<longrightarrow> (\<exists>p\<in>Paths s. \<forall>i. p i \<notin> A)"
apply(erule Avoid.induct)
 apply(blast)
apply(clarify)
apply(drule_tac x = "\<lambda>i. case i of 0 \<Rightarrow> t | Suc i \<Rightarrow> f i" in bspec)
apply(simp_all add: Paths_def split: nat.split)
done

text{*\noindent
The base case (@{prop"t = s"}) is trivial and proved by @{text blast}.
In the induction step, we have an infinite @{term A}-avoiding path @{term f}
starting from @{term u}, a successor of @{term t}. Now we simply instantiate
the @{text"\<forall>f\<in>Paths t"} in the induction hypothesis by the path starting with
@{term t} and continuing with @{term f}. That is what the above $\lambda$-term
expresses.  Simplification shows that this is a path starting with @{term t}
and that the instantiated induction hypothesis implies the conclusion.

Now we come to the key lemma. Assuming that no infinite @{term A}-avoiding
path starts from @{term s}, we want to show @{prop"s \<in> lfp(af A)"}. For the
inductive proof this must be generalized to the statement that every point @{term t}
``between'' @{term s} and @{term A}, in other words all of @{term"Avoid s A"},
is contained in @{term"lfp(af A)"}:
*}

lemma Avoid_in_lfp[rule_format(no_asm)]:
  "\<forall>p\<in>Paths s. \<exists>i. p i \<in> A \<Longrightarrow> t \<in> Avoid s A \<longrightarrow> t \<in> lfp(af A)"

txt{*\noindent
The proof is by induction on the ``distance'' between @{term t} and @{term
A}. Remember that @{prop"lfp(af A) = A \<union> M\<inverse> `` lfp(af A)"}.
If @{term t} is already in @{term A}, then @{prop"t \<in> lfp(af A)"} is
trivial. If @{term t} is not in @{term A} but all successors are in
@{term"lfp(af A)"} (induction hypothesis), then @{prop"t \<in> lfp(af A)"} is
again trivial.

The formal counterpart of this proof sketch is a well-founded induction
on~@{term M} restricted to @{term"Avoid s A - A"}, roughly speaking:
@{term[display]"{(y,x). (x,y) \<in> M \<and> x \<in> Avoid s A \<and> x \<notin> A}"}
As we shall see presently, the absence of infinite @{term A}-avoiding paths
starting from @{term s} implies well-foundedness of this relation. For the
moment we assume this and proceed with the induction:
*}

apply(subgoal_tac "wf{(y,x). (x,y) \<in> M \<and> x \<in> Avoid s A \<and> x \<notin> A}")
 apply(erule_tac a = t in wf_induct)
 apply(clarsimp)
(*<*)apply(rename_tac t)(*>*)

txt{*\noindent
@{subgoals[display,indent=0,margin=65]}
Now the induction hypothesis states that if @{prop"t \<notin> A"}
then all successors of @{term t} that are in @{term"Avoid s A"} are in
@{term"lfp (af A)"}. Unfolding @{term lfp} in the conclusion of the first
subgoal once, we have to prove that @{term t} is in @{term A} or all successors
of @{term t} are in @{term"lfp (af A)"}.  But if @{term t} is not in @{term A},
the second
@{const Avoid}-rule implies that all successors of @{term t} are in
@{term"Avoid s A"}, because we also assume @{prop"t \<in> Avoid s A"}.
Hence, by the induction hypothesis, all successors of @{term t} are indeed in
@{term"lfp(af A)"}. Mechanically:
*}

 apply(subst lfp_unfold[OF mono_af])
 apply(simp (no_asm) add: af_def)
 apply(blast intro: Avoid.intros)

txt{*
Having proved the main goal, we return to the proof obligation that the
relation used above is indeed well-founded. This is proved by contradiction: if
the relation is not well-founded then there exists an infinite @{term
A}-avoiding path all in @{term"Avoid s A"}, by theorem
@{thm[source]wf_iff_no_infinite_down_chain}:
@{thm[display]wf_iff_no_infinite_down_chain[no_vars]}
From lemma @{thm[source]ex_infinite_path} the existence of an infinite
@{term A}-avoiding path starting in @{term s} follows, contradiction.
*}

apply(erule contrapos_pp)
apply(simp add: wf_iff_no_infinite_down_chain)
apply(erule exE)
apply(rule ex_infinite_path)
apply(auto simp add: Paths_def)
done

text{*
The @{text"(no_asm)"} modifier of the @{text"rule_format"} directive in the
statement of the lemma means
that the assumption is left unchanged; otherwise the @{text"\<forall>p"}
would be turned
into a @{text"\<And>p"}, which would complicate matters below. As it is,
@{thm[source]Avoid_in_lfp} is now
@{thm[display]Avoid_in_lfp[no_vars]}
The main theorem is simply the corollary where @{prop"t = s"},
when the assumption @{prop"t \<in> Avoid s A"} is trivially true
by the first @{const Avoid}-rule. Isabelle confirms this:%
\index{CTL|)}*}

theorem AF_lemma2:  "{s. \<forall>p \<in> Paths s. \<exists> i. p i \<in> A} \<subseteq> lfp(af A)"
by(auto elim: Avoid_in_lfp intro: Avoid.intros)

(*<*)end(*>*)


section \<open>Winning Regions\<close>

theory WinningRegion
imports
  Main
  WinningStrategy
begin

text \<open>
  Here we define winning regions of parity games.  The winning region for player \<open>p\<close> is the
  set of nodes from which \<open>p\<close> has a positional winning strategy.
\<close>

context ParityGame begin

definition "winning_region p \<equiv> { v \<in> V. \<exists>\<sigma>. strategy p \<sigma> \<and> winning_strategy p \<sigma> v }"

lemma winning_regionI [intro]:
  assumes "v \<in> V" "strategy p \<sigma>" "winning_strategy p \<sigma> v"
  shows "v \<in> winning_region p"
  using assms unfolding winning_region_def by blast

lemma winning_region_in_V [simp]: "winning_region p \<subseteq> V" unfolding winning_region_def by blast

lemma winning_region_deadends:
  assumes "v \<in> VV p" "deadend v"
  shows "v \<in> winning_region p**"
proof
  show "v \<in> V" using \<open>v \<in> VV p\<close> by blast
  show "winning_strategy p** \<sigma>_arbitrary v" using assms winning_strategy_on_deadends by simp
qed simp

subsection \<open>Paths in Winning Regions\<close>

lemma (in vmc_path) paths_stay_in_winning_region:
  assumes \<sigma>': "strategy p \<sigma>'" "winning_strategy p \<sigma>' v0"
    and \<sigma>: "\<And>v. v \<in> winning_region p \<Longrightarrow> \<sigma>' v = \<sigma> v"
  shows "lset P \<subseteq> winning_region p"
proof
  fix x assume "x \<in> lset P"
  thus "x \<in> winning_region p" using assms vmc_path_axioms
  proof (induct arbitrary: v0 rule: llist_set_induct)
    case (find P v0)
    interpret vmc_path G P v0 p \<sigma> using find.prems(4) .
    show ?case using P_v0 \<sigma>'(1) find.prems(2) v0_V unfolding winning_region_def by blast
  next
    case (step P x v0)
    interpret vmc_path G P v0 p \<sigma> using step.prems(4) .
    show ?case proof (cases)
      assume "lnull (ltl P)"
      thus ?thesis using P_lnull_ltl_LCons step.hyps(2) by auto
    next
      assume "\<not>lnull (ltl P)"
      then interpret vmc_path_no_deadend G P v0 p \<sigma> using P_no_deadend_v0 by unfold_locales
      have "winning_strategy p \<sigma>' w0" proof (cases)
        assume "v0 \<in> VV p"
        hence "winning_strategy p \<sigma>' (\<sigma>' v0)"
          using strategy_extends_VVp local.step(4) step.prems(2) v0_no_deadend by blast
        moreover have "\<sigma> v0 = w0" using v0_conforms \<open>v0 \<in> VV p\<close> by blast
        moreover have "\<sigma>' v0 = \<sigma> v0"
          using \<sigma> assms(1) step.prems(2) v0_V unfolding winning_region_def by blast
        ultimately show ?thesis by simp
      next
        assume "v0 \<notin> VV p"
        thus ?thesis using v0_V strategy_extends_VVpstar step(4) step.prems(2) by simp
      qed
      thus ?thesis using step.hyps(3) step(4) \<sigma> vmc_path_ltl by blast
    qed
  qed
qed

lemma (in vmc_path) path_hits_winning_region_is_winning:
  assumes \<sigma>': "strategy p \<sigma>'" "\<And>v. v \<in> winning_region p \<Longrightarrow> winning_strategy p \<sigma>' v"
    and \<sigma>: "\<And>v. v \<in> winning_region p \<Longrightarrow> \<sigma>' v = \<sigma> v"
    and P: "lset P \<inter> winning_region p \<noteq> {}"
  shows "winning_path p P"
proof-
  obtain n where n: "enat n < llength P" "P $ n \<in> winning_region p"
    using P by (meson lset_intersect_lnth)
  define P' where "P' = ldropn n P"
  then interpret P': vmc_path G P' "P $ n" p \<sigma>
    unfolding P'_def using vmc_path_ldropn n(1) by blast
  have "winning_strategy p \<sigma>' (P $ n)" using \<sigma>'(2) n(2) by blast
  hence "lset P' \<subseteq> winning_region p"
    using P'.paths_stay_in_winning_region[OF \<sigma>'(1) _ \<sigma>]
    by blast
  hence "\<And>v. v \<in> lset P' \<Longrightarrow> \<sigma> v = \<sigma>' v" using \<sigma> by auto
  hence "path_conforms_with_strategy p P' \<sigma>'"
    using path_conforms_with_strategy_irrelevant_updates P'.P_conforms
    by blast
  then interpret P': vmc_path G P' "P $ n" p \<sigma>' using P'.conforms_to_another_strategy by blast
  have "winning_path p P'" using \<sigma>'(2) n(2) P'.vmc_path_axioms winning_strategy_def by blast
  thus "winning_path p P" unfolding P'_def using winning_path_drop_add n(1) P_valid by blast
qed

subsection \<open>Irrelevant Updates\<close>

text \<open>Updating a winning strategy outside of the winning region is irrelevant.\<close>

lemma winning_strategy_updates:
  assumes \<sigma>: "strategy p \<sigma>" "winning_strategy p \<sigma> v0"
    and v: "v \<notin> winning_region p" "v\<rightarrow>w"
  shows "winning_strategy p (\<sigma>(v := w)) v0"
proof
  fix P assume "vmc_path G P v0 p (\<sigma>(v := w))"
  then interpret vmc_path G P v0 p "\<sigma>(v := w)" .
  have "\<And>v'. v' \<in> winning_region p \<Longrightarrow> \<sigma> v' = (\<sigma>(v := w)) v'" using v by auto
  hence "v \<notin> lset P" using v paths_stay_in_winning_region \<sigma> unfolding winning_region_def by blast
  hence "path_conforms_with_strategy p P \<sigma>"
    using P_conforms path_conforms_with_strategy_irrelevant' by blast
  thus "winning_path p P" using conforms_to_another_strategy \<sigma>(2) winning_strategy_def by blast
qed

subsection \<open>Extending Winning Regions\<close>

lemma winning_region_extends_VVp:
  assumes v: "v \<in> VV p" "v\<rightarrow>w" and w: "w \<in> winning_region p"
  shows "v \<in> winning_region p"
proof (rule ccontr)
  obtain \<sigma> where \<sigma>: "strategy p \<sigma>" "winning_strategy p \<sigma> w"
    using w unfolding winning_region_def by blast
  let ?\<sigma> = "\<sigma>(v := w)"
  assume contra: "v \<notin> winning_region p"
  moreover have "strategy p ?\<sigma>" using valid_strategy_updates \<sigma>(1) \<open>v\<rightarrow>w\<close> by blast
  moreover hence "winning_strategy p ?\<sigma> v"
    using winning_strategy_updates \<sigma> contra v strategy_extends_backwards_VVp
    by auto
  ultimately show False using \<open>v\<rightarrow>w\<close> unfolding winning_region_def by auto
qed

text \<open>
  Unfortunately, we cannot prove the corresponding theorem \<open>winning_region_extends_VVpstar\<close>
  for @{term "VV p**"}-nodes yet.
  First, we need to show that there exists a uniform winning strategy on @{term "winning_region p"}.
  We will prove \<open>winning_region_extends_VVpstar\<close> as soon as we have this.
\<close>

end \<comment> \<open>context ParityGame\<close>

end


theory Cantor_Set
imports Main Real Series "~~/src/HOL/Library/Product_Vector"
begin

subsection {* Definition of the Cantor Set *}

definition go_left :: "real \<Rightarrow> real" where "go_left x = x/3"
definition go_right :: "real \<Rightarrow> real" where "go_right x = 2/3 + x/3"

fun cantor_n where
  "cantor_n 0 = {0::real..1}"
| "cantor_n (Suc n) = go_left ` cantor_n n \<union> go_right ` cantor_n n"
definition "cantor \<equiv> \<Inter>range cantor_n"

lemma cantor_bounds:
  assumes "x \<in> cantor"
  shows "0 \<le> x \<and> x \<le> 1"
proof-
  from assms have "x \<in> cantor_n 0" by (auto simp add: cantor_def simp del: cantor_n.simps)
  thus ?thesis by simp
qed

subsection {* Representing reals from [0,1] to base n *}

locale ary =
  fixes n :: nat
  assumes ng1: "n > 1"
begin

text {*
The mod n is a trick to do something slightly more useful when the input has digits outside
the range.
*}
definition n_ary_series :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> real" where
  "n_ary_series f = (\<lambda>k. real (f k mod n) * (1 / n) ^ Suc k)"
declare power_Suc[simp del]

definition to_real :: "(nat \<Rightarrow> nat) \<Rightarrow> real"
  where "to_real = (\<lambda> f. suminf (n_ary_series f))"

lemma summable_geometric': "norm (c::real) < 1 \<Longrightarrow> summable (\<lambda>k. c ^ (Suc k))"
  apply (rule summable_ignore_initial_segment[of _ 1, simplified Suc_eq_plus1[symmetric]])
  apply (rule summable_geometric)
  by simp

lemma suminf_geometric': "norm (c::real) < 1 \<Longrightarrow> (\<Sum>n. c ^ Suc n) = c / (1 - c)"
  apply (subst suminf_minus_initial_segment[of _ 1, simplified Suc_eq_plus1[symmetric]])
  apply (erule summable_geometric)
  apply (subst suminf_geometric, simp, simp)
  apply (subst mult_right_cancel[of "1 - c", symmetric])
  by (auto simp:left_diff_distrib)

lemma n_ary_series_div[simp]: "n_ary_series f i / n = n_ary_series (\<lambda> i. f (i - 1)) (Suc i)"
  unfolding n_ary_series_def
  by (simp add: power_Suc)

text {* The n-ary representation of 1. *}
definition "period_one \<equiv> n_ary_series (\<lambda>_. n - 1)"

lemma period_one_summable[simp]: "summable period_one"
  using ng1 by (auto simp:n_ary_series_def period_one_def intro!:summable_geometric' summable_mult)

lemma suminf_period_one_1[simp]: "suminf period_one = 1"
  using ng1
  unfolding period_one_def n_ary_series_def
  apply (subst suminf_mult)
  apply (rule summable_geometric')
  apply simp
  apply (subst suminf_geometric')
  by (auto simp:right_diff_distrib)

lemma period_one_skip_initial_segment[simp]:
  "(\<Sum>k. period_one (k + i)) = (1/n) ^ i * suminf period_one"
  by (subst suminf_mult[symmetric], simp, rule arg_cong[where f=suminf], auto simp:period_one_def n_ary_series_def power_Suc power_add)

lemma n_ary_summable[simp]:
  shows "summable (n_ary_series f)"
proof (rule summableI_nonneg_bounded[where x="suminf period_one"])
  fix k
  show "0 \<le> n_ary_series f k" using assms by (auto simp: n_ary_series_def intro!:mult_nonneg_nonneg)
  have "setsum (n_ary_series f) {..<k} \<le> setsum (period_one) {..<k}"
    using assms ng1
    by (auto simp:n_ary_series_def period_one_def intro!:setsum_mono)
       (metis Suc_pred mod_less_divisor neq0_conv not_less not_less_eq old.nat.distinct(2))
  also have "... \<le> suminf period_one" using assms
    by -(intro setsum_le_suminf period_one_summable,
         auto intro: simp:period_one_def n_ary_series_def)
  finally show "setsum (n_ary_series f) {..<k} \<le> suminf period_one" .
qed

lemma nary_pos[simp]: "to_real f \<ge> 0"
  unfolding to_real_def
  by (rule suminf_nonneg, simp) (auto simp:n_ary_series_def)

lemma nary_le_1[simp]:
  shows "to_real f \<le> 1"
proof-
  have "suminf (n_ary_series f) \<le> suminf period_one"
  proof (rule suminf_le, rule)
    fix i
    from ng1 have "f i mod n < n" by simp
    thus "n_ary_series f i \<le> period_one i"
      unfolding n_ary_series_def period_one_def  by auto
  next
    show "summable (n_ary_series f)" by (rule n_ary_summable)
  next
    show "summable period_one" by (rule period_one_summable)
  qed
  also have "\<dots> = 1" by (rule suminf_period_one_1)
  finally show ?thesis unfolding to_real_def .
qed

subsection {* The n-arity expansion of a real *}

fun to_nary :: "real \<Rightarrow> (nat \<Rightarrow> nat)"
 where "to_nary x i = (if x = 1 then n - 1 else natfloor (x * n^(Suc i)) mod n)"

(* Generalized Real.natfloor_div_nat, included in the main library since Oct 2014. *)
lemma natfloor_div_nat:
  assumes "y > 0"
  shows "natfloor (x / real y) = natfloor x div y"
proof-
  have "x \<le> 0 \<or> x \<ge> 0 \<and> x < 1 \<or> 1 \<le> x" by arith
  thus ?thesis
  proof(elim conjE disjE)
    assume *: "1 \<le> x"
    show ?thesis by (rule Real.natfloor_div_nat[OF * assms])
  next
    assume *: "x \<le> 0"
    moreover
    from * assms have "x / y \<le> 0" by (simp add: field_simps)
    ultimately
    show ?thesis by (simp add: natfloor_neg)
  next
    assume *: "x \<ge> 0" "x < 1"
    hence "natfloor x = 0" by (auto intro: natfloor_eq)
    moreover
    from * assms have "x / y \<ge> 0" and "x / y < 1" by (auto simp add: field_simps)
    hence "natfloor (x/y) = 0" by (auto intro: natfloor_eq)
    ultimately
    show ?thesis by simp
  qed
qed

lemma natfloor_mod:
  fixes x :: real
  shows "n * natfloor x + natfloor (n * x) mod n = natfloor (n * x)"
proof-
  have "natfloor (n * x) = n * (natfloor (n * x) div n) + natfloor (n * x) mod n"
    by (metis mod_div_equality2)
  also have "natfloor (n * x) div n = natfloor (n * x / n)"
    apply (rule natfloor_div_nat[symmetric])
    using ng1 by auto
  also have "n * x / n = x" using ng1 by simp
  finally show ?thesis..
qed

lemma partial_n_ary:
  fixes x :: real
  assumes "0 \<le> x" "x < 1"
  shows "setsum (n_ary_series (to_nary x)) {..<i} = natfloor (x * n^i) / n^i"
proof (induction i)
  case 0
  from assms have "natfloor x = 0" by (auto intro: natfloor_eq)
  thus ?case by simp
next
  case (Suc i)
    have "setsum (n_ary_series (to_nary x)) {..<Suc i}
      =  setsum (n_ary_series (to_nary x)) {..<i} + n_ary_series (to_nary x) i"
     by simp
   also have "\<dots> = natfloor (x * real (n ^ i)) / real (n ^ i) + n_ary_series (to_nary x) i"
     unfolding Suc.IH..
   also have "\<dots> = natfloor (x * n ^ i) /  n ^ i + (natfloor (x * n ^ Suc i) mod n) / n ^ Suc i"
     using assms(2) by (simp add: n_ary_series_def field_simps)
   also have "\<dots> = (n * natfloor (x * n ^ i) + natfloor (n * (x * n ^ i)) mod n) / n ^ Suc i"
     using ng1 by (simp add: field_simps power_Suc)
   also have "\<dots> = natfloor (n * (x * n^i)) / n^Suc i"
     unfolding natfloor_mod..
   also have "\<dots> = natfloor (x * n^(Suc i)) / n^Suc i" by (simp add: power_Suc field_simps)
   finally
   show ?case.
qed

lemma bounded_0_inverse:
  fixes f :: "nat \<Rightarrow> real"
  assumes "x < 1"
  assumes "c > 0"
  assumes "\<And> i. 0 \<le> f i"
  assumes "\<And> i. f i \<le> c * x^i"
  shows "f ----> 0"
proof(rule tendsto_sandwich[OF eventually_sequentiallyI eventually_sequentiallyI])
  fix n show "0 \<le> f n" by fact
next
  fix n show "f n \<le> c*x^n" by fact
next
  show "(\<lambda>x. 0) ----> 0"  by (rule tendsto_const)
next
  have "0 \<le> x" by (metis assms(2-4) le_less_trans mult.commute mult_zero_left not_less power_one_right real_mult_le_cancel_iff1)
  hence "op ^ x ----> 0"
    by (rule LIMSEQ_realpow_zero[OF _ assms(1)])
  thus "(\<lambda> i. c * x^i) ----> 0"
    by (rule tendsto_mult_right_zero)
qed

lemma to_real_to_nary:
  fixes x :: real
  assumes "0 \<le> x" "x \<le>1"
  shows "to_real (to_nary x) = x"
proof(cases "x = 1")
  case False with assms(2) have "x < 1" by simp

  have "to_real (to_nary x) = lim (\<lambda>i. setsum (n_ary_series (to_nary x)) {..<i})"
    unfolding to_real_def by (rule suminf_eq_lim)
  also have "\<dots> = lim (\<lambda>i. natfloor (x * n^i) / n^i)"
    unfolding partial_n_ary[OF assms(1) `x < 1` ] by simp
  also have "\<dots> = x"
  proof(rule limI)
    have "(\<lambda>i. x - (natfloor (x * (n ^ i))) / (n ^ i)) ----> 0"
    proof(rule bounded_0_inverse)
      fix i
      have "natfloor (x * (n^i)) \<le> x * (n^i)"
          using assms by (simp add: real_natfloor_le field_simps)
      thus "0 \<le> x - natfloor (x * (n^i)) / (n^i)"
          using ng1 by (simp add: field_simps)
    next
      fix i
      have "x * (n^i) - natfloor (x * (n^i)) \<le> 1"
         by (metis comm_monoid_diff_class.diff_cancel le_natfloor_eq_one less_eq_real_def natfloor_neg natfloor_one natfloor_subtract not_le power_0 power_eq_0_iff)
      from divide_right_mono[OF this, where c = "n^i"] assms(1)
      show "x - natfloor (x * (n ^ i)) / (n ^ i) \<le> 1 * (1/n)^i"
        using ng1 by (simp add: field_simps )
    next
      show "1/n < 1" using ng1 by auto
    next
      show "0 < (1::real)" by auto
    qed
    thus "(\<lambda>i. (natfloor (x * (n ^ i))) / (n ^ i)) ----> x"
      by (rule LIMSEQ_diff_approach_zero2[OF tendsto_const])
  qed
  finally show ?thesis.
next
  case True
  hence "to_nary x = (\<lambda>i. n - 1)" by auto
  thus ?thesis
    unfolding to_real_def using True suminf_period_one_1[unfolded period_one_def] by simp
qed

lemma range_to_real:
  shows "range to_real = {0..1}"
proof(intro set_eqI iffI)
  fix x :: real
  assume "x \<in> {0..1}" hence "0 \<le> x" and "x \<le> 1" by auto

  have "x = to_real (to_nary x)"
    by (rule to_real_to_nary[OF assms `0 \<le> x` `x \<le> 1`, symmetric])
  then
  show "x \<in> range to_real" by auto
qed auto

end

text {* We only really need this with @{term "n = 3"} there: *}
interpretation ary 3 by default auto

subsection {* A cantor-like set on the representations *}

definition r_go_left :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat)"
  where "r_go_left f = (\<lambda> i. if i = 0 then 0 else f (i - 1))"
definition r_go_right :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat)"
  where "r_go_right f= (\<lambda> i. if i = 0 then 2 else f (i - 1))"

fun r_cantor_n where
  "r_cantor_n 0 = UNIV"
| "r_cantor_n (Suc n) = r_go_left ` r_cantor_n n \<union> r_go_right ` r_cantor_n n"
definition "r_cantor \<equiv> \<Inter>range r_cantor_n"

subsection {* A bijection between the Cantor Set and a subset of ternary representations *}

subsubsection {* Recognizing the cantor sets via their digits *}

lemma r_cantor_n_cantor_ary: "f \<in> r_cantor_n n \<longleftrightarrow> (\<forall>i<n. f i \<in> {0,2})"
proof(intro iffI conjI)
  fix n
  assume "f \<in> r_cantor_n n"
  thus "\<forall>i<n. f i \<in> {0,2}"
  proof(induction n arbitrary: f)
    case (Suc n)
    hence "f \<in> r_go_left ` r_cantor_n n \<or> f \<in> r_go_right ` r_cantor_n n" by simp
    then obtain f' where "f' \<in> r_cantor_n n" and "f = r_go_left f' \<or> f = r_go_right f'" by auto
    from Suc.IH[OF this(1)]
    have "\<forall>i<n. f' i \<in> {0, 2}".
    hence "\<forall>i<n. f (Suc i) \<in> {0, 2}"
      using `f = _ \<or> f = _`
      by (auto simp add:  r_go_left_def   r_go_right_def)
    moreover
    have "f 0 \<in> {0, 2}"
      using `f = _ \<or> f = _`
      by (auto simp add:  r_go_left_def   r_go_right_def)
    ultimately
    show ?case by (metis less_Suc_eq_0_disj)
  qed simp
next
  fix n
  assume "\<forall>i<n. f i \<in> {0, 2}"
  thus "f \<in> r_cantor_n n"
  proof(induction n arbitrary: f)
    case 0 thus ?case by simp
  next
    case (Suc n)
    hence "f 0 = 0 \<or> f 0 = 2" by simp
    hence "f = r_go_left (\<lambda> i. f (Suc i)) \<or> f =  r_go_right (\<lambda> i. f (Suc i))"
      by (auto simp add:  r_go_left_def   r_go_right_def)
    moreover
    from Suc.prems
    have "(\<lambda> i. f (Suc i)) \<in> r_cantor_n n"
      by (auto intro!: Suc.IH)
    ultimately
    show "f \<in> r_cantor_n (Suc n)" by auto
  qed
qed

lemma r_cantor_zero_or_two: "f \<in> r_cantor \<longleftrightarrow> (\<forall> i. f i \<in> {0,2})"
proof-
  have "f \<in> r_cantor \<longleftrightarrow> (\<forall>n. f \<in> r_cantor_n n)" by (auto simp add: r_cantor_def)
  also have "\<dots> \<longleftrightarrow> (\<forall>n. (\<forall>i<n. f i \<in> {0,2}))" unfolding r_cantor_n_cantor_ary..
  also have "\<dots> \<longleftrightarrow> (\<forall>n. f n \<in> {0,2})" by auto
  finally show ?thesis.
qed

subsubsection {* @{term to_real} is continuous (in a sense) *}

lemma n_ary_series_diff:
  shows "\<bar>n_ary_series a k - n_ary_series b k\<bar> \<le> (1/3)^k"
proof-
  have "\<bar>n_ary_series a k - n_ary_series b k\<bar> = \<bar>real (a k mod 3) - real(b k mod 3)\<bar> * (1 / 3) ^ Suc k"
    unfolding n_ary_series_def by (auto simp add: field_simps)
  also
   have "\<bar>real (a k mod 3)\<bar> < 3" and  "\<bar>real (b k mod 3)\<bar> < 3" by auto
  hence "\<bar>real (a k mod 3) - real(b k mod 3)\<bar> \<le> 3" by auto
  also have "(3::real) * (1 / 3) ^ Suc k = (1/3)^k" by (simp add: power_Suc field_simps)
  finally show ?thesis by this auto
qed

lemma to_real_cont:
  assumes "\<forall>j<n. a j = b j"
  shows "\<bar>to_real a - to_real b\<bar> \<le> 3 * (1 / 3) ^ n"
proof-
  note sm' = summable_diff[OF n_ary_summable n_ary_summable]
  have sm''': "summable (\<lambda>i. ((1 / 3)::real) ^ i)" by (rule summable_geometric) simp
  hence sm''': "summable (\<lambda>i.  (1/3 :: real) ^ (i + n))" by (metis summable_iff_shift[where k = n])
  hence sm'': "summable (\<lambda>i. \<bar>n_ary_series a (i + n) - n_ary_series b (i + n)\<bar>)"
    apply (rule summable_rabs_comparison_test[rotated])
    using n_ary_series_diff
    apply auto
    done

  have "\<bar>to_real a - to_real b\<bar> = \<bar>(\<Sum>i. n_ary_series a i - n_ary_series b i)\<bar>"
    unfolding to_real_def by (rule arg_cong[OF suminf_diff[OF n_ary_summable n_ary_summable]])
  also have "\<dots> = \<bar>(\<Sum>i. n_ary_series a (i + n) - n_ary_series b (i + n)) + setsum (\<lambda> i. n_ary_series a i - n_ary_series b i) {..<n}\<bar>"
    by (rule arg_cong[OF suminf_split_initial_segment[OF sm']])
  also have "\<dots> = \<bar>(\<Sum>i. n_ary_series a (i + n) - n_ary_series b (i + n))\<bar>"
    using assms(1) by (auto simp add: n_ary_series_def)
  also have "\<dots> \<le> (\<Sum>i. \<bar>n_ary_series a (i + n) - n_ary_series b (i + n)\<bar>)"
    by (rule summable_rabs[OF sm''])
  also have "\<dots> \<le> (\<Sum>i. (1/3::real)^(i + n))"
    by (intro suminf_le[OF _ sm'' sm'''] allI n_ary_series_diff)
  also have "\<dots> = (\<Sum>i. (1/3::real)^i * (1/3::real)^n)"
    by (simp add: field_simps add: power_add)
  also have "\<dots> = (\<Sum>i. (1/3::real)^i) * (1/3::real)^n"
    by (rule suminf_mult2[symmetric, OF summable_geometric]) simp
  also have "\<dots> = 1 / (1 - 1 / 3) * (1 / 3) ^ n"
    by (simp add: suminf_geometric)
  also have "\<dots> \<le> 3 *  (1 / 3) ^ n" by (simp add: field_simps)
  finally show ?thesis.
qed

subsubsection {* Injectivity *}

lemma to_real_inj_aux:
  assumes cantor_at_i: "a i \<in> {0,2}"  "b i \<in> {0,2}"
  assumes ord: "a i < b i" "\<forall>j<i. a j = b j"
  assumes eq: "to_real a = to_real b"
  shows False
proof-
  have[simp]: "a i = 0" "b i = 2" using ord(1) cantor_at_i by auto
  have[simp]: "n_ary_series b i = 2 * (1/3) ^ Suc i" by (auto simp:n_ary_series_def)

  note sm = summable_ignore_initial_segment[OF n_ary_summable]
            summable_ignore_initial_segment[OF period_one_summable]

  have "suminf (n_ary_series a) = (\<Sum>n. n_ary_series a (n + i)) + setsum (n_ary_series a) {..<i}"
    by (rule suminf_split_initial_segment[OF n_ary_summable])
  also have "(\<Sum>n. n_ary_series a (n + i)) = (\<Sum>n. n_ary_series a (n + Suc i))"
    by (subst suminf_split_initial_segment[OF sm(1), where k=1]) (simp add:n_ary_series_def)
  also have "... \<le> (\<Sum>n. period_one (n + Suc i))"
    by (rule suminf_le[OF _ sm]) (auto simp add: n_ary_series_def period_one_def)
  also have "... = (1/3) ^ Suc i" by (simp del: add_Suc_right)
  also have "... < 2 * (1/3) ^ Suc i" by simp
  also have "... \<le> (\<Sum>n. n_ary_series b (n + i))"
  proof-
    have "0 \<le> (\<Sum>n. n_ary_series b (n + Suc i))"
    by (rule suminf_nonneg[OF sm(1)]) (simp add:n_ary_series_def)
    thus ?thesis by (subst suminf_split_initial_segment[OF sm(1), where k=1]) auto
  qed
  also have "... + setsum (n_ary_series  a) {..<i} = suminf (n_ary_series b)"
  proof-
    have 1: "setsum (n_ary_series a) {..<i} = setsum (n_ary_series b) {..<i}" using ord(2) by (auto simp:n_ary_series_def)
    show ?thesis by (subst 1) (rule suminf_split_initial_segment[OF n_ary_summable, symmetric])
  qed
  finally show False using eq unfolding to_real_def by auto
qed

lemma to_real_inj_next:
  assumes cantor_at_i: "a i \<in> {0,2}"  "b i \<in> {0,2}"
  assumes "\<forall>j<i. a j = b j"
  assumes eq: "to_real a = to_real b"
  shows "a i = b i"
proof(rule ccontr)
  assume ne: "a i \<noteq> b i"
  hence "a i < b i \<or> b i < a i" by auto
  thus False
  proof
    assume *: "a i < b i"
    show False by (rule to_real_inj_aux[OF assms(1,2) * assms(3,4)])
  next
    assume *: "b i < a i"
    note assms(2,1) *
    moreover
    from assms(3) have "\<forall>j<i. b j = a j" by auto
    moreover
    note eq[symmetric]
    ultimately
    show False by (rule to_real_inj_aux)
  qed
qed

lemma to_real_inj: "inj_on to_real r_cantor"
proof (rule inj_onI, rule)
  fix a b i
  assume asms: "a \<in> r_cantor" "b \<in> r_cantor" "to_real a = to_real b"

  show "a i = b i"
  proof(induction i rule: measure_induct)
    fix i

    from asms(1,2)
    have "a i \<in> {0,2}" and "b i \<in> {0,2}" unfolding r_cantor_zero_or_two by auto
    moreover
    assume "\<forall>j<i. a j = b j"
    moreover
    note `to_real _ = to_real _`
    ultimately
    show "a i = b i" by (rule to_real_inj_next)
  qed
qed

subsubsection {* Surjectivity *}

lemma suminf_split_first:
  assumes "summable (f :: nat \<Rightarrow> real)"
  shows "suminf f = (\<Sum>n. f (Suc n)) + f 0"
  using suminf_split_initial_segment[OF assms, of 1]
  by simp

lemma summable_changed:
  assumes "summable (f :: nat \<Rightarrow> real)"
  shows "summable (\<lambda>i. if i = 0 then x else f i)"
using assms summable_iff_shift[where k = 1 and f = f] summable_iff_shift[where k = 1 and f = " (\<lambda>i. if i = 0 then x else f i)"]
by simp

lemma suminf_shift:
  assumes "summable (f :: nat \<Rightarrow> real)"
  shows "x + (\<Sum>i. f (Suc i)) = (\<Sum>i. if i = 0 then x else f i)"
  by (simp add: suminf_split_first[OF summable_changed[OF assms]])

lemma to_real_go_right[simp]:
  shows "go_right (to_real f) = to_real (r_go_right f)"
proof-
  have "go_right (to_real f) = 2/3 + to_real f / 3" by (simp add: go_right_def)
  also have "\<dots> = 2/3 + (\<Sum>i. n_ary_series f i) / 3" by (simp add: to_real_def)
  also have "\<dots> = 2/3 + (\<Sum>i. n_ary_series f i / 3)" unfolding suminf_divide[OF n_ary_summable, symmetric]..
  also have "\<dots> = 2/3 + (\<Sum>i. n_ary_series (\<lambda> i. f (i - 1)) (Suc i))"
    by (metis n_ary_series_div real_of_nat_numeral)
  also have "\<dots> = (\<Sum>i. if i = 0 then 2/3 else n_ary_series (\<lambda> i. f (i - 1)) i)"
    by (rule suminf_shift[OF n_ary_summable])
  also have "\<dots> = (\<Sum>i. n_ary_series (\<lambda> i. if i = 0 then 2 else f (i - 1)) i)"
    by (rule arg_cong[where f = suminf]) (auto simp add: n_ary_series_def power_Suc)
  also have "\<dots> = (\<Sum>i. n_ary_series (r_go_right f) i)"
    by (simp add: r_go_right_def)
  also have "\<dots> = to_real (r_go_right f)"
    by (simp add: to_real_def)
  finally show ?thesis.
qed

lemma to_real_go_left[simp]:
  shows "go_left (to_real f) = to_real (r_go_left f)"
proof-
  have "go_left (to_real f) = to_real f / 3" by (simp add: go_left_def)
  also have "\<dots> = (\<Sum>i. n_ary_series f i) / 3" by (simp add: to_real_def)
  also have "\<dots> = (\<Sum>i. n_ary_series f i / 3)" by (rule suminf_divide[OF n_ary_summable, symmetric])
  also have "\<dots> = (\<Sum>i. n_ary_series (\<lambda> i. f (i - 1)) (Suc i))"
    by (metis n_ary_series_div real_of_nat_numeral)
  also have "\<dots> = 0 + (\<Sum>i. n_ary_series (\<lambda> i. f (i - 1)) (Suc i))"
    by simp
  also have "\<dots> = (\<Sum>i. if i = 0 then 0 else n_ary_series (\<lambda> i. f (i - 1)) i)"
    by (rule suminf_shift[OF n_ary_summable])
  also have "\<dots> = (\<Sum>i. n_ary_series (\<lambda> i. if i = 0 then 0 else f (i - 1)) i)"
    by (rule arg_cong[where f = suminf])  (auto simp add: n_ary_series_def)
  also have "\<dots> = (\<Sum>i. n_ary_series (r_go_left f) i)"
    by (simp add: r_go_left_def)
  also have "\<dots> = to_real (r_go_left f)"
    by (simp add: to_real_def)
  finally show ?thesis.
qed

lemma cantor_n_eq:  "cantor_n n = to_real` r_cantor_n n"
proof(induction n)
  case 0
  have "cantor_n 0  = {0..1}" by simp
  also have "\<dots> = range to_real" by (rule range_to_real[symmetric])
  also have "\<dots> = to_real ` r_cantor_n 0" by simp
  finally show ?case.
next
  case (Suc n)
  have "cantor_n (Suc n) = go_left ` cantor_n n \<union> go_right ` cantor_n n" by simp
  also have "\<dots> = go_left ` (to_real ` r_cantor_n n) \<union> go_right ` (to_real ` r_cantor_n n)"
    unfolding Suc.IH..
  also have "\<dots> = to_real ` r_go_left ` r_cantor_n n \<union> to_real ` r_go_right ` r_cantor_n n"
    by (simp add: image_image cong: image_cong)
  also have "\<dots> = to_real ` (r_go_left ` r_cantor_n n \<union> r_go_right ` r_cantor_n n)" by auto
  also have "\<dots> = to_real ` (r_cantor_n (Suc n))" by simp
  finally show ?case.
qed

lemma r_cantor_n_mono: "n \<le> m \<Longrightarrow> r_cantor_n m \<subseteq> r_cantor_n n"
  by (auto simp add: r_cantor_n_cantor_ary)

lemma r_cantor_n_same_prefix:
  assumes "a \<in> r_cantor_n n" "b \<in> r_cantor_n n"
  assumes eq: "to_real a = to_real b"
  shows "\<forall>j<n. a j = b j"
  using assms(1,2)
proof(induction n)
  case 0 show ?case by simp
next
  case (Suc n)
  from `a \<in> r_cantor_n (Suc n)` `b \<in> r_cantor_n (Suc n)`
  have "a n \<in> {0,2}" and "b n \<in> {0,2}" unfolding r_cantor_n_cantor_ary by auto
  moreover
  from  `a \<in> r_cantor_n (Suc n)` `b \<in> r_cantor_n (Suc n)`
  have "a \<in> r_cantor_n n" and "b \<in> r_cantor_n n"
    using r_cantor_n_mono[where n = n and m = "Suc n"] by auto
  hence "\<forall>j<n. a j = b j" by (rule Suc.IH)
  moreover
  note eq
  ultimately
  have "a n = b n" by (rule to_real_inj_next)
  with `\<forall>j<n. a j = b j`
  show ?case by (metis less_antisym)
qed

theorem to_real_surj: "to_real ` r_cantor = cantor"
proof
  show "to_real` r_cantor \<subseteq> cantor"
  unfolding cantor_def r_cantor_def
  by (auto simp add: cantor_n_eq)
next
  show "cantor \<subseteq> to_real ` r_cantor"
  proof
    fix x
    assume "x \<in> cantor"
    hence "\<forall> n. \<exists> f. f \<in> r_cantor_n n \<and> x = to_real f"
      by (auto simp add: cantor_def cantor_n_eq)
    then obtain f where f: "\<And>n. f n \<in> r_cantor_n n" "\<And> n . x = to_real (f n)" by metis

    { fix n m :: nat
      note f(1)
      moreover
      assume "n \<le> m" with f(1)
      have "f m \<in> r_cantor_n n" by (metis r_cantor_n_mono subsetCE)
      moreover
      from f(2) have "to_real (f n) = to_real (f m)" by auto
      ultimately
      have "\<forall>j<n. f n j = f m j" by (rule r_cantor_n_same_prefix)
    }
    note * = this
    def f' == "\<lambda> n. f (Suc n) n"

    have "\<forall> n. f' n \<in> {0,2}" using f(1) by (metis f'_def lessI r_cantor_n_cantor_ary)
    hence "f' \<in> r_cantor" unfolding r_cantor_zero_or_two.
    moreover
    have "(\<lambda> n. abs (to_real f' - to_real (f n))) ----> 0"
    proof(rule bounded_0_inverse)
      fix n
      show "0 \<le> \<bar>to_real f' - to_real (f n)\<bar>" by simp
      have "\<forall>j<n. f' j = f n j"  by (auto simp add: f'_def *)
      thus "\<bar>to_real f' - to_real (f n)\<bar> \<le> 3* (1/3)^n" by (rule to_real_cont)
    next
      show "1/3 < (1::real)" and "0 < (3::real)" by auto
    qed
    hence "(\<lambda> n. to_real f' - to_real (f n)) ----> 0" by (rule tendsto_rabs_zero_cancel)
    hence "(\<lambda> n. to_real f' - x) ----> 0" unfolding f(2)[symmetric].
    hence "x = to_real f'" by (simp add: LIMSEQ_const_iff)
    ultimately
    show "x \<in> to_real ` r_cantor" by auto
  qed
qed

subsubsection {* The bijection *}

theorem "bij_betw to_real r_cantor cantor"
  by (rule bij_betw_imageI[OF to_real_inj to_real_surj])

subsection {* A space-filling curve *}

definition "homeomorphism f A B \<equiv> bij_betw f A B \<and> continuous_on A f \<and> continuous_on B (the_inv_into A f)"

abbreviation "from_real \<equiv> the_inv_into r_cantor to_real"
definition "fill_1 f i \<equiv> f (2 * i)"
definition "fill_2 f i \<equiv> f (2 * i + 1)"

definition combine :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat)"
  where "combine f g i = (if 2 dvd i then f (i div 2) else g ((i - 1) div 2))"

lemma combine_fill1_fill2:
  "combine (fill_1 f) (fill_2 f) = f"
proof
  fix i  :: nat
  show "combine (fill_1 f) (fill_2 f) i = f i"
  proof(cases "2 dvd i")
  case True
    hence "2 * (i div 2) = i" by (rule dvd_mult_div_cancel)
    thus ?thesis
    using True unfolding fill_1_def fill_2_def combine_def by simp
  next
  case False
    hence "2 * ((i - 1) div 2) + 1 = i" by arith
    thus ?thesis
    using False unfolding fill_1_def fill_2_def combine_def by simp
  qed
qed

lemma fill_1_combine: "fill_1 (combine x y) = x"
  by (auto simp add: fill_1_def combine_def)

lemma fill_2_combine: "fill_2 (combine x y) = y"
  by rule (auto simp add: fill_2_def combine_def, arith)

definition fill :: "real \<Rightarrow> real \<times> real" where
  "fill x \<equiv> (to_real (fill_1 (from_real x)), to_real (fill_2 (from_real x)))"

definition unfill :: "(real \<times> real) \<Rightarrow> real" where
  "unfill p \<equiv> to_real (combine (from_real (fst p)) (from_real (snd p)))"

lemma fill_1_r_cantor: "f \<in> r_cantor \<Longrightarrow> fill_1 f \<in> r_cantor"
    unfolding r_cantor_zero_or_two by (auto simp add: fill_1_def)
lemma fill_2_r_cantor: "f \<in> r_cantor \<Longrightarrow> fill_2 f \<in> r_cantor"
    unfolding r_cantor_zero_or_two by (auto simp add: fill_2_def)
lemma combine_r_cantor: "x \<in> r_cantor \<Longrightarrow> y \<in> r_cantor \<Longrightarrow> combine x y \<in> r_cantor"
    unfolding r_cantor_zero_or_two by (auto simp add: combine_def)

lemma unfill_fill:
  assumes "x \<in> cantor"
  shows "unfill (fill x) = x"
proof-
  from assms
  have "from_real x \<in> r_cantor"
    by (metis order_refl the_inv_into_into to_real_inj to_real_surj)
  from fill_1_r_cantor[OF this] fill_2_r_cantor[OF this]
  show ?thesis
    unfolding unfill_def fill_def
    by (simp add: the_inv_into_f_f[OF to_real_inj] combine_fill1_fill2
                  f_the_inv_into_f[OF to_real_inj] to_real_surj assms)
qed

lemma fill_unfill:
  assumes "x \<in> cantor" and "y \<in> cantor"
  shows "fill (unfill (x,y)) = (x,y)"
proof-
  from assms
  have "from_real x \<in> r_cantor" "from_real y \<in> r_cantor"
    by (metis order_refl the_inv_into_into to_real_inj to_real_surj)+
  from combine_r_cantor[OF this]
  show ?thesis
    unfolding unfill_def fill_def
    by (simp add: the_inv_into_f_f[OF to_real_inj] fill_1_combine fill_2_combine
                  f_the_inv_into_f[OF to_real_inj] to_real_surj assms)
qed

lemma fill_inj: "inj_on fill cantor"
  using unfill_fill by (metis inj_on_def)

theorem "homeomorphism fill cantor (cantor \<times> cantor)"
  apply (simp add:homeomorphism_def bij_betw_def fill_inj)
  oops

end


theory sse_operation_positive
  imports sse_boolean_algebra
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

section \<open>Positive semantic conditions for operations\<close>

text\<open>\noindent{We define and interrelate some useful conditions on propositional functions which do not involve
negative-like properties (hence 'positive'). We focus on propositional functions which correspond to unary
connectives of the algebra (with type @{text "\<sigma>\<Rightarrow>\<sigma>"}). We call such propositional functions 'operations'.}\<close>

subsection \<open>Definitions (finitary case)\<close>

text\<open>\noindent{Monotonicity (MONO).}\<close>
definition "MONO \<phi> \<equiv> \<forall>A B. A \<^bold>\<preceq> B \<longrightarrow> \<phi> A \<^bold>\<preceq> \<phi> B"
lemma MONO_ant: "MONO \<phi> \<Longrightarrow> \<forall>A B C. A \<^bold>\<preceq> B \<longrightarrow> \<phi>(B \<^bold>\<rightarrow> C) \<^bold>\<preceq> \<phi>(A \<^bold>\<rightarrow> C)" by (smt MONO_def conn)
lemma MONO_cons: "MONO \<phi> \<Longrightarrow> \<forall>A B C. A \<^bold>\<preceq> B \<longrightarrow> \<phi>(C \<^bold>\<rightarrow> A) \<^bold>\<preceq> \<phi>(C \<^bold>\<rightarrow> B)" by (smt MONO_def conn)
lemma MONO_dual: "MONO \<phi> \<Longrightarrow> MONO \<phi>\<^sup>d" by (smt MONO_def dual_def compl_def)

text\<open>\noindent{Extensive/expansive (EXP) and its dual (dEXP), aka. 'contractive'.}\<close>
definition "EXP \<phi>  \<equiv> \<forall>A. A \<^bold>\<preceq> \<phi> A"
definition "dEXP \<phi> \<equiv> \<forall>A. \<phi> A \<^bold>\<preceq> A"
lemma EXP_dual1: "EXP \<phi> \<Longrightarrow> dEXP \<phi>\<^sup>d" by (metis EXP_def dEXP_def dual_def compl_def)
lemma EXP_dual2: "dEXP \<phi> \<Longrightarrow> EXP \<phi>\<^sup>d" by (metis EXP_def dEXP_def dual_def compl_def)

text\<open>\noindent{Idempotence (IDEM).}\<close>
definition "IDEM \<phi>  \<equiv> \<forall>A. (\<phi> A) \<^bold>\<approx> \<phi>(\<phi> A)"
definition "IDEMa \<phi> \<equiv> \<forall>A. (\<phi> A) \<^bold>\<preceq> \<phi>(\<phi> A)"
definition "IDEMb \<phi> \<equiv> \<forall>A. (\<phi> A) \<^bold>\<succeq> \<phi>(\<phi> A)"
lemma IDEM_dual1: "IDEMa \<phi> \<Longrightarrow> IDEMb \<phi>\<^sup>d" unfolding dual_def IDEMa_def IDEMb_def compl_def by auto
lemma IDEM_dual2: "IDEMb \<phi> \<Longrightarrow> IDEMa \<phi>\<^sup>d" unfolding dual_def IDEMa_def IDEMb_def compl_def by auto
lemma IDEM_dual: "IDEM \<phi> = IDEM \<phi>\<^sup>d" by (metis IDEM_def IDEM_dual1 IDEM_dual2 IDEMa_def IDEMb_def dual_symm)

text\<open>\noindent{Normality (NOR) and its dual (dNOR).}\<close>
definition "NOR \<phi>  \<equiv> (\<phi> \<^bold>\<bottom>) \<^bold>\<approx> \<^bold>\<bottom>"
definition "dNOR \<phi> \<equiv> (\<phi> \<^bold>\<top>) \<^bold>\<approx> \<^bold>\<top>"
lemma NOR_dual1: "NOR \<phi> = dNOR \<phi>\<^sup>d" unfolding dual_def NOR_def dNOR_def top_def bottom_def compl_def by simp
lemma NOR_dual2: "dNOR \<phi> = NOR \<phi>\<^sup>d" unfolding dual_def NOR_def dNOR_def top_def bottom_def compl_def by simp

text\<open>\noindent{Distribution over meets or multiplicativity (MULT).}\<close>
definition "MULT \<phi>   \<equiv> \<forall>A B. \<phi>(A \<^bold>\<and> B) \<^bold>\<approx> (\<phi> A) \<^bold>\<and> (\<phi> B)"
definition "MULT_a \<phi> \<equiv> \<forall>A B. \<phi>(A \<^bold>\<and> B) \<^bold>\<preceq> (\<phi> A) \<^bold>\<and> (\<phi> B)"
definition "MULT_b \<phi> \<equiv> \<forall>A B. \<phi>(A \<^bold>\<and> B) \<^bold>\<succeq> (\<phi> A) \<^bold>\<and> (\<phi> B)"

text\<open>\noindent{Distribution over joins or additivity (ADDI).}\<close>
definition "ADDI \<phi>   \<equiv> \<forall>A B. \<phi>(A \<^bold>\<or> B) \<^bold>\<approx> (\<phi> A) \<^bold>\<or> (\<phi> B)"
definition "ADDI_a \<phi> \<equiv> \<forall>A B. \<phi>(A \<^bold>\<or> B) \<^bold>\<preceq> (\<phi> A) \<^bold>\<or> (\<phi> B)"
definition "ADDI_b \<phi> \<equiv> \<forall>A B. \<phi>(A \<^bold>\<or> B) \<^bold>\<succeq> (\<phi> A) \<^bold>\<or> (\<phi> B)"

subsection \<open>Relations among conditions (finitary case)\<close>

text\<open>\noindent{dEXP and dNOR entail NOR.}\<close>
lemma "dEXP \<phi> \<Longrightarrow> dNOR \<phi> \<Longrightarrow> NOR \<phi>" by (meson bottom_def dEXP_def NOR_def)

text\<open>\noindent{EXP and NOR entail dNOR.}\<close>
lemma "EXP \<phi> \<Longrightarrow> NOR \<phi> \<Longrightarrow> dNOR \<phi>" by (simp add: EXP_def dNOR_def top_def)

text\<open>\noindent{Interestingly, EXP and its dual allow for an alternative characterization of fixed-point operators.}\<close>
lemma EXP_fp:  "EXP  \<phi> \<Longrightarrow> \<phi>\<^sup>f\<^sup>p \<^bold>\<equiv> (\<phi>\<^sup>c \<^bold>\<squnion> id)" by (smt id_def EXP_def dual_def dual_symm equal_op_def conn)
lemma dEXP_fp: "dEXP \<phi> \<Longrightarrow> \<phi>\<^sup>f\<^sup>p \<^bold>\<equiv> (\<phi> \<^bold>\<squnion> compl)" by (smt dEXP_def equal_op_def conn)

text\<open>\noindent{MONO, MULT-a and ADDI-b are equivalent.}\<close>
lemma MONO_MULTa: "MONO \<phi> = MULT_a \<phi>" proof -
  have lr: "MONO \<phi> \<Longrightarrow> MULT_a \<phi>" by (smt MONO_def MULT_a_def meet_def)
  have rl: "MULT_a \<phi> \<Longrightarrow> MONO \<phi>" proof-
    assume multa: "MULT_a \<phi>"
    { fix A B
      { assume "A \<^bold>\<preceq> B"
        hence "A \<^bold>\<approx> A \<^bold>\<and> B" unfolding conn by blast
        hence "\<phi> A \<^bold>\<approx> \<phi>(A \<^bold>\<and> B)" unfolding conn by simp
        moreover from multa have "\<phi>(A \<^bold>\<and> B) \<^bold>\<preceq> (\<phi> A) \<^bold>\<and> (\<phi> B)" using MULT_a_def by metis
        ultimately have "\<phi> A \<^bold>\<preceq> (\<phi> A) \<^bold>\<and> (\<phi> B)" by blast
        hence "\<phi> A \<^bold>\<preceq> (\<phi> B)" unfolding conn by blast
      } hence "A \<^bold>\<preceq> B \<longrightarrow> \<phi> A \<^bold>\<preceq> \<phi> B" by (rule impI)
    } thus ?thesis by (simp add: MONO_def) qed
  from lr rl show ?thesis by auto
qed
lemma MONO_ADDIb: "MONO \<phi> = ADDI_b \<phi>" proof -
  have lr: "MONO \<phi> \<Longrightarrow> ADDI_b \<phi>" by (smt ADDI_b_def MONO_def join_def)
  have rl: "ADDI_b \<phi> \<Longrightarrow> MONO \<phi>" proof -
  assume addib: "ADDI_b \<phi>"
  { fix A B
    { assume "A \<^bold>\<preceq> B"
      hence "B \<^bold>\<approx> A \<^bold>\<or> B" unfolding conn by blast
      hence "\<phi> B \<^bold>\<approx> \<phi>(A \<^bold>\<or> B)" unfolding conn by simp
      moreover from addib have "(\<phi> A) \<^bold>\<or> (\<phi> B) \<^bold>\<preceq> \<phi>(A \<^bold>\<or> B)" using ADDI_b_def by metis
      ultimately have "(\<phi> A) \<^bold>\<or> (\<phi> B) \<^bold>\<preceq> \<phi> B" by blast
      hence "\<phi> A \<^bold>\<preceq> (\<phi> B)" unfolding conn by blast
    } hence "A \<^bold>\<preceq> B \<longrightarrow> \<phi> A \<^bold>\<preceq> \<phi> B" by (rule impI)
  } thus ?thesis by (simp add: MONO_def) qed
  from lr rl show ?thesis by auto
qed
lemma ADDIb_MULTa: "ADDI_b \<phi> = MULT_a \<phi>" using MONO_ADDIb MONO_MULTa by auto

end


(*
    Title:      Rank.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
    Maintainer: Jose Divasón <jose.divasonm at unirioja.es>
*)

header{*Rank of a matrix*}

theory Rank
imports
      "../Rank_Nullity_Theorem/Dim_Formula"
begin

subsection{*Row rank, column rank and rank*}

text{*Definitions of row rank, column rank and rank*}

definition row_rank :: "'a::{field}^'n^'m=>nat"
  where "row_rank A = vec.dim (row_space A)"

definition col_rank :: "'a::{field}^'n^'m=>nat"
  where "col_rank A = vec.dim (col_space A)"

definition rank :: "'a::{field}^'n^'m=>nat"
  where "rank A = row_rank A"

subsection{*Properties*}

lemma rrk_is_preserved:
fixes A::"'a::{field}^'cols^'rows::{finite, wellorder}"
  and P::"'a::{field}^'rows::{finite, wellorder}^'rows::{finite, wellorder}"
assumes inv_P: "invertible P"
shows "row_rank A = row_rank (P**A)"
by (metis row_space_is_preserved row_rank_def inv_P)

lemma crk_is_preserved:
fixes A::"'a::{field}^'cols::{finite, wellorder}^'rows"
  and P::"'a::{field}^'rows^'rows"
assumes inv_P: "invertible P"
shows "col_rank A = col_rank (P**A)"
  using rank_nullity_theorem_matrices unfolding ncols_def
  by (metis col_rank_def inv_P nat_add_left_cancel null_space_is_preserved)

end