theory Chapter7
imports "~~/src/HOL/IMP/Small_Step"
begin

text{*
\section*{Chapter 7}

\exercise
Define a function that computes the set of variables that are assigned to
in a command:
*}

fun assigned :: "com \<Rightarrow> vname set" where
"assigned SKIP = {}" |
"assigned (a ::= e) = {a}" |
"assigned (a;; b) = assigned a \<union> assigned b" |
"assigned (IF a THEN b ELSE c) = assigned b \<union> assigned c" |
"assigned (WHILE a DO b) = assigned b"

text{*
Prove that if some variable is not assigned to in a command,
then that variable is never modified by the command:
*}

lemma "\<lbrakk> (c, s) \<Rightarrow> t; x \<notin> assigned c \<rbrakk> \<Longrightarrow> s x = t x"
by (induction rule: big_step_induct) auto

text {*
\endexercise

\exercise
Define a recursive function that determines if a command behaves like @{const SKIP}
and prove its correctness:
*}

fun skip :: "com \<Rightarrow> bool" where
"skip SKIP = True" |
"skip (a ::= e) = False" |
"skip (a;; b) = (skip a \<and> skip b)" |
"skip (IF a THEN b ELSE c) = (skip b \<and> skip c)" |
(* I initially had skip (WHILE a DO b) = skip b, however consider the case where b = SKIP and
   a = Bc True. We would need to show that, \<forall>s t. (SKIP, s) \<Rightarrow> t \<longrightarrow> (WHILE a DO b, s) \<Rightarrow> t,
   however this is not the case since there exists no t that that command reduces to (as it doesn't
   terminate. Since the exercise wants the type signature to be com \<Rightarrow> bool, and I don't feel like
   handling only statically-false cases, I just define it to be false. *)
"skip (WHILE a DO b) = False"

lemma "skip c \<Longrightarrow> c \<sim> SKIP"
proof (induction c)
  case SKIP thus ?case by simp (* trivial *)
next
  case Assign thus ?case by simp (* contradiction *)
next
  case (Seq a b)
  hence "a \<sim> SKIP" and "b \<sim> SKIP" by auto
  moreover hence "(a;; b) \<sim> (SKIP;; SKIP)" by blast
  moreover hence "(SKIP;; SKIP) \<sim> SKIP" by auto
  ultimately show ?case by auto
next
  case (If a b c)
  hence "b \<sim> SKIP \<and> c \<sim> SKIP" by auto
  thus ?case by blast
next
  case While thus ?case by auto (* contradiction *)
qed

text{*
\endexercise

\exercise
Define a recursive function
*}

fun deskip :: "com \<Rightarrow> com" where
"deskip SKIP = SKIP" |
"deskip (a ::= b) = a ::= b" |
"deskip (a;; b) = (if deskip a = SKIP then deskip b else (if deskip b = SKIP then deskip a else deskip a;; deskip b))" |
"deskip (IF a THEN b ELSE c) = IF a THEN deskip b ELSE deskip c" |
"deskip (WHILE a DO b) = WHILE a DO deskip b"

text{*
that eliminates as many @{const SKIP}s as possible from a command. For example:
@{prop[display]"deskip (SKIP;; WHILE b DO (x::=a;; SKIP)) = WHILE b DO x::=a"}
Prove its correctness by induction on @{text c}: *}

lemma "deskip c \<sim> c"
proof (induction c)
  case SKIP show ?case by simp
next
  case Assign show ?case by simp
next
  case (Seq a b)
  hence "a;; b \<sim> deskip a;; deskip b" by auto
  moreover have "deskip (a;; b) \<sim> deskip a;; deskip b" by auto
  ultimately show ?case by auto
next
  case If thus ?case by auto
next
  case While
  thus ?case by (simp add: sim_while_cong)
qed

text{*
Remember lemma @{thm[source]sim_while_cong} for the @{text WHILE} case.
\endexercise

\exercise
A small-step semantics for the evaluation of arithmetic expressions
can be defined like this:
*}

inductive astep :: "aexp \<times> state \<Rightarrow> aexp \<Rightarrow> bool" (infix "\<leadsto>" 50) where
"(V x, s) \<leadsto> N (s x)" |
"(Plus (N i) (N j), s) \<leadsto> N (i + j)" |
"(a, s) \<leadsto> a' \<Longrightarrow> (Plus a b, s) \<leadsto> Plus a' b" |
"(b, s) \<leadsto> b' \<Longrightarrow> (Plus (N i) b, s) \<leadsto> Plus (N i) b'"

(* your definition/proof here *)

text{*
Complete the definition with two rules for @{const Plus}
that model a left-to-right evaluation strategy:
reduce the first argument with @{text"\<leadsto>"} if possible,
reduce the second argument with @{text"\<leadsto>"} if the first argument is a number.
Prove that each @{text"\<leadsto>"} step preserves the value of the expression:
*}

lemma "(a, s) \<leadsto> a' \<Longrightarrow> aval a s = aval a' s"
proof (induction rule: astep.induct [split_format (complete)])

fix x s
show "aval (V x) s = aval (N (s x)) s" by auto

fix i j s
show "aval (Plus (N i) (N j)) s = aval (N (i + j)) s" by auto

fix a s a' b
assume 0: "aval a s = aval a' s"
from 0 show "aval (Plus a b) s = aval (Plus a' b) s" by auto

fix b s b' i
assume 0: "aval b s = aval b' s"
from 0 show "aval (Plus (N i) b) s = aval (Plus (N i) b') s" by auto

qed

(* ok, I lied, I love case. some of those hairier proofs would have been pretty impossible to
   read without it. writing out certain steps explicitly can make the structure of the proof
   clear while still leaving the meat to the automation. *)

text{*
Do not use the \isacom{case} idiom but write down explicitly what you assume
and show in each case: \isacom{fix} \dots \isacom{assume} \dots \isacom{show} \dots.
\endexercise

\exercise
Prove or disprove (by giving a counterexample):
*}

lemma "IF And b\<^sub>1 b\<^sub>2 THEN c\<^sub>1 ELSE c\<^sub>2 \<sim>
          IF b\<^sub>1 THEN IF b\<^sub>2 THEN c\<^sub>1 ELSE c\<^sub>2 ELSE c\<^sub>2" (is "?Small \<sim> ?Big")
proof -

  {fix s t
  have lower: "bval (And b\<^sub>1 b\<^sub>2) s = (if bval b\<^sub>1 s then bval b\<^sub>2 s else False)" by auto
  {
    assume ltr: "(?Small, s) \<Rightarrow> t" (is "?P")
    {
      assume b1: "bval b\<^sub>1 s"
      assume b2: "bval b\<^sub>2 s"
      from b1 b2 ltr have fst: "(c\<^sub>1, s) \<Rightarrow> t" by auto
    }
    note fst = this

    {
      assume b1: "bval b\<^sub>1 s"
      assume b3: "\<not>bval b\<^sub>2 s"
      from b1 b3 ltr have snd: "(c\<^sub>2, s) \<Rightarrow> t" by auto
    }
    note snd = this

    {
      assume b4: "\<not>bval b\<^sub>1 s"
      from b4 ltr have thd: "(c\<^sub>2, s) \<Rightarrow> t" by auto
    }
    note thd = this

    from fst snd thd lower have "(?Big, s) \<Rightarrow> t" by auto
  }
  note ltr = this

  {
  assume rtl: "(?Big, s) \<Rightarrow> t" (is "?P")

    {
      assume b1: "bval b\<^sub>1 s"
      assume b2: "bval b\<^sub>2 s"
      from b1 b2 rtl have fst: "(c\<^sub>1, s) \<Rightarrow> t" by auto
    }
    note fst = this

    {
      assume b1: "bval b\<^sub>1 s"
      assume b3: "\<not>bval b\<^sub>2 s"
      from b1 b3 rtl have snd: "(c\<^sub>2, s) \<Rightarrow> t" by auto
    }
    note snd = this

    {
      assume b4: "\<not>bval b\<^sub>1 s"
      from b4 rtl have thd: "(c\<^sub>2, s) \<Rightarrow> t" by auto
    }
    note thd = this

    from fst snd thd lower have "(?Big, s) \<Rightarrow> t" by auto
  }
  note rtl = this

  from ltr rtl have "(?Small, s) \<Rightarrow> t = (?Big, s) \<Rightarrow> t" by auto
  }
  from this show ?thesis by auto
qed

(* ... Wow that is ugly. I'm not sure how to improve it, though. I tried using "moreover have"
  unsuccessfully. A next/case shorthand for this sort of thing would be nice. I think part of the
  problem is that it's phrased in terms of = of booleans, which here I decompose into
  P \<longrightarrow> Q \<and> Q \<longrightarrow> P \<Longrightarrow> P = Q (some of that reasoning is hidden behind auto). Alas,
  sledgehammer finds a metis proof quite quickly. I was hoping writing out the structured proof
  would provide some deeper insight into Isar, but I ended up using really low-level things. *)

(* note: needed to explicitly add quantifiers, since the free variables didn't seem to want to
   unify with the concrete counterexample *)
lemma "\<not> (\<forall>b\<^sub>1 b\<^sub>2 c. WHILE And b\<^sub>1 b\<^sub>2 DO c \<sim> WHILE b\<^sub>1 DO WHILE b\<^sub>2 DO c)" (is "\<not> ?P")
proof
  assume are_sim: ?P
  (* concrete counterexample: the first program terminates while the second does not.
     if we assume the second *does* terminate because the first does, we can show by rule
     induction that this is a contradiction (no rule can derive that (second, s) \<Rightarrow> t) *)
  have conc: "WHILE And (Bc True) (Bc False) DO SKIP \<sim> WHILE (Bc True) DO WHILE (Bc False) DO SKIP"
    using are_sim by simp
  have is_skip: "(WHILE And (Bc True) (Bc False) DO SKIP, s) \<Rightarrow> s" by auto
  hence "(WHILE (Bc True) DO WHILE (Bc False) DO SKIP, s) \<Rightarrow> s" using conc by simp
  thus False
  by (induction "(WHILE (Bc True) DO WHILE (Bc False) DO SKIP)" s s rule: big_step_induct, simp)
qed

definition Or :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"Or b\<^sub>1 b\<^sub>2 = Not (And (Not b\<^sub>1) (Not b\<^sub>2))"

lemma
while_terminates_then_cond_false:
assumes a: "(WHILE b DO c, s) \<Rightarrow> t" (is "(?C, s) \<Rightarrow> t")
shows "\<not> bval b t"
proof -
  (* it seems using "assumes" statements instead of explicit P \<Longrightarrow> Q makes you need to
     name it explicitly if you want to use it. It doesn't become a "this" at the start of the proof
  *)
  from a show ?thesis by (induction ?C s t rule: big_step_induct, auto)
qed

lemma "WHILE Or b\<^sub>1 b\<^sub>2 DO c \<sim>
          WHILE Or b\<^sub>1 b\<^sub>2 DO c;; WHILE b\<^sub>1 DO c" (is "?P \<sim> ?P;; ?Q")
proof -
  have ltr: "\<forall>s t. (?P, s) \<Rightarrow> t \<longrightarrow> (?P;; ?Q, s) \<Rightarrow> t"
  proof -
      {fix s t
      assume terminates: "(?P, s) \<Rightarrow> t"
      hence "\<not> bval (Or b\<^sub>1 b\<^sub>2) t" using while_terminates_then_cond_false by auto
      hence "(?Q, t) \<Rightarrow> t" by (auto simp add: Or_def)
      from this have "(?P;; ?Q, s) \<Rightarrow> t" using terminates by auto
      } thus ?thesis by auto
  qed

  have rtl: "\<forall>s t. (?P;; ?Q, s) \<Rightarrow> t \<longrightarrow> (?P, s) \<Rightarrow> t"
  proof -
    {fix s t
    assume terminates: "(?P;; ?Q, s) \<Rightarrow> t"
    then obtain t1 where seq1: "(?P, s) \<Rightarrow> t1" and seq2: "(?Q, t1) \<Rightarrow> t" by auto
    hence "\<not> bval (Or b\<^sub>1 b\<^sub>2) t1" using while_terminates_then_cond_false terminates by auto
    hence nb1: "\<not> bval b\<^sub>1 t1" by (auto simp add: Or_def)
    hence "t1 = t" using seq2 by auto
    hence "(?P, s) \<Rightarrow> t" using terminates seq1 seq2 nb1 by auto
    } thus ?thesis by auto
  qed

  show ?thesis using ltr rtl by blast
qed

text{*
\endexercise

\exercise
Define a new loop construct @{text "DO c WHILE b"} (where @{text c} is
executed once before @{text b} is tested) in terms of the
existing constructs in @{typ com}:
*}

definition Do :: "com \<Rightarrow> bexp \<Rightarrow> com" ("DO _ WHILE _"  [0, 61] 61) where
"DO c WHILE b = c ;; WHILE b DO c"

text{*
Define a translation on commands that replaces all @{term "WHILE b DO c"}
by suitable commands that use @{term "DO c WHILE b"} instead:
*}

fun dewhile :: "com \<Rightarrow> com" where
"dewhile SKIP = SKIP" |
"dewhile (a ::= b) = a ::= b" |
"dewhile (a;; b) = dewhile a;; dewhile b" |
"dewhile (IF a THEN b ELSE c) = IF a THEN dewhile b ELSE dewhile c" |
"dewhile (WHILE a DO b) = IF Not a THEN SKIP ELSE (DO dewhile b WHILE a)"

text{* Prove that your translation preserves the semantics: *}

lemma "dewhile c \<sim> c"
proof (induction c)
  case SKIP thus ?case by simp
  next case Assign thus ?case by simp
  next case Seq thus ?case by auto
  next case If thus ?case by auto
  next
    case (While b c)
    hence "WHILE b DO c \<sim> WHILE b DO dewhile c" using sim_while_cong by simp
    thus ?case using Do_def while_unfold by auto
qed

text{*
\endexercise

\exercise
Let @{text "C :: nat \<Rightarrow> com"} be an infinite sequence of commands and
@{text "S :: nat \<Rightarrow> state"} an infinite sequence of states such that
@{prop"C(0::nat) = c;;d"} and \mbox{@{prop"\<forall>n. (C n, S n) \<rightarrow> (C(Suc n), S(Suc n))"}}.
Then either all @{text"C n"} are of the form \mbox{@{term"c\<^sub>n;;d"}}
and it is always @{text c\<^sub>n} that is reduced or @{text c\<^sub>n} eventually becomes @{const SKIP}.
Prove
*}

lemma assumes "C 0 = c;;d" and "\<forall>n. (C n, S n) \<rightarrow> (C(Suc n), S(Suc n))"
shows "(\<forall>n. \<exists>c\<^sub>1 c\<^sub>2. C n = c\<^sub>1;;d \<and> C(Suc n) = c\<^sub>2;;d \<and> (c\<^sub>1, S n) \<rightarrow> (c\<^sub>2, S(Suc n)))
     \<or> (\<exists>k. C k = SKIP;;d)" (is "(\<forall>i. ?P i) \<or> ?Q")
proof cases
  assume ?Q
  thus ?thesis by simp
next
  assume not: "\<not>?Q"
  {fix i
  have "\<exists>c1 c2. C i = c1;; d \<and> C (Suc i) = c2;; d \<and> (c1, S i) \<rightarrow> (c2, S (Suc i))"
  proof (induction i)
    case 0
    have "C 1 \<noteq> SKIP;; d" using not by simp
    thus ?case using assms by (metis Small_Step.SeqE not prod.sel(1) prod.sel(2))
  next
    case (Suc n)
    (* Relatively straightforward - use the induction hypothesis to chain forward another step
       from original c1 and c2, show that this c3 has the necessary properties. Since c2 \<rightarrow> SKIP
       is not possible, there will always be something in front of the ;; that prevents the ;; from
       reducing away. *)
    then obtain c1 c2 where "C n = c1;; d \<and> C (Suc n) = c2;; d \<and> (c1, S n) \<rightarrow> (c2, S (Suc n))" by auto
    moreover have "C (Suc (Suc n)) \<noteq> SKIP;; d" using not by simp
    moreover obtain c3 where "C (Suc (Suc n)) = c3;; d" using not calculation by (metis Pair_inject Small_Step.SeqE assms(2))
    moreover have "(C (Suc n), S (Suc n)) \<rightarrow> (C (Suc (Suc n)), S (Suc (Suc n)))" using assms by auto
    moreover have "C (Suc n) = c2;; d \<and> C (Suc (Suc n)) = c3 ;; d \<and> (c2, S (Suc n)) \<rightarrow> (c3, S (Suc (Suc n)))" using calculation not by auto
    ultimately show ?case using not by auto
  qed
  }
  thus ?thesis by auto
qed

(* your definition/proof here *)

text{*
\endexercise
\bigskip

For the following exercises copy theories
@{theory Com}, @{theory Big_Step} and @{theory Small_Step}
and modify them as required. Those parts of the theories
that do not contribute to the results required in the exercise can be discarded.
If there are multiple proofs of the same result, you may update any one of them.

\begin{exercise}\label{exe:IMP:REPEAT}
Extend IMP with a @{text "REPEAT c UNTIL b"} command by adding the constructor
\begin{alltt}
  Repeat com bexp   ("(REPEAT _/ UNTIL _)"  [0, 61] 61)
\end{alltt}
to datatype @{typ com}.
Adjust the definitions of big-step and small-step semantics,
the proof that the big-step semantics is deterministic and
the equivalence proof between the two semantics.
\end{exercise}

\begin{exercise}\label{exe:IMP:OR}
Extend IMP with a new command @{text "c\<^sub>1 OR c\<^sub>2"} that is a
nondeterministic choice: it may execute either @{text
"c\<^sub>1"} or @{text "c\<^sub>2"}. Add the constructor
\begin{alltt}
  Or com com   ("_ OR/ _" [60, 61] 60)
\end{alltt}
to datatype @{typ com}. Adjust the definitions of big-step
and small-step semantics, prove @{text"(c\<^sub>1 OR c\<^sub>2) \<sim> (c\<^sub>2 OR c\<^sub>1)"}
and update the equivalence proof between the two semantics.
\end{exercise}

\begin{exercise}
Extend IMP with exceptions. Add two constructors @{text THROW} and
@{text "TRY c\<^sub>1 CATCH c\<^sub>2"} to datatype @{typ com}:
\begin{alltt}
  THROW  |  Try com com   ("(TRY _/ CATCH _)"  [0, 61] 61)
\end{alltt}
Command @{text THROW} throws an exception. The only command that can
catch an execption is @{text "TRY c\<^sub>1 CATCH c\<^sub>2"}: if an execption
is thrown by @{text c\<^sub>1}, execution continues with @{text c\<^sub>2},
otherwise @{text c\<^sub>2} is ignored.
Adjust the definitions of big-step and small-step semantics as follows.

The big-step semantics is now of type @{typ "com \<times> state \<Rightarrow> com \<times> state"}.
In a big step @{text "(c,s) \<Rightarrow> (x,t)"}, @{text x} can only be @{term SKIP}
(signalling normal termination) or @{text THROW} (signalling that an exception
was thrown but not caught).

The small-step semantics is of the same type as before. There are two final
configurations now, @{term "(SKIP, t)"} and @{term "(THROW, t)"}.
Exceptions propagate upwards until an enclosing handler is found.
That is, until a configuration @{text "(TRY THROW CATCH c, s)"}
is reached and @{text THROW} can be caught.

Adjust the equivalence proof between the two semantics such that you obtain
@{text "cs \<Rightarrow> (SKIP,t)  \<longleftrightarrow>  cs \<rightarrow>* (SKIP,t)"}
and @{text "cs \<Rightarrow> (THROW,t)  \<longleftrightarrow>  cs \<rightarrow>* (THROW,t)"}.
Also revise the proof of
\noquotes{@{prop [source] "(\<exists>cs'. cs \<Rightarrow> cs')  \<longleftrightarrow>  (\<exists>cs'. cs \<rightarrow>* cs' \<and> final cs')"}}.
\end{exercise}
*}

end


theory ConcreteSemantics11_Denotational
  imports Main "~~/src/HOL/IMP/Big_Step"
begin

section "Denotational Semantics of Commands"

type_synonym com_den = "(state \<times> state) set"

definition W :: "(state \<Rightarrow> bool) \<Rightarrow> com_den \<Rightarrow> (com_den \<Rightarrow> com_den)" where
"W db dc = (\<lambda>dw. {(s,t). if db s then (s, t) \<in> dc O dw else s = t})"

fun D :: "com \<Rightarrow> com_den" where
"D SKIP   = Id" |
"D (x ::= a) = {(s,t). t = s(x := aval a s)}" |
"D (c1;;c2)  = D(c1) O D(c2)" |
"D (IF b THEN c1 ELSE c2)
 = {(s,t). if bval b s then (s,t) \<in> D c1 else (s,t) \<in> D c2}" |
"D (WHILE b DO c) = lfp (W (bval b) (D c))"

lemma W_mono: "mono (W b r)"
  apply(unfold mono_def W_def)
  apply(auto)
  done

lemma D_While_If:
  "D(WHILE b DO c) = D(IF b THEN c;;WHILE b DO c ELSE SKIP)"
proof -
  let ?w = "WHILE b DO c"
  let ?f = "W (bval b) (D c)"
  have "D ?w = lfp ?f"
    by simp
  also have "... = ?f (lfp ?f)"
    by (simp add: W_mono def_lfp_unfold)
(*  also have "... = ?f (D ?w)"
    by simp*)
  also have "... = D(IF b THEN c;;WHILE b DO c ELSE SKIP)"
    using W_def by auto
  then show ?thesis
    using calculation by auto
    (*using \<open>lfp (W (bval b) (D c)) = W (bval b) (D c) (lfp (W (bval b) (D c)))\<close> by auto*)
qed

text\<open>Equivalence of denotational and big-step semantics:\<close>

(*Lemma 11.4.*)
lemma D_if_big_step:  "(c,s) \<Rightarrow> t \<Longrightarrow> (s,t) \<in> D(c)"
proof(induction rule: big_step_induct)
case (Skip s)
  then show ?case
    by simp
next
  case (Assign x a s)
  then show ?case
    by auto
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  then show ?case
    by auto
next
  case (IfTrue b s c\<^sub>1 t c\<^sub>2)
  then show ?case
    by simp
next
  case (IfFalse b s c\<^sub>2 t c\<^sub>1)
  then show ?case
    by simp
next
  case (WhileFalse b s c)
  then show ?case
    using D_While_If by auto
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  then show ?case
  proof -
    have "(s\<^sub>1, s\<^sub>3) \<in> D (c;; WHILE b DO c)"
      using D.simps(3) WhileTrue.IH(1) WhileTrue.IH(2) by blast
    then show ?thesis
      using D_While_If WhileTrue.hyps(1) by force
  qed
qed

abbreviation Big_step :: "com \<Rightarrow> com_den" where
"Big_step c \<equiv> {(s,t). (c,s) \<Rightarrow> t}"

(*Lemma 11.5.*)
lemma Big_step_if_D:  "(s,t) \<in> D(c) \<Longrightarrow> (s,t) \<in> Big_step c"
proof(induction c arbitrary: s t)
case SKIP
  then show ?case
    by auto
next
  case (Assign x1 x2)
  then show ?case by fastforce
next
  case (Seq c1 c2)
  then show ?case by fastforce
next
  case (If x1 c1 c2)
  then show ?case by (auto split: if_splits)
next
  case (While b c)
  let ?B = "Big_step (WHILE b DO c)"
  let ?f = "W (bval b) (D c)"
  have "?f ?B \<subseteq> ?B" using While.IH by (auto simp: W_def)
  then show ?case
    using D.simps(5) While.prems lfp_lowerbound by blast
qed

(*Theorem 11.6 (Equivalence of denotational and big-step semantics).*)
theorem denotational_is_big_step: "(s, t) \<in> D c = (c, s) \<Rightarrow> t"
  using Big_step_if_D D_if_big_step by blast

(*Corollary 11.7.*)
corollary equiv_c_iff_equal_D: "(c1 \<sim> c2) \<longleftrightarrow> D c1 = D c2"
  apply(simp add: denotational_is_big_step[symmetric])
  apply(simp add: set_eq_iff)
  done

subsection "Continuity"

definition chain :: "(nat \<Rightarrow> 'a set) \<Rightarrow> bool" where
"chain S = (\<forall>i. S i \<subseteq> S(Suc i))"

(*Lemma 11.10.*)
lemma chain_total: "chain S \<Longrightarrow> S i \<le> S j \<or> S j \<le> S i"
  by (meson ConcreteSemantics11_Denotational.chain_def le_cases lift_Suc_mono_le)

definition cont:: "('a set \<Rightarrow> 'b set) \<Rightarrow> bool" where
"cont f = (\<forall> S. chain S \<longrightarrow> f (\<Union> n. S n) = (\<Union> n. f (S n)))"

(*Lemma 11.11.*)
lemma mono_if_cont: fixes f :: "'a set \<Rightarrow> 'b set"
  assumes "cont f" shows "mono f"
proof
  fix a b :: "'a set" assume "a \<subseteq> b"
  let ?S = "\<lambda>i::nat. if i = 0 then a else b"
  have "chain ?S" using \<open>a \<subseteq> b\<close>
    by (simp add: ConcreteSemantics11_Denotational.chain_def)
  then have "f (\<Union>n. ?S n) = (\<Union>n. f(?S n))"
    by (metis assms cont_def)
  moreover have "(\<Union>n. ?S n) = b" using \<open>a \<subseteq> b\<close> by auto
  moreover have "(\<Union>n. f(?S n)) = f a \<union> f b" by (auto split: if_splits)
  ultimately show "f a \<subseteq> f b"
    by (simp add: subset_Un_eq)
qed

lemma chain_iterates: fixes f :: "'a set \<Rightarrow> 'a set"
  assumes "mono f" shows "chain(\<lambda>n. (f^^n) {})"
proof-
  have "(f ^^ n ) {} \<subseteq> (f ^^ (Suc n)) {} " for n
    using assms funpow_decreasing le_SucI by blast
  thus ?thesis
    by (simp add: ConcreteSemantics11_Denotational.chain_def)
qed

(*Theorem 11.12 (Kleene fixpoint theorem).*)
theorem lfp_if_cont:
  assumes "cont f" shows "lfp f = (UN n. (f^^n) {})" (is "_ = ?U")
proof
(*
 1. lfp f \<subseteq> (\<Union>n. (f ^^ n) {})
 2. (\<Union>n. (f ^^ n) {}) \<subseteq> lfp f
*)
  have "mono f"
    by (simp add: assms mono_if_cont)
  then have mono: "(f ^^ n) {} \<subseteq> (f ^^ Suc n) {}" for n
    using funpow_decreasing order.strict_implies_order by blast
  show "lfp f \<subseteq> ?U"
  proof (rule lfp_lowerbound)
    have "f ?U = (\<Union>n. (f ^^ (Suc n)) {})"
      using chain_iterates[OF mono_if_cont[OF assms]] assms
      by(simp add: cont_def)
    also have "\<dots> = (f ^^ 0) {} \<union> (\<Union>n. (f ^^ (Suc n)) {})"
      by simp
    also have "\<dots> = ?U" using mono by auto (metis funpow_simps_right(2) funpow_swap1 o_apply)
    finally show "f ?U \<subseteq> ?U"
      by simp
  qed
next
  have "(f^^n){} \<subseteq> p" if "f p \<subseteq> p" for n p
(*  have "(f ^^ n) {} \<subseteq> lfp f" for n *)
(*    using Kleene_iter_lpfp assms lfp_unfold mono_if_cont by blast*)
(*Q: is it good to use Kleene_iter_lpfp ? \<rightarrow> Not good.*)
  proof (induction n)
    case 0
    then show ?case
      by simp
  next
    case (Suc n)
    from monoD[OF mono_if_cont[OF assms] Suc] \<open>f p \<subseteq> p\<close>
    show ?case
      by auto
(*    using Kleene_iter_lpfp assms mono_if_cont that by blast*)
(*    by (meson Kleene_iter_lpfp assms lfp_greatest mono_if_cont)*)
qed
  then show "?U \<subseteq> lfp f"  by(auto simp: lfp_def)
(*    by (simp add: UN_least \<open>\<And>n. (f ^^ n) {} \<subseteq> lfp f\<close>)*)
qed

(*Lemma 11.13.*)
lemma cont_W: "cont(W b r)"
  apply(simp add: cont_def)
  apply(simp add: W_def)
  apply(auto)
  done

subsection\<open>The denotational semantics is deterministic\<close>

lemma single_valued_UN_chain:
  assumes "chain S" "(\<And>n. single_valued (S n))"
  shows "single_valued(UN n. S n)"
proof(auto simp: single_valued_def)
(*  \<And>x y xa z xb. (x, y) \<in> S xa \<Longrightarrow> (x, z) \<in> S xb \<Longrightarrow> y = z *)
  fix m n x y z  assume "(x, y) \<in> S m " "(x, z) \<in> S n"
  show "y = z"
    by (meson \<open>(x, y) \<in> S m\<close> \<open>(x, z) \<in> S n\<close> assms(1) assms(2) chain_total single_valuedD subsetD)
(*    by (meson \<open>(x, y) \<in> S m\<close> \<open>(x, z) \<in> S n\<close> assms(1) assms(2) chain_total single_valued_def subset_iff)*)
(* There also exists an proof using `chain_total`*)
qed

(*Lemma 11.15.*)
lemma single_valued_lfp: fixes f :: "com_den \<Rightarrow> com_den"
assumes "cont f" "\<And>r. single_valued r \<Longrightarrow> single_valued (f r)"
shows "single_valued(lfp f)"
  unfolding lfp_if_cont[OF assms(1)]
proof(rule single_valued_UN_chain)
  from chain_iterates[OF mono_if_cont]
  show "chain (\<lambda>n. (f ^^ n) {})"
    by (simp add: \<open>\<And>f. cont f \<Longrightarrow> chain (\<lambda>n. (f ^^ n) {})\<close> assms(1))
next
  fix n show " single_valued ((f ^^ n) {})"
  proof(induction n)
    case 0
    then show ?case
      by simp
  next
    case (Suc n)
    then show ?case by (auto simp: assms(2) )
  qed
qed
(*
 1. \<forall>x y. (\<exists>xa. (x, y) \<in> (f ^^ xa) {}) \<longrightarrow> (\<forall>z. (\<exists>xa. (x, z) \<in> (f ^^ xa) {}) \<longrightarrow> y = z)
*)
  (*
apply(simp add: single_valued_def)
apply(simp add: lfp_def)
  sledgehammer*)

(*Lemma 11.16.*)
lemma single_valued_D: "single_valued (D c)"
proof(induction c)
  case SKIP
  then show ?case
    by simp
next
  case (Assign x1 x2)
  then show ?case by (auto simp: single_valued_def)
next
  case (Seq c1 c2)
  then show ?case
    by (simp add: single_valued_relcomp)
next
  case (If x1 c1 c2)
  then show ?case by (auto simp: single_valued_def)
next
  case (While x1 c)
(*\<And>x1 c. single_valued (D c) \<Longrightarrow> single_valued (D (WHILE x1 DO c))*)
  let ?f = "W (bval x1) (D c)"
  have "single_valued (lfp ?f)"
  proof (rule single_valued_lfp[OF cont_W])
(*
 1. cont (W (bval x1) (D c))
 2. \<And>r. single_valued r \<Longrightarrow> single_valued (W (bval x1) (D c) r)
*)
    fix r show "single_valued r \<Longrightarrow> single_valued (W (bval x1) (D c) r)" using While.IH
       by(force simp: single_valued_def W_def)
  qed
  then show ?case
    by simp
(*    by (meson big_step_determ denotational_is_big_step single_valuedI)*)
qed

end


(* Title:      (More) Relation Algebra
   Author:     Walter Guttmann, Peter Hoefner
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
               Peter Hoefner <peter at hoefner-online.de>
*)

section \<open>(More) Relation Algebra\<close>

text \<open>
This theory presents fundamental properties of relation algebras, which are not present in the AFP entry on relation algebras but could be integrated there \cite{ArmstrongFosterStruthWeber2014}.
Many theorems concern vectors and points.
\<close>

theory More_Relation_Algebra

imports Relation_Algebra.Relation_Algebra_RTC Relation_Algebra.Relation_Algebra_Functions

begin

no_notation
  trancl ("(_\<^sup>+)" [1000] 999)

context relation_algebra
begin

notation
  converse ("(_\<^sup>T)" [102] 101)

abbreviation bijective
  where "bijective x \<equiv> is_inj x \<and> is_sur x"

abbreviation reflexive
  where "reflexive R \<equiv> 1' \<le> R"

abbreviation symmetric
  where "symmetric R \<equiv> R = R\<^sup>T"

abbreviation transitive
  where "transitive R \<equiv> R;R \<le> R"

text \<open>General theorems\<close>

lemma x_leq_triple_x:
  "x \<le> x;x\<^sup>T;x"
proof -
  have "x = x;1' \<cdot> 1"
    by simp
  also have "... \<le> (x \<cdot> 1;1'\<^sup>T);(1' \<cdot> x\<^sup>T;1)"
    by (rule dedekind)
  also have "... = x;(x\<^sup>T;1 \<cdot> 1')"
    by (simp add: inf.commute)
  also have "... \<le> x;(x\<^sup>T \<cdot> 1';1\<^sup>T);(1 \<cdot> (x\<^sup>T)\<^sup>T;1')"
    by (metis comp_assoc dedekind mult_isol)
  also have "... \<le> x;x\<^sup>T;x"
    by simp
  finally show ?thesis .
qed

lemma inj_triple:
  assumes "is_inj x"
    shows "x = x;x\<^sup>T;x"
by (metis assms order.eq_iff inf_absorb2 is_inj_def mult_1_left mult_subdistr x_leq_triple_x)

lemma p_fun_triple:
  assumes "is_p_fun x"
    shows "x = x;x\<^sup>T;x"
by (metis assms comp_assoc order.eq_iff is_p_fun_def mult_isol mult_oner x_leq_triple_x)

lemma loop_backward_forward:
  "x\<^sup>T \<le> -(1') + x"
by (metis conv_e conv_times inf.cobounded2 test_dom test_domain test_eq_conv galois_2 inf.commute
           sup.commute)

lemma inj_sur_semi_swap:
  assumes "is_sur z"
      and "is_inj x"
    shows "z \<le> y;x \<Longrightarrow> x \<le> y\<^sup>T;z"
proof -
  assume "z \<le> y;x"
  hence "z;x\<^sup>T \<le> y;(x;x\<^sup>T)"
    by (metis mult_isor mult_assoc)
  hence "z;x\<^sup>T \<le> y"
    using \<open>is_inj x\<close> unfolding is_inj_def
    by (metis mult_isol order.trans mult_1_right)
  hence "(z\<^sup>T;z);x\<^sup>T \<le> z\<^sup>T;y"
    by (metis mult_isol mult_assoc)
  hence "x\<^sup>T \<le> z\<^sup>T;y"
    using \<open>is_sur z\<close> unfolding is_sur_def
    by (metis mult_isor order.trans mult_1_left)
  thus ?thesis
    using conv_iso by fastforce
qed

lemma inj_sur_semi_swap_short:
  assumes "is_sur z"
      and "is_inj x"
    shows "z \<le> y\<^sup>T;x \<Longrightarrow> x \<le> y;z"
proof -
  assume as: "z \<le> y\<^sup>T;x"
  hence "z;x\<^sup>T \<le> y\<^sup>T"
    using \<open>z \<le> y\<^sup>T;x\<close> \<open>is_inj x\<close> unfolding is_inj_def
    by (metis assms(2) conv_invol inf.orderI inf_absorb1 inj_p_fun ss_422iii)
  hence "x\<^sup>T \<le> z\<^sup>T;y\<^sup>T"
    using \<open>is_sur z\<close> unfolding is_sur_def
    by (metis as assms inj_sur_semi_swap conv_contrav conv_invol conv_iso)
  thus "x \<le> y;z"
    using conv_iso by fastforce
qed

lemma bij_swap:
  assumes "bijective z"
      and "bijective x"
    shows "z \<le> y\<^sup>T;x \<longleftrightarrow> x \<le> y;z"
by (metis assms inj_sur_semi_swap conv_invol)

text \<open>The following result is \cite[Proposition 4.2.2(iv)]{SchmidtStroehlein1993}.\<close>

text \<open>The following results are variants of \cite[Proposition 4.2.3]{SchmidtStroehlein1993}.\<close>

lemma ss423conv:
  assumes "bijective x"
    shows "x ; y \<le> z \<longleftrightarrow> y \<le> x\<^sup>T ; z"
by (metis assms conv_contrav conv_iso inj_p_fun is_map_def ss423 sur_total)

lemma ss423bij:
  assumes "bijective x"
    shows "y ; x\<^sup>T \<le> z \<longleftrightarrow> y \<le> z ; x"
by (simp add: assms is_map_def p_fun_inj ss423 total_sur)

lemma inj_distr:
  assumes "is_inj z"
    shows "(x\<cdot>y);z = (x;z)\<cdot>(y;z)"
apply (rule order.antisym)
 using mult_subdistr_var apply blast
using assms conv_iso inj_p_fun p_fun_distl by fastforce

lemma test_converse:
  "x \<cdot> 1' = x\<^sup>T \<cdot> 1'"
by (metis conv_e conv_times inf_le2 is_test_def test_eq_conv)

lemma injective_down_closed:
  assumes "is_inj x"
      and "y \<le> x"
    shows "is_inj y"
by (meson assms conv_iso dual_order.trans is_inj_def mult_isol_var)

lemma injective_sup:
  assumes "is_inj t"
      and "e;t\<^sup>T \<le> 1'"
      and "is_inj e"
    shows "is_inj (t + e)"
proof -
  have 1: "t;e\<^sup>T \<le> 1'"
    using assms(2) conv_contrav conv_e conv_invol conv_iso by fastforce
  have "(t + e);(t + e)\<^sup>T = t;t\<^sup>T + t;e\<^sup>T + e;t\<^sup>T + e;e\<^sup>T"
    by (metis conv_add distrib_left distrib_right' sup_assoc)
  also have "... \<le> 1'"
    using 1 assms by (simp add: is_inj_def le_supI)
  finally show ?thesis
    unfolding is_inj_def .
qed

text \<open>Some (more) results about vectors\<close>

lemma vector_meet_comp:
  assumes "is_vector v"
      and "is_vector w"
    shows "v;w\<^sup>T = v\<cdot>w\<^sup>T"
by (metis assms conv_contrav conv_one inf_top_right is_vector_def vector_1)

lemma vector_meet_comp':
  assumes "is_vector v"
    shows "v;v\<^sup>T = v\<cdot>v\<^sup>T"
using assms vector_meet_comp by blast

lemma vector_meet_comp_x:
  "x;1;x\<^sup>T = x;1\<cdot>1;x\<^sup>T"
by (metis comp_assoc inf_top.right_neutral is_vector_def one_idem_mult vector_1)

lemma vector_meet_comp_x':
  "x;1;x = x;1\<cdot>1;x"
by (metis inf_commute inf_top.right_neutral ra_1)

lemma vector_prop1:
  assumes "is_vector v"
    shows "-v\<^sup>T;v = 0"
by (metis assms compl_inf_bot inf_top.right_neutral one_compl one_idem_mult vector_2)

text \<open>The following results and a number of others in this theory are from \cite{Guttmann2017a}.\<close>

lemma ee:
  assumes "is_vector v"
      and "e \<le> v;-v\<^sup>T"
    shows "e;e = 0"
proof -
  have "e;v \<le> 0"
    by (metis assms annir mult_isor vector_prop1 comp_assoc)
  thus ?thesis
    by (metis assms(2) annil order.antisym bot_least comp_assoc mult_isol)
qed

lemma et:
  assumes "is_vector v"
      and "e \<le> v;-v\<^sup>T"
      and "t \<le> v;v\<^sup>T"
    shows "e;t = 0"
      and "e;t\<^sup>T = 0"
proof -
  have "e;t \<le> v;-v\<^sup>T;v;v\<^sup>T"
    by (metis assms(2-3) mult_isol_var comp_assoc)
  thus "e;t = 0"
    by (simp add: assms(1) comp_assoc le_bot vector_prop1)
next
  have "t\<^sup>T \<le> v;v\<^sup>T"
    using assms(3) conv_iso by fastforce
  hence "e;t\<^sup>T \<le> v;-v\<^sup>T;v;v\<^sup>T"
    by (metis assms(2) mult_isol_var comp_assoc)
  thus "e;t\<^sup>T = 0"
    by (simp add: assms(1) comp_assoc le_bot vector_prop1)
qed

text \<open>Some (more) results about points\<close>

definition point
  where "point x \<equiv> is_vector x \<and> bijective x"

lemma point_swap:
  assumes "point p"
      and "point q"
    shows "p \<le> x;q \<longleftrightarrow> q \<le> x\<^sup>T;p"
by (metis assms conv_invol inj_sur_semi_swap point_def)

text \<open>Some (more) results about singletons\<close>

abbreviation singleton
  where "singleton x \<equiv> bijective (x;1) \<and> bijective (x\<^sup>T;1)"

lemma singleton_injective:
  assumes "singleton x"
    shows "is_inj x"
using assms injective_down_closed maddux_20 by blast

lemma injective_inv:
  assumes "is_vector v"
      and "singleton e"
      and "e \<le> v;-v\<^sup>T"
      and "t \<le> v;v\<^sup>T"
      and "is_inj t"
    shows "is_inj (t + e)"
by (metis assms singleton_injective injective_sup bot_least et(2))

lemma singleton_is_point:
  assumes "singleton p"
    shows "point (p;1)"
by (simp add: assms comp_assoc is_vector_def point_def)

lemma singleton_transp:
  assumes "singleton p"
    shows "singleton (p\<^sup>T)"
by (simp add: assms)

lemma point_to_singleton:
  assumes "singleton p"
    shows "singleton (1'\<cdot>p;p\<^sup>T)"
using assms dom_def_aux_var dom_one is_vector_def point_def by fastforce

lemma singleton_singletonT:
  assumes "singleton p"
    shows "p;p\<^sup>T \<le> 1'"
using assms singleton_injective is_inj_def by blast

text \<open>Minimality\<close>

abbreviation minimum
  where "minimum x v \<equiv> v \<cdot> -(x\<^sup>T;v)"

text \<open>Regressively finite\<close>

abbreviation regressively_finite
  where "regressively_finite x \<equiv> \<forall>v . is_vector v \<and> v \<le> x\<^sup>T;v \<longrightarrow> v = 0"

lemma regressively_finite_minimum:
  "regressively_finite R \<Longrightarrow> is_vector v \<Longrightarrow> v \<noteq> 0 \<Longrightarrow> minimum R v \<noteq> 0"
using galois_aux2 by blast

lemma regressively_finite_irreflexive:
  assumes "regressively_finite x"
    shows "x \<le> -1'"
proof -
  have 1: "is_vector ((x\<^sup>T \<cdot> 1');1)"
    by (simp add: is_vector_def mult_assoc)
  have "(x\<^sup>T \<cdot> 1');1 = (x\<^sup>T \<cdot> 1');(x\<^sup>T \<cdot> 1');1"
    by (simp add: is_test_def test_comp_eq_mult)
  with 1 have "(x\<^sup>T \<cdot> 1');1 = 0"
    by (metis assms comp_assoc mult_subdistr)
  thus ?thesis
    by (metis conv_e conv_invol conv_times conv_zero galois_aux ss_p18)
qed

end (* relation_algebra *)

subsection \<open>Relation algebras satisfying the Tarski rule\<close>

class relation_algebra_tarski = relation_algebra +
  assumes tarski: "x \<noteq> 0 \<longleftrightarrow> 1;x;1 = 1"
begin

text \<open>Some (more) results about points\<close>

lemma point_equations:
  assumes "is_point p"
  shows "p;1=p"
    and "1;p=1"
    and "p\<^sup>T;1=1"
    and "1;p\<^sup>T=p\<^sup>T"
   apply (metis assms is_point_def is_vector_def)
  using assms is_point_def is_vector_def tarski vector_comp apply fastforce
 apply (metis assms conv_contrav conv_one conv_zero is_point_def is_vector_def tarski)
by (metis assms conv_contrav conv_one is_point_def is_vector_def)

text \<open>The following result is \cite[Proposition 2.4.5(i)]{SchmidtStroehlein1993}.\<close>

lemma point_singleton:
  assumes "is_point p"
      and "is_vector v"
      and "v \<noteq> 0"
      and "v \<le> p"
    shows "v = p"
proof -
  have "1;v = 1"
    using assms(2,3) comp_assoc is_vector_def tarski by fastforce
  hence "p = 1;v \<cdot> p"
    by simp
  also have "... \<le> (1 \<cdot> p;v\<^sup>T);(v \<cdot> 1\<^sup>T;p)"
    using dedekind by blast
  also have "... \<le> p;v\<^sup>T;v"
    by (simp add: mult_subdistl)
  also have "... \<le> p;p\<^sup>T;v"
    using assms(4) conv_iso mult_double_iso by blast
  also have "... \<le> v"
    by (metis assms(1) is_inj_def is_point_def mult_isor mult_onel)
  finally show ?thesis
    using assms(4) by simp
qed

lemma point_not_equal_aux:
  assumes "is_point p"
      and "is_point q"
    shows "p\<noteq>q \<longleftrightarrow> p \<cdot> -q \<noteq> 0"
proof
  show "p \<noteq> q \<Longrightarrow> p \<cdot> - q \<noteq> 0"
  proof (rule contrapos_nn)
    assume "p \<cdot> -q = 0"
    thus "p = q"
     using assms galois_aux2 is_point_def point_singleton by fastforce
  qed
next
  show "p \<cdot> - q \<noteq> 0 \<Longrightarrow> p \<noteq> q"
    using inf_compl_bot by blast
qed

text \<open>The following result is part of \cite[Proposition 2.4.5(ii)]{SchmidtStroehlein1993}.\<close>

lemma point_not_equal:
  assumes "is_point p"
      and "is_point q"
    shows "p\<noteq>q \<longleftrightarrow> p\<le>-q"
      and "p\<le>-q \<longleftrightarrow> p;q\<^sup>T \<le> -1'"
      and "p;q\<^sup>T \<le> -1' \<longleftrightarrow> p\<^sup>T;q \<le> 0"
proof -
  have "p \<noteq> q \<Longrightarrow> p \<le> - q"
    by (metis assms point_not_equal_aux is_point_def vector_compl vector_mult point_singleton
              inf.orderI inf.cobounded1)
  thus "p\<noteq>q \<longleftrightarrow> p\<le>-q"
    by (metis assms(1) galois_aux inf.orderE is_point_def order.refl)
next
  show "(p \<le> - q) = (p ; q\<^sup>T \<le> - 1')"
    by (simp add: conv_galois_2)
next
  show "(p ; q\<^sup>T \<le> - 1') = (p\<^sup>T ; q \<le> 0)"
    by (metis assms(2) compl_bot_eq conv_galois_2 galois_aux maddux_141 mult_1_right
              point_equations(4))
qed

lemma point_is_point:
  "point x \<longleftrightarrow> is_point x"
apply (rule iffI)
 apply (simp add: is_point_def point_def surj_one tarski)
using is_point_def is_vector_def mult_assoc point_def sur_def_var1 tarski by fastforce

lemma point_in_vector_or_complement:
  assumes "point p"
      and "is_vector v"
    shows "p \<le> v \<or> p \<le> -v"
proof (cases "p \<le> -v")
  assume "p \<le> -v"
  thus ?thesis
    by simp
next
  assume "\<not>(p \<le> -v)"
  hence "p\<cdot>v \<noteq> 0"
    by (simp add: galois_aux)
  hence "1;(p\<cdot>v) = 1"
    using assms comp_assoc is_vector_def point_def tarski vector_mult by fastforce
  hence "p \<le> p;(p\<cdot>v)\<^sup>T;(p\<cdot>v)"
    by (metis inf_top.left_neutral modular_2_var)
  also have "... \<le> p;p\<^sup>T;v"
    by (simp add: mult_isol_var)
  also have "... \<le> v"
    using assms(1) comp_assoc point_def ss423conv by fastforce
  finally show ?thesis ..
qed

lemma point_in_vector_or_complement_iff:
  assumes "point p"
      and "is_vector v"
    shows "p \<le> v \<longleftrightarrow> \<not>(p \<le> -v)"
by (metis assms annir compl_top_eq galois_aux inf.orderE one_compl point_def ss423conv tarski
          top_greatest point_in_vector_or_complement)

lemma different_points_consequences:
  assumes "point p"
      and "point q"
      and "p\<noteq>q"
    shows "p\<^sup>T;-q=1"
      and "-q\<^sup>T;p=1"
      and "-(p\<^sup>T;-q)=0"
      and "-(-q\<^sup>T;p)=0"
proof -
  have "p \<le> -q"
    by (metis assms compl_le_swap1 inf.absorb1 inf.absorb2 point_def point_in_vector_or_complement)
  thus 1: "p\<^sup>T;-q=1"
    using assms(1) by (metis is_vector_def point_def ss423conv top_le)
  thus 2: "-q\<^sup>T;p=1"
    using conv_compl conv_one by force
  from 1 show "-(p\<^sup>T;-q)=0"
    by simp
  from 2 show "-(-q\<^sup>T;p)=0"
    by simp
qed

text \<open>Some (more) results about singletons\<close>

lemma singleton_pq:
  assumes "point p"
      and "point q"
    shows "singleton (p;q\<^sup>T)"
using assms comp_assoc point_def point_equations(1,3) point_is_point by fastforce

lemma singleton_equal_aux:
  assumes "singleton p"
      and "singleton q"
      and "q\<le>p"
    shows "p \<le> q;1"
proof -
  have pLp: "p;1;p\<^sup>T \<le>1'"
    by (simp add: assms(1) maddux_21 ss423conv)

  have "p = 1;(q\<^sup>T;q;1) \<cdot> p"
    using tarski
    by (metis assms(2) annir singleton_injective inf.commute inf_top.right_neutral inj_triple
              mult_assoc surj_one)
  also have "... \<le> (1 \<cdot> p;(q\<^sup>T;q;1)\<^sup>T);(q\<^sup>T;q;1 \<cdot> 1;p)"
    using dedekind by (metis conv_one)
  also have "... \<le> p;1;q\<^sup>T;q;q\<^sup>T;q;1"
    by (simp add: comp_assoc mult_isol)
  also have "... \<le> p;1;p\<^sup>T;q;q\<^sup>T;q;1"
    using assms(3) by (metis comp_assoc conv_iso mult_double_iso)
  also have "... \<le> 1';q;q\<^sup>T;q;1"
    using pLp using mult_isor by blast
  also have "... \<le> q;1"
    using assms(2) singleton_singletonT by (simp add: comp_assoc mult_isol)
  finally show ?thesis .
qed

lemma singleton_equal:
 assumes "singleton p"
     and "singleton q"
     and "q\<le>p"
   shows "q=p"
proof -
  have p1: "p \<le> q;1"
    using assms by (rule singleton_equal_aux)
  have "p\<^sup>T \<le> q\<^sup>T;1"
    using assms singleton_equal_aux singleton_transp conv_iso by fastforce
  hence p2: "p \<le> 1;q"
    using conv_iso by force

  have "p \<le> q;1 \<cdot> 1;q"
    using p1 p2 inf.boundedI by blast
  also have "... \<le> (q \<cdot> 1;q;1);(1 \<cdot> q\<^sup>T;1;q)"
    using dedekind by (metis comp_assoc conv_one)
  also have "... \<le> q;q\<^sup>T;1;q"
    by (simp add: mult_isor comp_assoc)
  also have "... \<le> q;1'"
    by (metis assms(2) conv_contrav conv_invol conv_one is_inj_def mult_assoc mult_isol
              one_idem_mult)
  also have "... \<le> q"
    by simp
  finally have "p \<le> q" .
  thus "q=p"
  using assms(3) by simp
qed

lemma singleton_nonsplit:
  assumes "singleton p"
      and "x\<le>p"
    shows "x=0 \<or> x=p"
proof (cases "x=0")
  assume "x=0"
  thus ?thesis ..
next
  assume 1: "x\<noteq>0"
  have "singleton x"
  proof (safe)
    show "is_inj (x;1)"
      using assms injective_down_closed mult_isor by blast
    show "is_inj (x\<^sup>T;1)"
      using assms conv_iso injective_down_closed mult_isol_var by blast
    show "is_sur (x;1)"
      using 1 comp_assoc sur_def_var1 tarski by fastforce
    thus "is_sur (x\<^sup>T;1)"
      by (metis conv_contrav conv_one mult.semigroup_axioms sur_def_var1 semigroup.assoc)
  qed
  thus ?thesis
    using assms singleton_equal by blast
qed

lemma singleton_nonzero:
  assumes "singleton p"
    shows "p\<noteq>0"
proof
  assume "p = 0"
  hence "point 0"
    using assms singleton_is_point by fastforce
  thus False
    by (simp add: is_point_def point_is_point)
qed

lemma singleton_sum:
  assumes "singleton p"
    shows "p \<le> x+y \<longleftrightarrow> (p\<le>x \<or> p\<le>y)"
proof
  show "p \<le> x + y \<Longrightarrow> p \<le> x \<or> p \<le> y"
  proof -
    assume as: "p \<le> x + y"
    show "p \<le> x \<or> p \<le> y"
    proof (cases "p\<le>x")
      assume "p\<le>x"
      thus ?thesis ..
    next
      assume a:"\<not>(p\<le>x)"
      hence "p\<cdot>x \<noteq> p"
        using a inf.orderI by fastforce
      hence "p \<le> -x"
        using assms singleton_nonsplit galois_aux inf_le1 by blast
      hence "p\<le>y"
        using as by (metis galois_1 inf.orderE)
      thus ?thesis
        by simp
    qed
  qed
next
  show "p \<le> x \<or> p \<le> y \<Longrightarrow> p \<le> x + y"
    using sup.coboundedI1 sup.coboundedI2 by blast
qed

lemma singleton_iff:
 "singleton x \<longleftrightarrow> x \<noteq> 0 \<and> x\<^sup>T;1;x + x;1;x\<^sup>T \<le> 1'"
by (smt comp_assoc conv_contrav conv_invol conv_one is_inj_def le_sup_iff one_idem_mult
        sur_def_var1 tarski)

lemma singleton_not_atom_in_relation_algebra_tarski:
 assumes "p\<noteq>0"
     and "\<forall>x . x\<le>p \<longrightarrow> x=0 \<or> x=p"
   shows "singleton p"
nitpick [expect=genuine] oops

end (* relation_algebra_tarski *)

subsection \<open>Relation algebras satisfying the point axiom\<close>

class relation_algebra_point = relation_algebra +
  assumes point_axiom: "x \<noteq> 0 \<longrightarrow> (\<exists>y z . point y \<and> point z \<and> y;z\<^sup>T \<le> x)"
begin

text \<open>Some (more) results about points\<close>

lemma point_exists:
  "\<exists>x . point x"
by (metis (full_types) order.eq_iff is_inj_def is_sur_def is_vector_def point_axiom point_def)

lemma point_below_vector:
  assumes "is_vector v"
      and "v \<noteq> 0"
    shows "\<exists>x . point x \<and> x \<le> v"
proof -
  from assms(2) obtain y and z where 1: "point y \<and> point z \<and> y;z\<^sup>T \<le> v"
    using point_axiom by blast
  have "z\<^sup>T;1 = (1;z)\<^sup>T"
    using conv_contrav conv_one by simp
  hence "y;(1;z)\<^sup>T \<le> v"
    using 1 by (metis assms(1) comp_assoc is_vector_def mult_isor)
  thus ?thesis
    using 1 by (metis conv_one is_vector_def point_def sur_def_var1)
qed

end (* relation_algebra_point *)

class relation_algebra_tarski_point = relation_algebra_tarski + relation_algebra_point
begin

lemma atom_is_singleton:
  assumes "p\<noteq>0"
      and "\<forall>x . x\<le>p \<longrightarrow> x=0 \<or> x=p"
    shows "singleton p"
by (metis assms singleton_nonzero singleton_pq point_axiom)

lemma singleton_iff_atom:
  "singleton p \<longleftrightarrow> p\<noteq>0 \<and> (\<forall>x . x\<le>p \<longrightarrow> x=0 \<or> x=p)"
using singleton_nonsplit singleton_nonzero atom_is_singleton by blast

lemma maddux_tarski:
  assumes "x\<noteq>0"
  shows "\<exists>y . y\<noteq>0 \<and> y\<le>x \<and> is_p_fun y"
proof -
  obtain p q where 1: "point p \<and> point q \<and> p;q\<^sup>T \<le> x"
    using assms point_axiom by blast
  hence 2: "p;q\<^sup>T\<noteq>0"
    by (simp add: singleton_nonzero singleton_pq)
  have "is_p_fun (p;q\<^sup>T)"
    using 1 by (meson singleton_singletonT singleton_pq singleton_transp is_inj_def p_fun_inj)
  thus ?thesis
    using 1 2 by force
qed

text \<open>Intermediate Point Theorem \cite[Proposition 2.4.8]{SchmidtStroehlein1993}\<close>

lemma intermediate_point_theorem:
  assumes "point p"
      and "point r"
    shows "p \<le> x;y;r \<longleftrightarrow> (\<exists>q . point q \<and> p \<le> x;q \<and> q \<le> y;r)"
proof
  assume 1: "p \<le> x;y;r"
  let ?v = "x\<^sup>T;p \<cdot> y;r"
  have 2: "is_vector ?v"
    using assms comp_assoc is_vector_def point_def vector_mult by fastforce
  have "?v \<noteq> 0"
    using 1 by (metis assms(1) inf.absorb2 is_point_def maddux_141 point_is_point mult.assoc)
  hence "\<exists>q . point q \<and> q \<le> ?v"
    using 2 point_below_vector by blast
  thus "\<exists>q . point q \<and> p \<le> x;q \<and> q \<le> y;r"
    using assms(1) point_swap by auto
next
  assume "\<exists>q . point q \<and> p \<le> x;q \<and> q \<le> y;r"
  thus "p \<le> x;y;r"
    using comp_assoc mult_isol order_trans by fastforce
qed

end (* relation_algebra_tarski_point *)

(*
The following shows that rtc can be defined with only 2 axioms.
This should eventually go into AFP/Relation_Algebra_RTC.relation_algebra_rtc.
There the class definition should be replaced with:

class relation_algebra_rtc = relation_algebra + star_op +
  assumes rtc_unfoldl: "1' + x ; x\<^sup>\<star> \<le> x\<^sup>\<star>"
      and rtc_inductl: "z + x ; y \<le> y \<longrightarrow> x\<^sup>\<star> ; z \<le> y"

and the following lemmas:
*)

context relation_algebra
begin

lemma unfoldl_inductl_implies_unfoldr:
  assumes "\<And>x. 1' + x;(rtc x) \<le> rtc x"
      and "\<And>x y z. x+y;z \<le> z \<Longrightarrow> rtc(y);x \<le> z"
    shows "1' + rtc(x);x \<le> rtc x"
by (metis assms le_sup_iff mult_oner order.trans subdistl_eq sup_absorb2 sup_ge1)

lemma star_transpose_swap:
  assumes "\<And>x. 1' + x;(rtc x) \<le> rtc x"
      and "\<And>x y z. x+y;z \<le> z \<Longrightarrow> rtc(y);x \<le> z"
    shows "rtc(x\<^sup>T) = (rtc x)\<^sup>T"
apply(simp only: order.eq_iff; rule conjI)
  apply (metis assms conv_add conv_contrav conv_e conv_iso mult_1_right
             unfoldl_inductl_implies_unfoldr )
by (metis assms conv_add conv_contrav conv_e conv_invol conv_iso mult_1_right
          unfoldl_inductl_implies_unfoldr)

lemma unfoldl_inductl_implies_inductr:
  assumes "\<And>x. 1' + x;(rtc x) \<le> rtc x"
      and "\<And>x y z. x+y;z \<le> z \<Longrightarrow> rtc(y);x \<le> z"
    shows "x+z;y \<le> z \<Longrightarrow> x;rtc(y) \<le> z"
by (metis assms conv_add conv_contrav conv_iso star_transpose_swap)

end (* relation_algebra *)

context relation_algebra_rtc
begin

abbreviation tc ("(_\<^sup>+)" [101] 100) where "tc x \<equiv> x;x\<^sup>\<star>"

abbreviation is_acyclic
  where "is_acyclic x \<equiv> x\<^sup>+ \<le> -1'"

text \<open>General theorems\<close>

lemma star_denest_10:
  assumes "x;y=0"
    shows "(x+y)\<^sup>\<star> = y;y\<^sup>\<star>;x\<^sup>\<star>+x\<^sup>\<star>"
using assms bubble_sort sup.commute by auto

text \<open>The following two lemmas are from \cite{Guttmann2018b}.\<close>

lemma cancel_separate:
  assumes "x ; y \<le> 1'"
  shows "x\<^sup>\<star> ; y\<^sup>\<star> \<le> x\<^sup>\<star> + y\<^sup>\<star>"
proof -
  have "x ; y\<^sup>\<star> = x + x ; y ; y\<^sup>\<star>"
    by (metis comp_assoc conway.dagger_unfoldl_distr distrib_left mult_oner)
  also have "... \<le> x + y\<^sup>\<star>"
    by (metis assms join_isol star_invol star_plus_one star_subdist_var_2 sup.absorb2 sup.assoc)
  also have "... \<le> x\<^sup>\<star> + y\<^sup>\<star>"
    using join_iso by fastforce
  finally have "x ; (x\<^sup>\<star> + y\<^sup>\<star>) \<le> x\<^sup>\<star> + y\<^sup>\<star>"
    by (simp add: distrib_left le_supI1)
  thus ?thesis
    by (simp add: rtc_inductl)
qed

lemma cancel_separate_inj_converse:
  assumes "is_inj x"
    shows "x\<^sup>\<star> ; x\<^sup>T\<^sup>\<star> = x\<^sup>\<star> + x\<^sup>T\<^sup>\<star>"
 apply (rule order.antisym)
  using assms cancel_separate is_inj_def apply blast
by (metis conway.dagger_unfoldl_distr le_supI mult_1_right mult_isol sup.cobounded1)

lemma cancel_separate_p_fun_converse:
  assumes "is_p_fun x"
    shows "x\<^sup>T\<^sup>\<star> ; x\<^sup>\<star> = x\<^sup>\<star> + x\<^sup>T\<^sup>\<star>"
using sup_commute assms cancel_separate_inj_converse p_fun_inj by fastforce

lemma cancel_separate_converse_idempotent:
  assumes "is_inj x"
      and "is_p_fun x"
    shows "(x\<^sup>\<star> + x\<^sup>T\<^sup>\<star>);(x\<^sup>\<star> + x\<^sup>T\<^sup>\<star>) = x\<^sup>\<star> + x\<^sup>T\<^sup>\<star>"
by (metis assms cancel_separate cancel_separate_p_fun_converse church_rosser_equiv is_inj_def
          star_denest_var_6)

lemma triple_star:
  assumes "is_inj x"
      and "is_p_fun x"
    shows "x\<^sup>\<star>;x\<^sup>T\<^sup>\<star>;x\<^sup>\<star> = x\<^sup>\<star> + x\<^sup>T\<^sup>\<star>"
by (simp add: assms cancel_separate_inj_converse cancel_separate_p_fun_converse)

lemma inj_xxts:
  assumes "is_inj x"
    shows "x;x\<^sup>T\<^sup>\<star> \<le> x\<^sup>\<star> + x\<^sup>T\<^sup>\<star>"
by (metis assms cancel_separate_inj_converse distrib_right less_eq_def star_ext)

lemma plus_top:
  "x\<^sup>+;1 = x;1"
by (metis comp_assoc conway.dagger_unfoldr_distr sup_top_left)

lemma top_plus:
  "1;x\<^sup>+ = 1;x"
by (metis comp_assoc conway.dagger_unfoldr_distr star_denest_var_2 star_ext star_slide_var
           sup_top_left top_unique)

lemma plus_conv:
  "(x\<^sup>+)\<^sup>T = x\<^sup>T\<^sup>+"
by (simp add: star_conv star_slide_var)

lemma inj_implies_step_forwards_backwards:
  assumes "is_inj x"
    shows "x\<^sup>\<star>;(x\<^sup>+\<cdot>1');1 \<le> x\<^sup>T;1"
proof -
  have "(x\<^sup>+\<cdot>1');1 \<le> (x\<^sup>\<star>\<cdot>x\<^sup>T);(x\<cdot>(x\<^sup>\<star>)\<^sup>T);1"
    by (metis conv_contrav conv_e dedekind mult_1_right mult_isor star_slide_var)
  also have "... \<le> (x\<^sup>\<star>\<cdot>x\<^sup>T);1"
    by (simp add: comp_assoc mult_isol)
  finally have 1: "(x\<^sup>+\<cdot>1');1 \<le> (x\<^sup>\<star>\<cdot>x\<^sup>T);1" .

  have "x;(x\<^sup>\<star>\<cdot>x\<^sup>T);1 \<le> (x\<^sup>+\<cdot>x;x\<^sup>T);1"
    by (metis inf_idem meet_interchange mult_isor)
  also have "... \<le> (x\<^sup>+\<cdot>1');1"
    using assms is_inj_def meet_isor mult_isor by fastforce
  finally have "x;(x\<^sup>\<star>\<cdot>x\<^sup>T);1 \<le> (x\<^sup>\<star>\<cdot>x\<^sup>T);1"
    using 1 by fastforce
  hence "x\<^sup>\<star>;(x\<^sup>+\<cdot>1');1 \<le> (x\<^sup>\<star>\<cdot>x\<^sup>T);1"
    using 1 by (simp add: comp_assoc rtc_inductl)
  thus "x\<^sup>\<star>;(x\<^sup>+\<cdot>1');1 \<le> x\<^sup>T;1"
    using inf.cobounded2 mult_isor order_trans by blast
qed

text \<open>Acyclic relations\<close>

text \<open>The following result is from \cite{Guttmann2017c}.\<close>

lemma acyclic_inv:
  assumes "is_acyclic t"
      and "is_vector v"
      and "e \<le> v;-v\<^sup>T"
      and "t \<le> v;v\<^sup>T"
    shows "is_acyclic (t + e)"
proof -
  have "t\<^sup>+;e \<le> t\<^sup>+;v;-v\<^sup>T"
    by (simp add: assms(3) mult_assoc mult_isol)
  also have "... \<le> v;v\<^sup>T;t\<^sup>\<star>;v;-v\<^sup>T"
    by (simp add: assms(4) mult_isor)
  also have "... \<le> v;-v\<^sup>T"
    by (metis assms(2) mult_double_iso top_greatest is_vector_def mult_assoc)
  also have "... \<le> -1'"
    by (simp add: conv_galois_1)
  finally have 1: "t\<^sup>+;e \<le> -1'" .
  have "e \<le> v;-v\<^sup>T"
    using assms(3) by simp
  also have "... \<le> -1'"
    by (simp add: conv_galois_1)
  finally have 2: "t\<^sup>+;e + e \<le> -1'"
    using 1 by simp
  have 3: "e;t\<^sup>\<star> = e"
    by (metis assms(2-4) et(1) independence2)
  have 4: "e\<^sup>\<star> = 1' + e"
    using assms(2-3) ee boffa_var bot_least by blast
  have "(t + e)\<^sup>+ = (t + e);t\<^sup>\<star>;(e;t\<^sup>\<star>)\<^sup>\<star>"
    by (simp add: comp_assoc)
  also have "... = (t + e);t\<^sup>\<star>;(1' + e)"
    using 3 4 by simp
  also have "... = t\<^sup>+;(1' + e) + e;t\<^sup>\<star>;(1' + e)"
    by simp
  also have "... = t\<^sup>+;(1' + e) + e;(1' + e)"
    using 3 by simp
  also have "... = t\<^sup>+;(1' + e) + e"
    using 4 assms(2-3) ee independence2 by fastforce
  also have "... = t\<^sup>+ + t\<^sup>+;e + e"
    by (simp add: distrib_left)
  also have "... \<le> -1'"
    using assms(1) 2 by simp
  finally show ?thesis .
qed

lemma acyclic_single_step:
  assumes "is_acyclic x"
    shows "x \<le> -1'"
by (metis assms dual_order.trans mult_isol mult_oner star_ref)

lemma acyclic_reachable_points:
  assumes "is_point p"
      and "is_point q"
      and "p \<le> x;q"
      and "is_acyclic x"
    shows "p\<noteq>q"
proof
  assume "p=q"
  hence "p \<le> x;q \<cdot> q"
    by (simp add: assms(3) order.eq_iff inf.absorb2)
  also have "... = (x \<cdot> 1');q"
    using assms(2) inj_distr is_point_def by simp
  also have "... \<le> (-1' \<cdot> 1');q"
    using acyclic_single_step assms(4) by (metis abel_semigroup.commute inf.abel_semigroup_axioms
          meet_isor mult_isor)
 also have "... = 0"
  by simp
 finally have "p \<le> 0" .
 thus False
  using assms(1) bot_unique is_point_def by blast
qed

lemma acyclic_trans:
 assumes "is_acyclic x"
   shows "x \<le> -(x\<^sup>T\<^sup>+)"
proof -
 have "\<exists>c\<ge>x. c \<le> - (x\<^sup>+)\<^sup>T"
  by (metis assms compl_mono conv_galois_2 conv_iso double_compl mult_onel star_1l)
 thus ?thesis
  by (metis dual_order.trans plus_conv)
qed

lemma acyclic_trans':
 assumes "is_acyclic x"
   shows "x\<^sup>\<star> \<le> -(x\<^sup>T\<^sup>+)"
proof -
 have "x\<^sup>\<star> \<le> - (- (- (x\<^sup>T ; - (- 1'))) ; (x\<^sup>\<star>)\<^sup>T)"
  by (metis assms conv_galois_1 conv_galois_2 order_trans star_trans)
 then show ?thesis
  by (simp add: star_conv)
qed

text \<open>Regressively finite\<close>

lemma regressively_finite_acyclic:
  assumes "regressively_finite x"
    shows "is_acyclic x"
proof -
  have 1: "is_vector ((x\<^sup>+ \<cdot> 1');1)"
    by (simp add: is_vector_def mult_assoc)
  have "(x\<^sup>+ \<cdot> 1');1 = (x\<^sup>T\<^sup>+ \<cdot> 1');1"
    by (metis plus_conv test_converse)
  also have "... \<le> x\<^sup>T;(1';x\<^sup>T\<^sup>\<star> \<cdot> x);1"
    by (metis conv_invol modular_1_var mult_isor mult_oner mult_onel)
  also have "... \<le> x\<^sup>T;(1' \<cdot> x\<^sup>+);x\<^sup>T\<^sup>\<star>;1"
    by (metis comp_assoc conv_invol modular_2_var mult_isol mult_isor star_conv)
  also have "... = x\<^sup>T;(x\<^sup>+ \<cdot> 1');1"
    by (metis comp_assoc conway.dagger_unfoldr_distr inf.commute sup.cobounded1 top_le)
  finally have "(x\<^sup>+ \<cdot> 1');1 = 0"
    using 1 assms by (simp add: comp_assoc)
  thus ?thesis
    by (simp add: galois_aux ss_p18)
qed

notation power (infixr "\<up>" 80)

lemma power_suc_below_plus:
  "x \<up> Suc n \<le> x\<^sup>+"
  apply (induct n)
 using mult_isol star_ref apply fastforce
by (simp add: mult_isol_var order_trans)

end (* relation_algebra_rtc *)

class relation_algebra_rtc_tarski = relation_algebra_rtc + relation_algebra_tarski
begin

lemma point_loop_not_acyclic:
  assumes "is_point p"
      and "p \<le> x \<up> Suc n ; p"
    shows "\<not> is_acyclic x"
proof -
  have "p \<le> x\<^sup>+ ; p"
    by (meson assms dual_order.trans point_def point_is_point ss423bij power_suc_below_plus)
  hence "p ; p\<^sup>T \<le> x\<^sup>+"
    using assms(1) point_def point_is_point ss423bij by blast
  thus ?thesis
    using assms(1) order.trans point_not_equal(1) point_not_equal(2) by blast
qed

end

class relation_algebra_rtc_point = relation_algebra_rtc + relation_algebra_point

class relation_algebra_rtc_tarski_point = relation_algebra_rtc_tarski + relation_algebra_rtc_point +
                                          relation_algebra_tarski_point

text \<open>
Finite graphs: the axiom says the algebra has finitely many elements.
This means the relations have a finite base set.
\<close>

class relation_algebra_rtc_tarski_point_finite = relation_algebra_rtc_tarski_point + finite
begin

text \<open>For a finite acyclic relation, the powers eventually vanish.\<close>

lemma acyclic_power_vanishes:
  assumes "is_acyclic x"
    shows "\<exists>n . x \<up> Suc n = 0"
proof -
  let ?n = "card { p . is_point p }"
  let ?p = "x \<up> ?n"
  have "?p = 0"
  proof (rule ccontr)
    assume "?p \<noteq> 0"
    from this obtain p q where 1: "point p \<and> point q \<and> p;q\<^sup>T \<le> ?p"
      using point_axiom by blast
    hence 2: "p \<le> ?p;q"
      using point_def ss423bij by blast
    have "\<forall>n\<le>?n . (\<exists>f. \<forall>i\<le>n . is_point (f i) \<and> (\<forall>j\<le>i . p \<le> x\<up>(?n-i) ; f i \<and> f i \<le> x\<up>(i-j) ; f j))"
    proof
      fix n
      show "n\<le>?n \<longrightarrow> (\<exists>f. \<forall>i\<le>n . is_point (f i) \<and> (\<forall>j\<le>i . p \<le> x\<up>(?n-i) ; f i \<and> f i \<le> x\<up>(i-j) ; f j))"
      proof (induct n)
        case 0
        thus ?case
          using 1 2 point_is_point by fastforce
      next
        case (Suc n)
        fix n
        assume 3: "n\<le>?n \<longrightarrow> (\<exists>f . \<forall>i\<le>n . is_point (f i) \<and> (\<forall>j\<le>i . p \<le> x \<up> (?n-i) ; f i \<and> f i \<le> x \<up> (i-j) ; f j))"
        show "Suc n\<le>?n \<longrightarrow> (\<exists>f . \<forall>i\<le>Suc n . is_point (f i) \<and> (\<forall>j\<le>i . p \<le> x \<up> (?n-i) ; f i \<and> f i \<le> x \<up> (i-j) ; f j))"
        proof
          assume 4: "Suc n\<le>?n"
          from this obtain f where 5: "\<forall>i\<le>n . is_point (f i) \<and> (\<forall>j\<le>i . p \<le> x \<up> (?n-i) ; f i \<and> f i \<le> x \<up> (i-j) ; f j)"
            using 3 by auto
          have "p \<le> x \<up> (?n-n) ; f n"
            using 5 by blast
          also have "... = x \<up> (?n-n-one_class.one) ; x ; f n"
            using 4 by (metis (no_types) Suc_diff_le diff_Suc_1 diff_Suc_Suc power_Suc2)
          finally obtain r where 6: "point r \<and> p \<le> x \<up> (?n-Suc n) ; r \<and> r \<le> x ; f n"
            using 1 5 intermediate_point_theorem point_is_point by fastforce
          let ?g = "\<lambda>m . if m = Suc n then r else f m"
          have "\<forall>i\<le>Suc n . is_point (?g i) \<and> (\<forall>j\<le>i . p \<le> x \<up> (?n-i) ; ?g i \<and> ?g i \<le> x \<up> (i-j) ; ?g j)"
          proof
            fix i
            show "i\<le>Suc n \<longrightarrow> is_point (?g i) \<and> (\<forall>j\<le>i . p \<le> x \<up> (?n-i) ; ?g i \<and> ?g i \<le> x \<up> (i-j) ; ?g j)"
            proof (cases "i\<le>n")
              case True
              thus ?thesis
                using 5 by simp
            next
              case False
              have "is_point (?g (Suc n)) \<and> (\<forall>j\<le>Suc n . p \<le> x \<up> (?n-Suc n) ; ?g (Suc n) \<and> ?g (Suc n) \<le> x \<up> (Suc n-j) ; ?g j)"
              proof
                show "is_point (?g (Suc n))"
                  using 6 point_is_point by fastforce
              next
                show "\<forall>j\<le>Suc n . p \<le> x \<up> (?n-Suc n) ; ?g (Suc n) \<and> ?g (Suc n) \<le> x \<up> (Suc n-j) ; ?g j"
                proof
                  fix j
                  show "j\<le>Suc n \<longrightarrow> p \<le> x \<up> (?n-Suc n) ; ?g (Suc n) \<and> ?g (Suc n) \<le> x \<up> (Suc n-j) ; ?g j"
                  proof
                    assume 7: "j\<le>Suc n"
                    show "p \<le> x \<up> (?n-Suc n) ; ?g (Suc n) \<and> ?g (Suc n) \<le> x \<up> (Suc n-j) ; ?g j"
                    proof
                      show "p \<le> x \<up> (?n-Suc n) ; ?g (Suc n)"
                        using 6 by simp
                    next
                      show "?g (Suc n) \<le> x \<up> (Suc n-j) ; ?g j"
                      proof (cases "j = Suc n")
                        case True
                        thus ?thesis
                          by simp
                      next
                        case False
                        hence "f n \<le> x \<up> (n-j) ; f j"
                          using 5 7 by fastforce
                        hence "x ; f n \<le> x \<up> (Suc n-j) ; f j"
                          using 7 False Suc_diff_le comp_assoc mult_isol by fastforce
                        thus ?thesis
                          using 6 False by fastforce
                      qed
                    qed
                  qed
                qed
              qed
              thus ?thesis
                by (simp add: False le_Suc_eq)
            qed
          qed
          thus "\<exists>f . \<forall>i\<le>Suc n . is_point (f i) \<and> (\<forall>j\<le>i . p \<le> x \<up> (?n-i) ; f i \<and> f i \<le> x \<up> (i-j) ; f j)"
            by auto
        qed
      qed
    qed
    from this obtain f where 8: "\<forall>i\<le>?n . is_point (f i) \<and> (\<forall>j\<le>i . p \<le> x \<up> (?n-i) ; f i \<and> f i \<le> x \<up> (i-j) ; f j)"
      by fastforce
    let ?A = "{ k . k\<le>?n }"
    have "f ` ?A \<subseteq> { p . is_point p }"
      using 8 by blast
    hence "card (f ` ?A) \<le> ?n"
      by (simp add: card_mono)
    hence "\<not> inj_on f ?A"
      by (simp add: pigeonhole)
    from this obtain i j where 9: "i \<le> ?n \<and> j \<le> ?n \<and> i \<noteq> j \<and> f i = f j"
      by (metis (no_types, lifting) inj_on_def mem_Collect_eq)
    show False
      apply (cases "i < j")
     using 8 9 apply (metis Suc_diff_le Suc_leI assms diff_Suc_Suc order_less_imp_le
                            point_loop_not_acyclic)
    using 8 9 by (metis assms neqE point_loop_not_acyclic Suc_diff_le Suc_leI assms diff_Suc_Suc
                        order_less_imp_le)
    qed
    thus ?thesis
      by (metis annir power.simps(2))
qed

text \<open>Hence finite acyclic relations are regressively finite.\<close>

lemma acyclic_regressively_finite:
  assumes "is_acyclic x"
    shows "regressively_finite x"
proof
  have "is_acyclic (x\<^sup>T)"
    using assms acyclic_trans' compl_le_swap1 order_trans star_ref by blast
  from this obtain n where 1: "x\<^sup>T \<up> Suc n = 0"
    using acyclic_power_vanishes by fastforce
  fix v
  show "is_vector v \<and> v \<le> x\<^sup>T;v \<longrightarrow> v = 0"
  proof
    assume 2: "is_vector v \<and> v \<le> x\<^sup>T;v"
    have "v \<le> x\<^sup>T \<up> Suc n ; v"
    proof (induct n)
      case 0
      thus ?case
        using 2 by simp
    next
      case (Suc n)
      hence "x\<^sup>T ; v \<le> x\<^sup>T \<up> Suc (Suc n) ; v"
        by (simp add: comp_assoc mult_isol)
      thus ?case
        using 2 dual_order.trans by blast
    qed
    thus "v = 0"
      using 1 by (simp add: le_bot)
  qed
 qed

lemma acyclic_is_regressively_finite:
  "is_acyclic x \<longleftrightarrow> regressively_finite x"
using acyclic_regressively_finite regressively_finite_acyclic by blast

end (* end relation_algebra_rtc_tarski_point_finite *)

end


theory Part_1 imports Main

begin

(* 5.1 *)

lemma assumes T: "\<forall>x y. T x y \<or> T y x"
  and A: "\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y"
  and TA: "\<forall>x y. T x y \<longrightarrow> A x y" and "A x y"
  shows "T x y"
proof (rule ccontr)
  assume "\<not> T x y"
  from this and T have "T y x" by blast
  from this and TA have "A y x" by blast
  from this and `A x y` and A have "x = y" by blast
  from this and `\<not> T x y` and `T y x` show "False" by blast
qed

(* 5.2 *)

lemma "(\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs)
  \<or> (\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs + 1)"
proof cases
  assume "even (length xs)"
  then obtain k where ks:"(length xs) = 2*k" by blast
  obtain ys where 1:"ys = take k xs" by auto
  obtain zs where 2:"zs = drop k xs" by auto
  then have "xs = ys @ zs" by (simp add: \<open>ys = take k xs\<close>)
  moreover have "length ys = length zs" using 1 and 2 and ks by simp
  ultimately show ?thesis by blast
next
  assume "odd (length xs)"
  then obtain k where ks:"length xs = 2*k + 1" using oddE by blast
  obtain ys where 1:"ys = take (Suc k) xs" by auto
  obtain zs where 2:"zs = drop (Suc k) xs" by auto
  then have "xs = ys @ zs" using 1 and 2 by simp
  moreover have "length ys = length zs + 1" by (simp add: "1" "2" ks)
  ultimately show ?thesis by blast
qed

end


(* Author: Tobias Nipkow *)

section \<open>Braun Trees\<close>

theory Braun_Tree
imports "HOL-Library.Tree_Real"
begin

text \<open>Braun Trees were studied by Braun and Rem~\<^cite>\<open>"BraunRem"\<close>
and later Hoogerwoord~\<^cite>\<open>"Hoogerwoord"\<close>.\<close>

fun braun :: "'a tree \<Rightarrow> bool" where
"braun Leaf = True" |
"braun (Node l x r) = ((size l = size r \<or> size l = size r + 1) \<and> braun l \<and> braun r)"

lemma braun_Node':
  "braun (Node l x r) = (size r \<le> size l \<and> size l \<le> size r + 1 \<and> braun l \<and> braun r)"
by auto

text \<open>The shape of a Braun-tree is uniquely determined by its size:\<close>

lemma braun_unique: "\<lbrakk> braun (t1::unit tree); braun t2; size t1 = size t2 \<rbrakk> \<Longrightarrow> t1 = t2"
proof (induction t1 arbitrary: t2)
  case Leaf thus ?case by simp
next
  case (Node l1 _ r1)
  from Node.prems(3) have "t2 \<noteq> Leaf" by auto
  then obtain l2 x2 r2 where [simp]: "t2 = Node l2 x2 r2" by (meson neq_Leaf_iff)
  with Node.prems have "size l1 = size l2 \<and> size r1 = size r2" by auto
  thus ?case using Node.prems(1,2) Node.IH by auto
qed

text \<open>Braun trees are almost complete:\<close>

lemma acomplete_if_braun: "braun t \<Longrightarrow> acomplete t"
proof(induction t)
  case Leaf show ?case by (simp add: acomplete_def)
next
  case (Node l x r) thus ?case using acomplete_Node_if_wbal2 by force
qed

subsection \<open>Numbering Nodes\<close>

text \<open>We show that a tree is a Braun tree iff a parity-based
numbering (\<open>braun_indices\<close>) of nodes yields an interval of numbers.\<close>

fun braun_indices :: "'a tree \<Rightarrow> nat set" where
"braun_indices Leaf = {}" |
"braun_indices (Node l _ r) = {1} \<union> (*) 2 ` braun_indices l \<union> Suc ` (*) 2 ` braun_indices r"

lemma braun_indices1: "0 \<notin> braun_indices t"
by (induction t) auto

lemma finite_braun_indices: "finite(braun_indices t)"
by (induction t) auto

text "One direction:"

lemma braun_indices_if_braun: "braun t \<Longrightarrow> braun_indices t = {1..size t}"
proof(induction t)
  case Leaf thus ?case by simp
next
  have *: "(*) 2 ` {a..b} \<union> Suc ` (*) 2 ` {a..b} = {2*a..2*b+1}" (is "?l = ?r") for a b
  proof
    show "?l \<subseteq> ?r" by auto
  next
    have "\<exists>x2\<in>{a..b}. x \<in> {Suc (2*x2), 2*x2}" if *: "x \<in> {2*a .. 2*b+1}" for x
    proof -
      have "x div 2 \<in> {a..b}" using * by auto
      moreover have "x \<in> {2 * (x div 2), Suc(2 * (x div 2))}" by auto
      ultimately show ?thesis by blast
    qed
    thus "?r \<subseteq> ?l" by fastforce
  qed
  case (Node l x r)
  hence "size l = size r \<or> size l = size r + 1" (is "?A \<or> ?B") by auto
  thus ?case
  proof
    assume ?A
    with Node show ?thesis by (auto simp: *)
  next
    assume ?B
    with Node show ?thesis by (auto simp: * atLeastAtMostSuc_conv)
  qed
qed

text "The other direction is more complicated. The following proof is due to Thomas Sewell."

lemma disj_evens_odds: "(*) 2 ` A \<inter> Suc ` (*) 2 ` B = {}"
using double_not_eq_Suc_double by auto

lemma card_braun_indices: "card (braun_indices t) = size t"
proof (induction t)
  case Leaf thus ?case by simp
next
  case Node
  thus ?case
    by(auto simp: UNION_singleton_eq_range finite_braun_indices card_Un_disjoint
                  card_insert_if disj_evens_odds card_image inj_on_def braun_indices1)
qed

lemma braun_indices_intvl_base_1:
  assumes bi: "braun_indices t = {m..n}"
  shows "{m..n} = {1..size t}"
proof (cases "t = Leaf")
  case True then show ?thesis using bi by simp
next
  case False
  note eqs = eqset_imp_iff[OF bi]
  from eqs[of 0] have 0: "0 < m"
    by (simp add: braun_indices1)
  from eqs[of 1] have 1: "m \<le> 1"
    by (cases t; simp add: False)
  from 0 1 have eq1: "m = 1" by simp
  from card_braun_indices[of t] show ?thesis
    by (simp add: bi eq1)
qed

lemma even_of_intvl_intvl:
  fixes S :: "nat set"
  assumes "S = {m..n} \<inter> {i. even i}"
  shows "\<exists>m' n'. S = (\<lambda>i. i * 2) ` {m'..n'}"
  apply (rule exI[where x="Suc m div 2"], rule exI[where x="n div 2"])
  apply (fastforce simp add: assms mult.commute)
  done

lemma odd_of_intvl_intvl:
  fixes S :: "nat set"
  assumes "S = {m..n} \<inter> {i. odd i}"
  shows "\<exists>m' n'. S = Suc ` (\<lambda>i. i * 2) ` {m'..n'}"
proof -
  have step1: "\<exists>m'. S = Suc ` ({m'..n - 1} \<inter> {i. even i})"
    apply (rule_tac x="if n = 0 then 1 else m - 1" in exI)
    apply (auto simp: assms image_def elim!: oddE)
    done
  thus ?thesis
    by (metis even_of_intvl_intvl)
qed

lemma image_int_eq_image:
  "(\<forall>i \<in> S. f i \<in> T) \<Longrightarrow> (f ` S) \<inter> T = f ` S"
  "(\<forall>i \<in> S. f i \<notin> T) \<Longrightarrow> (f ` S) \<inter> T = {}"
  by auto

lemma braun_indices1_le:
  "i \<in> braun_indices t \<Longrightarrow> Suc 0 \<le> i"
  using braun_indices1 not_less_eq_eq by blast

lemma braun_if_braun_indices: "braun_indices t = {1..size t} \<Longrightarrow> braun t"
proof(induction t)
case Leaf
  then show ?case by simp
next
  case (Node l x r)
  obtain t where t: "t = Node l x r" by simp
  from Node.prems have eq: "{2 .. size t} = (\<lambda>i. i * 2) ` braun_indices l \<union> Suc ` (\<lambda>i. i * 2) ` braun_indices r"
    (is "?R = ?S \<union> ?T")
    apply clarsimp
    apply (drule_tac f="\<lambda>S. S \<inter> {2..}" in arg_cong)
    apply (simp add: t mult.commute Int_Un_distrib2 image_int_eq_image braun_indices1_le)
    done
  then have ST: "?S = ?R \<inter> {i. even i}" "?T = ?R \<inter> {i. odd i}"
    by (simp_all add: Int_Un_distrib2 image_int_eq_image)
  from ST have l: "braun_indices l = {1 .. size l}"
    by (fastforce dest: braun_indices_intvl_base_1 dest!: even_of_intvl_intvl
                  simp: mult.commute inj_image_eq_iff[OF inj_onI])
  from ST have r: "braun_indices r = {1 .. size r}"
    by (fastforce dest: braun_indices_intvl_base_1 dest!: odd_of_intvl_intvl
                  simp: mult.commute inj_image_eq_iff[OF inj_onI])
  note STa = ST[THEN eqset_imp_iff, THEN iffD2]
  note STb = STa[of "size t"] STa[of "size t - 1"]
  then have sizes: "size l = size r \<or> size l = size r + 1"
    apply (clarsimp simp: t l r inj_image_mem_iff[OF inj_onI])
    apply (cases "even (size l)"; cases "even (size r)"; clarsimp elim!: oddE; fastforce)
    done
  from l r sizes show ?case
    by (clarsimp simp: Node.IH)
qed

lemma braun_iff_braun_indices: "braun t \<longleftrightarrow> braun_indices t = {1..size t}"
using braun_if_braun_indices braun_indices_if_braun by blast

(* An older less appealing proof:
lemma Suc0_notin_double: "Suc 0 \<notin> ( * ) 2 ` A"
by(auto)

lemma zero_in_double_iff: "(0::nat) \<in> ( * ) 2 ` A \<longleftrightarrow> 0 \<in> A"
by(auto)

lemma Suc_in_Suc_image_iff: "Suc n \<in> Suc ` A \<longleftrightarrow> n \<in> A"
by(auto)

lemmas nat_in_image = Suc0_notin_double zero_in_double_iff Suc_in_Suc_image_iff

lemma disj_union_eq_iff:
  "\<lbrakk> L1 \<inter> R2 = {}; L2 \<inter> R1 = {} \<rbrakk> \<Longrightarrow> L1 \<union> R1 = L2 \<union> R2 \<longleftrightarrow> L1 = L2 \<and> R1 = R2"
by blast

lemma inj_braun_indices: "braun_indices t1 = braun_indices t2 \<Longrightarrow> t1 = (t2::unit tree)"
proof(induction t1 arbitrary: t2)
  case Leaf thus ?case using braun_indices.elims by blast
next
  case (Node l1 x1 r1)
  have "t2 \<noteq> Leaf"
  proof
    assume "t2 = Leaf"
    with Node.prems show False by simp
  qed
  thus ?case using Node
    by (auto simp: neq_Leaf_iff insert_ident nat_in_image braun_indices1
                  disj_union_eq_iff disj_evens_odds inj_image_eq_iff inj_def)
qed

text \<open>How many even/odd natural numbers are there between m and n?\<close>

lemma card_Icc_even_nat:
  "card {i \<in> {m..n::nat}. even i} = (n+1-m + (m+1) mod 2) div 2" (is "?l m n = ?r m n")
proof(induction "n+1 - m" arbitrary: n m)
   case 0 thus ?case by simp
next
  case Suc
  have "m \<le> n" using Suc(2) by arith
  hence "{m..n} = insert m {m+1..n}" by auto
  hence "?l m n = card {i \<in> insert m {m+1..n}. even i}" by simp
  also have "\<dots> = ?r m n" (is "?l = ?r")
  proof (cases)
    assume "even m"
    hence "{i \<in> insert m {m+1..n}. even i} = insert m {i \<in> {m+1..n}. even i}" by auto
    hence "?l = card {i \<in> {m+1..n}. even i} + 1" by simp
    also have "\<dots> = (n-m + (m+2) mod 2) div 2 + 1" using Suc(1)[of n "m+1"] Suc(2) by simp
    also have "\<dots> = ?r" using \<open>even m\<close> \<open>m \<le> n\<close> by auto
    finally show ?thesis .
  next
    assume "odd m"
    hence "{i \<in> insert m {m+1..n}. even i} = {i \<in> {m+1..n}. even i}" by auto
    hence "?l = card ..." by simp
    also have "\<dots> = (n-m + (m+2) mod 2) div 2" using Suc(1)[of n "m+1"] Suc(2) by simp
    also have "\<dots> = ?r" using \<open>odd m\<close> \<open>m \<le> n\<close> even_iff_mod_2_eq_zero[of m] by simp
    finally show ?thesis .
  qed
  finally show ?case .
qed

lemma card_Icc_odd_nat: "card {i \<in> {m..n::nat}. odd i} = (n+1-m + m mod 2) div 2"
proof -
  let ?A = "{i \<in> {m..n}. odd i}"
  let ?B = "{i \<in> {m+1..n+1}. even i}"
  have "card ?A = card (Suc ` ?A)" by (simp add: card_image)
  also have "Suc ` ?A = ?B" using Suc_le_D by(force simp: image_iff)
  also have "card ?B = (n+1-m + (m) mod 2) div 2"
    using card_Icc_even_nat[of "m+1" "n+1"] by simp
  finally show ?thesis .
qed

lemma compact_Icc_even: assumes "A = {i \<in> {m..n}. even i}"
shows "A = (\<lambda>j. 2*(j-1) + m + m mod 2) ` {1..card A}" (is "_ = ?A")
proof
  let ?a = "(n+1-m + (m+1) mod 2) div 2"
  have "\<exists>j \<in> {1..?a}. i = 2*(j-1) + m + m mod 2" if *: "i \<in> {m..n}" "even i" for i
  proof -
    let ?j = "(i - (m + m mod 2)) div 2 + 1"
    have "?j \<in> {1..?a} \<and> i = 2*(?j-1) + m + m mod 2" using * by(auto simp: mod2_eq_if) presburger+
    thus ?thesis by blast
  qed
  thus "A \<subseteq> ?A" using assms
    by(auto simp: image_iff card_Icc_even_nat simp del: atLeastAtMost_iff)
next
  let ?a = "(n+1-m + (m+1) mod 2) div 2"
  have 1: "2 * (j - 1) + m + m mod 2 \<in> {m..n}" if *: "j \<in> {1..?a}" for j
    using * by(auto simp: mod2_eq_if)
  have 2: "even (2 * (j - 1) + m + m mod 2)" for j by presburger
  show "?A \<subseteq> A"
    apply(simp add: assms card_Icc_even_nat del: atLeastAtMost_iff One_nat_def)
    using 1 2 by blast
qed

lemma compact_Icc_odd:
  assumes "B = {i \<in> {m..n}. odd i}" shows "B = (\<lambda>i. 2*(i-1) + m + (m+1) mod 2) ` {1..card B}"
proof -
  define A :: " nat set" where "A = Suc ` B"
  have "A = {i \<in> {m+1..n+1}. even i}"
    using Suc_le_D by(force simp add: A_def assms image_iff)
  from compact_Icc_even[OF this]
  have "A = Suc ` (\<lambda>i. 2 * (i - 1) + m + (m + 1) mod 2) ` {1..card A}"
    by (simp add: image_comp o_def)
  hence B: "B = (\<lambda>i. 2 * (i - 1) + m + (m + 1) mod 2) ` {1..card A}"
    using A_def by (simp add: inj_image_eq_iff)
  have "card A = card B" by (metis A_def bij_betw_Suc bij_betw_same_card)
  with B show ?thesis by simp
qed

lemma even_odd_decomp: assumes "\<forall>x \<in> A. even x" "\<forall>x \<in> B. odd x"  "A \<union> B = {m..n}"
shows "(let a = card A; b = card B in
   a + b = n+1-m \<and>
   A = (\<lambda>i. 2*(i-1) + m + m mod 2) ` {1..a} \<and>
   B = (\<lambda>i. 2*(i-1) + m + (m+1) mod 2) ` {1..b} \<and>
   (a = b \<or> a = b+1 \<and> even m \<or> a+1 = b \<and> odd m))"
proof -
  let ?a = "card A" let ?b = "card B"
  have "finite A \<and> finite B"
    by (metis \<open>A \<union> B = {m..n}\<close> finite_Un finite_atLeastAtMost)
  hence ab: "?a + ?b = Suc n - m"
    by (metis Int_emptyI assms card_Un_disjoint card_atLeastAtMost)
  have A: "A = {i \<in> {m..n}. even i}" using assms by auto
  hence A': "A = (\<lambda>i. 2*(i-1) + m + m mod 2) ` {1..?a}" by(rule compact_Icc_even)
  have B: "B = {i \<in> {m..n}. odd i}" using assms by auto
  hence B': "B = (\<lambda>i. 2*(i-1) + m + (m+1) mod 2) ` {1..?b}" by(rule compact_Icc_odd)
  have "?a = ?b \<or> ?a = ?b+1 \<and> even m \<or> ?a+1 = ?b \<and> odd m"
    apply(simp add: Let_def mod2_eq_if
      card_Icc_even_nat[of m n, simplified A[symmetric]]
      card_Icc_odd_nat[of m n, simplified B[symmetric]] split!: if_splits)
    by linarith
  with ab A' B' show ?thesis by simp
qed

lemma braun_if_braun_indices: "braun_indices t = {1..size t} \<Longrightarrow> braun t"
proof(induction t)
case Leaf
  then show ?case by simp
next
  case (Node t1 x2 t2)
  have 1: "i > 0 \<Longrightarrow> Suc(Suc(2 * (i - Suc 0))) = 2*i" for i::nat by(simp add: algebra_simps)
  have 2: "i > 0 \<Longrightarrow> 2 * (i - Suc 0) + 3 = 2*i + 1" for i::nat by(simp add: algebra_simps)
  have 3: "( * ) 2 ` braun_indices t1 \<union> Suc ` ( * ) 2 ` braun_indices t2 =
     {2..size t1 + size t2 + 1}" using Node.prems
    by (simp add: insert_ident Icc_eq_insert_lb_nat nat_in_image braun_indices1)
  thus ?case using Node.IH even_odd_decomp[OF _ _ 3]
    by(simp add: card_image inj_on_def card_braun_indices Let_def 1 2 inj_image_eq_iff image_comp
           cong: image_cong_simp)
qed
*)

end


theory Exe2p11
  imports Main
begin

datatype exp = Var | Const int | Add exp exp | Mult exp exp

fun eval :: "exp \<Rightarrow> int \<Rightarrow> int" where
"eval Var i = i" |
"eval (Const i) _ = i" |
"eval (Add e1 e2) i = (eval e1 i) + (eval e2 i)" |
"eval (Mult e1 e2) i = (eval e1 i) * (eval e2 i)"

fun evalp :: "int list \<Rightarrow> int \<Rightarrow> int" where
"evalp [] x = 0" |
"evalp (h#t) x = h + (evalp t x) * x"

fun trimp :: "int list \<Rightarrow> int list" where
"trimp [] = []" |
"trimp (h#t) = (if h = 0
                then (if length (trimp t) = 0
                      then []
                      else (h#trimp t))
                else (h#trimp t))"

fun addp :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
"addp [] xs = xs" |
"addp xs [] = xs" |
"addp (h1#t1) (h2#t2) = (h1 + h2) # (addp t1 t2)"

fun multp :: "int list \<Rightarrow> int list \<Rightarrow> int list" where
"multp [] _ = []" |
"multp (h#t) l = addp (map (op * h) l) (0 # multp t l)"

fun coeffs :: "exp \<Rightarrow> int list" where
"coeffs Var = [0,1]" |
"coeffs (Const z) = [z]" |
"coeffs (Add e1 e2) = addp (coeffs e1) (coeffs e2)" |
"coeffs (Mult e1 e2) = multp (coeffs e1) (coeffs e2)"

lemma [simp]: "evalp (addp l1 l2) x = evalp l1 x + evalp l2 x"
  apply(induction l1 rule: addp.induct)
    apply(auto simp add: algebra_simps)
  done

lemma [simp]: "evalp (multp l []) x = 0"
  apply(induction l)
   apply(auto)
  done

lemma [simp]: "evalp (multp l (h # t)) x = h * evalp l x + x * (evalp (multp l t) x)"
  apply(induction l)
   apply(auto simp add: algebra_simps)
  done

lemma [simp]: "evalp (multp l1 l2) x = evalp l1 x * evalp l2 x"
  apply(induction l1 rule: multp.induct)
   apply(auto simp add: algebra_simps)
  done

lemma "evalp (coeffs e) x = eval e x"
  apply(induction e arbitrary: x)
   apply(auto simp add: algebra_simps)
  done


chapter \<open>Examples for IMP with Arrays\<close>
theory IMPAHP_Examples
imports IMPArrayHoareTotal
begin

section \<open>Program Verification\<close>

context Imp_Array_Examples begin

subsection \<open>Common Loop Patterns\<close>

subsubsection \<open>Approximate from Below\<close>
text \<open>Used to invert a monotonic function.
  We count up, until we overshoot the desired result,
  then we subtract one.
\<close>

abbreviation "sqrt_prog \<equiv>
  CLR r;;
  r ::= N 1;;
  WHILE ($r * $r <= $n) DO (
    r ::= Plus ($r) (N 1)
  );;
  r ::= Minus ($r) (N 1)
  "

text \<open>The invariant states that the \<open>r-1\<close> is not too big.
  When the loop terminates, \<open>r-1\<close> is not too big, but \<open>r\<close> is already too big,
  so \<open>r-1\<close> is the desired value (rounding down).
\<close>
definition Isqrt :: "int \<Rightarrow> int \<Rightarrow> bool"
  where "Isqrt n\<^sub>0 r \<equiv> 0\<le>r \<and> (r-1)\<^sup>2 \<le> n\<^sub>0"

text \<open>Note: Be careful to not accidentally define the invariant
  over some generic type \<open>'a\<close>! \<close>

lemma Isqrt_aux:
  "0 \<le> n\<^sub>0 \<Longrightarrow> Isqrt n\<^sub>0 1"
  "\<lbrakk>0 \<le> n\<^sub>0; r * r \<le> n\<^sub>0; Isqrt n\<^sub>0 r\<rbrakk> \<Longrightarrow> Isqrt n\<^sub>0 (r + 1)"
  "\<lbrakk>0 \<le> n\<^sub>0; \<not> r * r \<le> n\<^sub>0; Isqrt n\<^sub>0 r\<rbrakk> \<Longrightarrow> (r - 1)\<^sup>2 \<le> n\<^sub>0 \<and> n\<^sub>0 < r\<^sup>2"
  "Isqrt n\<^sub>0 r \<Longrightarrow> r * r \<le> n\<^sub>0 \<Longrightarrow> r\<le>n\<^sub>0"
  apply (auto simp: Isqrt_def power2_eq_square algebra_simps)
  by (smt combine_common_factor mult_right_mono semiring_normalization_rules(3))

find_theorems "(_(_:=_)) _"

lemma "0\<le>n\<^sub>0 \<Longrightarrow>
  \<Turnstile>\<^sub>t {vars n in n=n\<^sub>0}
      sqrt_prog
    {vars r n in n=n\<^sub>0 \<and> r\<^sup>2 \<le> n\<^sub>0 \<and> n\<^sub>0 < (r+1)\<^sup>2}"
  apply (rewrite annot_tinvar[where
    R="measure (\<lambda>s. nat (s ''n'' 0 + 1 - s ''r'' 0))" and
    I="vars r n in n=n\<^sub>0 \<and> Isqrt n\<^sub>0 r
    "])
  supply Isqrt_aux [simp]
  apply vcg
  done

subsubsection \<open>Count up\<close>

text \<open>Count up to the desired value, and iteratively compute a function on the way\<close>
abbreviation "exp_prog \<equiv>
  CLR c;; CLR r;;
  c ::= N 0;;
  r ::= N 1;;
  WHILE $c < $n DO (
    r ::= $r * $b;;
    c ::= $c + (N 1)
  )"

text \<open>The invariant states that we have computed the function for value \<open>c\<close>:\<close>

abbreviation "Iexp n\<^sub>0 b\<^sub>0 r c \<equiv> 0\<le>c \<and> c\<le>n\<^sub>0 \<and> r = b\<^sub>0 ^ nat c"

lemma "0\<le>n\<^sub>0 \<Longrightarrow>
  \<Turnstile>\<^sub>t {vars n b in n=n\<^sub>0 \<and> b=b\<^sub>0}
       exp_prog
     {vars r n b in n=n\<^sub>0 \<and> b=b\<^sub>0 \<and> r = b\<^sub>0 ^ nat n\<^sub>0}"
  apply (rewrite annot_tinvar[where
    R="measure (\<lambda>s. nat (s ''n'' 0 - s ''c'' 0))" and
    I="vars r c n b in n=n\<^sub>0 \<and> b=b\<^sub>0 \<and> Iexp n\<^sub>0 b\<^sub>0 r c"])
  supply nat_add_distrib[simp]
  apply vcg
  done

subsubsection \<open>Count down\<close>

text \<open>Essentially the same as count up, but we use the input variable as counter\<close>

abbreviation "exp_prog' \<equiv>
  CLR r;;  (* Aux variables are cleared before use. *)
  r ::= N 1;;
  WHILE N 0 < $n DO (
    r ::= $r * $b;;
    n ::= $n - N 1
  )"

text \<open>The invariant is the same as for count-up.
  Only that we have to compute the actual number
  of loop iterations by \<open>n\<^sub>0 - n\<close>
\<close>
definition exp_invar' :: "int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool"
  where "exp_invar' n\<^sub>0 b\<^sub>0 n r \<equiv> (
      let c=n\<^sub>0-n in
        0\<le>c \<and> c\<le>n\<^sub>0 \<and> r = b\<^sub>0 ^ nat c
    )"

text \<open>If the invariants become more complex or hard to prove automatically,
  it can be advantageous to define the (logical part of) the invariant as
  a predicate, and prove the required VCs as separate lemmas.
\<close>

lemma "0\<le>n\<^sub>0 \<Longrightarrow>
  \<Turnstile>\<^sub>t {vars n b in n=n\<^sub>0 \<and> b=b\<^sub>0}
       exp_prog'
    {vars r b in b=b\<^sub>0 \<and> r = (b\<^sub>0 ^ nat n\<^sub>0)}"
proof -
  note [simp] = aux1 aux2 aux3
  assume "0\<le>n\<^sub>0"
  then show ?thesis
    apply (rewrite annot_tinvar[where
      I="vars r n b in b=b\<^sub>0 \<and> exp_invar' n\<^sub>0 b\<^sub>0 n r" and
      R="measure (\<lambda>s. nat (s ''n'' 0))"
      ])
    by vcg
qed

abbreviation "sqr_prog \<equiv>
  CLR a;; CLR b;;
  b ::= \<acute>1;;
  a ::= \<acute>0;;
  WHILE (\<acute>0 < $n) DO (
    a ::= $a + $b;;
    b ::= $b + \<acute>2;;
    n ::= $n - \<acute>1
  )"

lemma "n\<^sub>0\<ge>0 \<Longrightarrow> \<Turnstile>\<^sub>t {vars n in n=n\<^sub>0} sqr_prog {vars a in a=n\<^sub>0\<^sup>2}"
  apply (rewrite annot_tinvar[where R="measure (\<lambda>s. nat (s ''n'' 0))"
        and I="vars a b n in 0\<le>n \<and> n\<le>n\<^sub>0 \<and> (let i=n\<^sub>0-n in b=2*i+1 \<and> a=i\<^sup>2)"])
  apply vcg_all
  apply (auto simp: power2_eq_square algebra_simps)
  done

abbreviation "sqr_prog' \<equiv>
  CLR a;; CLR b;; CLR c;;
  b ::= \<acute>1;;
  a ::= \<acute>0;;
  c ::= \<acute>0;;
  WHILE ($c < $n) DO (
    a ::= $a + $b;;
    b ::= $b + \<acute>2;;
    c ::= $c + \<acute>1
  )"

lemma "n\<^sub>0\<ge>0 \<Longrightarrow> \<Turnstile>\<^sub>t {vars n in n=n\<^sub>0} sqr_prog' {vars n a in n=n\<^sub>0 \<and> a=n\<^sub>0\<^sup>2}"
  apply (rewrite annot_tinvar[where R="measure (\<lambda>s. nat (s ''n'' 0 - s ''c'' 0))"
        and I="vars a b c n in n=n\<^sub>0 \<and> a=c\<^sup>2 \<and> b = 2*c+1 \<and> c\<le>n\<^sub>0"])
  apply vcg_all
  apply (auto simp: power2_eq_square algebra_simps)
  done

end

end


theory P20 imports Main begin

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

primrec preorder :: "'a tree \<Rightarrow> 'a list" where
"preorder Tip = Nil" |
"preorder (Node l x r) = x # (preorder l) @ (preorder r)"

primrec postorder :: "'a tree \<Rightarrow> 'a list" where
"postorder Tip = Nil" |
"postorder (Node l x r) = (postorder l) @ (postorder r) @ [x]"

primrec postorder_acc :: "'a tree \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"postorder_acc Tip xs = xs" |
"postorder_acc (Node l x r) xs = postorder_acc l (postorder_acc r (x # xs))"

lemma "postorder_acc t xs = (postorder t) @ xs"
  apply (induct t arbitrary: xs)
   apply auto
  done

primrec foldl_tree :: "('b => 'a => 'b) \<Rightarrow> 'b \<Rightarrow> 'a tree \<Rightarrow> 'b" where
"foldl_tree f b Tip = b" |
"foldl_tree f b (Node l x r) = foldl_tree f (foldl_tree f (f b x) r) l"

lemma "\<forall> a. postorder_acc t a = foldl_tree (\<lambda> xs x. x # xs) a t"
  apply (induct t)
   apply auto
  done

primrec tree_sum :: "nat tree \<Rightarrow> nat" where
"tree_sum Tip = 0" |
"tree_sum (Node l x r) = x + (tree_sum l) + (tree_sum r)"

primrec list_sum :: "nat list \<Rightarrow> nat" where
"list_sum Nil = 0" |
"list_sum (x # xs) = x + list_sum xs"

lemma partition_sum: "list_sum (xs @ ys) = list_sum xs + list_sum ys"
  apply (induct xs)
   apply auto
  done

lemma "tree_sum t = list_sum (preorder t)"
  apply (induct t)
   apply (auto simp add: partition_sum)
  done

end