header {*\isaheader{Specification of Annotated Lists}*}
theory AnnotatedListSpec
imports ICF_Spec_Base
begin

(*@intf AnnotatedList
  @abstype ('e \<times> 'a::monoid_add) list
  Lists with annotated elements. The annotations form a monoid, and there is
  a split operation to split the list according to its annotations. This is the
  abstract concept implemented by finger trees.
*)

subsection "Introduction"
text {*
  We define lists with annotated elements. The annotations form a monoid.

  We provide standard list operations and the split-operation, that
  splits the list according to its annotations.
*}
locale al =
  --"Annotated lists are abstracted to lists of pairs of elements and annotations."
  fixes \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes invar :: "'s \<Rightarrow> bool"

locale al_no_invar = al +
  assumes invar[simp, intro!]: "\<And>l. invar l"

subsection "Basic Annotated List Operations"

subsubsection "Empty Annotated List"
locale al_empty = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes empty :: "unit \<Rightarrow> 's"
  assumes empty_correct:
    "invar (empty ())"
    "\<alpha> (empty ()) = Nil"

subsubsection "Emptiness Check"
locale al_isEmpty = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes isEmpty :: "'s \<Rightarrow> bool"
  assumes isEmpty_correct:
    "invar s \<Longrightarrow> isEmpty s \<longleftrightarrow> \<alpha> s = Nil"

subsubsection "Counting Elements"
locale al_count = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes count :: "'s \<Rightarrow> nat"
  assumes count_correct:
    "invar s \<Longrightarrow> count s = length(\<alpha> s)"

subsubsection "Appending an Element from the Left"
locale al_consl = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes consl :: "'e \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> 's"
  assumes consl_correct:
    "invar s \<Longrightarrow> invar (consl e a s)"
    "invar s \<Longrightarrow> (\<alpha> (consl e a s)) = (e,a) # (\<alpha> s)"

subsubsection "Appending an Element from the Right"
locale al_consr = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes consr :: "'s \<Rightarrow> 'e \<Rightarrow> 'a \<Rightarrow> 's"
  assumes consr_correct:
    "invar s \<Longrightarrow> invar (consr s e a)"
    "invar s \<Longrightarrow> (\<alpha> (consr s e a)) = (\<alpha> s) @ [(e,a)]"

subsubsection "Take the First Element"
locale al_head = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes head :: "'s \<Rightarrow> ('e \<times> 'a)"
  assumes head_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> Nil\<rbrakk> \<Longrightarrow> head s = hd (\<alpha> s)"

subsubsection "Drop the First Element"
locale al_tail = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes tail :: "'s \<Rightarrow> 's"
  assumes tail_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> Nil\<rbrakk> \<Longrightarrow> \<alpha> (tail s) = tl (\<alpha> s)"
    "\<lbrakk>invar s; \<alpha> s \<noteq> Nil\<rbrakk> \<Longrightarrow> invar (tail s)"

subsubsection "Take the Last Element"
locale al_headR = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes headR :: "'s \<Rightarrow> ('e \<times> 'a)"
  assumes headR_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> Nil\<rbrakk> \<Longrightarrow> headR s = last (\<alpha> s)"

subsubsection "Drop the Last Element"
locale al_tailR = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes tailR :: "'s \<Rightarrow> 's"
  assumes tailR_correct:
    "\<lbrakk>invar s; \<alpha> s \<noteq> Nil\<rbrakk> \<Longrightarrow> \<alpha> (tailR s) = butlast (\<alpha> s)"
    "\<lbrakk>invar s; \<alpha> s \<noteq> Nil\<rbrakk> \<Longrightarrow> invar (tailR s)"

subsubsection "Fold a Function over the Elements from the Left"
locale al_foldl = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes foldl :: "('z \<Rightarrow> 'e \<times> 'a \<Rightarrow> 'z) \<Rightarrow> 'z \<Rightarrow> 's \<Rightarrow> 'z"
  assumes foldl_correct:
    "invar s \<Longrightarrow> foldl f \<sigma> s = List.foldl f \<sigma> (\<alpha> s)"

subsubsection "Fold a Function over the Elements from the Right"
locale al_foldr = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes foldr :: "('e \<times> 'a \<Rightarrow> 'z \<Rightarrow> 'z) \<Rightarrow> 's \<Rightarrow> 'z \<Rightarrow> 'z"
  assumes foldr_correct:
    "invar s \<Longrightarrow> foldr f s \<sigma> = List.foldr f (\<alpha> s) \<sigma>"

locale poly_al_fold = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
begin
  definition foldl where
    foldl_correct[code_unfold]: "foldl f \<sigma> s = List.foldl f \<sigma> (\<alpha> s)"
  definition foldr where
    foldr_correct[code_unfold]: "foldr f s \<sigma> = List.foldr f (\<alpha> s) \<sigma>"
end

subsubsection "Concatenation of Two Annotated Lists"
locale al_app = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes app :: "'s \<Rightarrow> 's \<Rightarrow> 's"
  assumes app_correct:
    "\<lbrakk>invar s;invar s'\<rbrakk> \<Longrightarrow> \<alpha> (app s s') = (\<alpha> s) @ (\<alpha> s')"
    "\<lbrakk>invar s;invar s'\<rbrakk> \<Longrightarrow> invar (app s s')"

subsubsection "Readout the Summed up Annotations"
locale al_annot = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes annot :: "'s \<Rightarrow> 'a"
  assumes annot_correct:
    "invar s \<Longrightarrow> (annot s) = (listsum (map snd (\<alpha> s)))"

subsubsection "Split by Monotone Predicate"
locale al_splits = al +
  constrains \<alpha> :: "'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  fixes splits :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow>
                                ('s \<times> ('e \<times> 'a) \<times> 's)"
  assumes splits_correct:
    "\<lbrakk>invar s;
       \<forall>a b. p a \<longrightarrow> p (a + b);
       \<not> p i;
       p (i + listsum (map snd (\<alpha> s)));
       (splits p i s) = (l, (e,a), r)\<rbrakk>
      \<Longrightarrow>
        (\<alpha> s) = (\<alpha> l) @ (e,a) # (\<alpha> r)  \<and>
        \<not> p (i + listsum (map snd (\<alpha> l)))  \<and>
        p (i + listsum (map snd (\<alpha> l)) + a)  \<and>
        invar l  \<and>
        invar r
    "
begin
  lemma splitsE:
    assumes
    invar: "invar s" and
    mono: "\<forall>a b. p a \<longrightarrow> p (a + b)" and
    init_ff: "\<not> p i" and
    sum_tt: "p (i + listsum (map snd (\<alpha> s)))"
    obtains l e a r where
    "(splits p i s) = (l, (e,a), r)"
    "(\<alpha> s) = (\<alpha> l) @ (e,a) # (\<alpha> r)"
    "\<not> p (i + listsum (map snd (\<alpha> l)))"
    "p (i + listsum (map snd (\<alpha> l)) + a)"
    "invar l"
    "invar r"
    using assms
    apply (cases "splits p i s")
    apply (case_tac b)
    apply (drule_tac i = i and p = p
      and l = a and r = c and e = aa and a = ba in  splits_correct)
    apply (simp_all)
    done
end

subsection "Record Based Interface"
record ('e,'a,'s) alist_ops =
  alist_op_\<alpha> ::"'s \<Rightarrow> ('e \<times> 'a::monoid_add) list"
  alist_op_invar :: "'s \<Rightarrow> bool"
  alist_op_empty :: "unit \<Rightarrow> 's"
  alist_op_isEmpty :: "'s \<Rightarrow> bool"
  alist_op_count :: "'s \<Rightarrow> nat"
  alist_op_consl :: "'e \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> 's"
  alist_op_consr :: "'s \<Rightarrow> 'e \<Rightarrow> 'a \<Rightarrow> 's"
  alist_op_head :: "'s \<Rightarrow> ('e \<times> 'a)"
  alist_op_tail :: "'s \<Rightarrow> 's"
  alist_op_headR :: "'s \<Rightarrow> ('e \<times> 'a)"
  alist_op_tailR :: "'s \<Rightarrow> 's"
  alist_op_app :: "'s \<Rightarrow> 's \<Rightarrow> 's"
  alist_op_annot :: "'s \<Rightarrow> 'a"
  alist_op_splits :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 's \<Rightarrow> ('s \<times> ('e \<times> 'a) \<times> 's)"

locale StdALDefs = poly_al_fold "alist_op_\<alpha> ops" "alist_op_invar ops"
  for ops :: "('e,'a::monoid_add,'s,'more) alist_ops_scheme"
begin
  abbreviation \<alpha> where "\<alpha> == alist_op_\<alpha> ops"
  abbreviation invar where "invar == alist_op_invar ops "
  abbreviation empty where "empty == alist_op_empty ops "
  abbreviation isEmpty where "isEmpty == alist_op_isEmpty ops "
  abbreviation count where "count == alist_op_count ops"
  abbreviation consl where "consl == alist_op_consl ops "
  abbreviation consr where "consr == alist_op_consr ops "
  abbreviation head where "head == alist_op_head ops "
  abbreviation tail where "tail == alist_op_tail ops "
  abbreviation headR where "headR == alist_op_headR ops "
  abbreviation tailR where "tailR == alist_op_tailR ops "
  abbreviation app where "app == alist_op_app ops "
  abbreviation annot where "annot == alist_op_annot ops "
  abbreviation splits where "splits == alist_op_splits ops "
end

locale StdAL = StdALDefs ops +
  al \<alpha> invar +
  al_empty \<alpha> invar empty +
  al_isEmpty \<alpha> invar isEmpty +
  al_count \<alpha> invar count +
  al_consl \<alpha> invar consl +
  al_consr \<alpha> invar consr +
  al_head \<alpha> invar head +
  al_tail \<alpha> invar tail +
  al_headR \<alpha> invar headR +
  al_tailR \<alpha> invar tailR +
  al_app \<alpha> invar app +
  al_annot \<alpha> invar annot +
  al_splits \<alpha> invar splits
  for ops
begin
  lemmas correct =
    empty_correct
    isEmpty_correct
    count_correct
    consl_correct
    consr_correct
    head_correct
    tail_correct
    headR_correct
    tailR_correct
    app_correct
    annot_correct
    foldl_correct
    foldr_correct
end

locale StdAL_no_invar = StdAL + al_no_invar \<alpha> invar

end


header {* Generic Computability *}

theory Computability
imports HOLCF HOLCFUtils
begin

text {*
Shivers proves the computability of the abstract semantics functions only by generic and slightly simplified example. This theory contains the abstract treatment in Section 4.4.3. Later, we will work out the details apply this to @{text \<aPR>}.
*}

subsection {* Non-branching case *}

text {*

After the following lemma (which could go into @{theory Set_Interval}), we show Shivers' Theorem 10. This says that the least fixed point of the equation
\[
f\ x = g\ x \cup f\ (r\ x)
\]
is given by
\[
f\ x = \bigcup_{i\ge 0} g\ (r^i\ x).
\]

The proof follows the standard proof of showing an equality involving a fixed point: First we show that the right hand side fulfills the above equation and then show that our solution is less than any other solution to that equation.
*}

lemma insert_greaterThan:
  "insert (n::nat) {n<..} = {n..}"
by auto

lemma theorem10:
  fixes g :: "'a::cpo \<rightarrow> 'b::type set" and r :: "'a \<rightarrow> 'a"
  shows "fix\<cdot>(\<Lambda> f x. g\<cdot>x \<union> f\<cdot>(r\<cdot>x)) = (\<Lambda> x. (\<Union>i. g\<cdot>(r\<^bsup>i\<^esup>\<cdot>x)))"
proof(induct rule:fix_eqI[OF cfun_eqI cfun_belowI, case_names fp least])
case (fp x)
  have "g\<cdot>x \<union> (\<Union>i. g\<cdot>(r\<^bsup>i\<^esup>\<cdot>(r\<cdot>x))) = g\<cdot>(r\<^bsup>0\<^esup>\<cdot>x) \<union> (\<Union>i. g\<cdot>(r\<^bsup>Suc i\<^esup>\<cdot>x))"
    by (simp add: iterate_Suc2 del: iterate_Suc)
  also have "\<dots> = g\<cdot>(r\<^bsup>0\<^esup>\<cdot>x) \<union> (\<Union>i\<in>{0<..}. g\<cdot>(r\<^bsup>i\<^esup>\<cdot>x))"
    by auto
  also have "\<dots>  = (\<Union>i\<in>insert 0 {0<..}. g\<cdot>(r\<^bsup>i\<^esup>\<cdot>x))"
    by simp
  also have "... = (\<Union>i. g\<cdot>(r\<^bsup>i\<^esup>\<cdot>x))"
    by (simp only: insert_greaterThan atLeast_0 )
  finally
  show ?case by auto
next
case (least f x)
  hence expand: "\<And>x. f\<cdot>x = (g\<cdot>x \<union> f\<cdot>(r\<cdot>x))" by (auto simp:cfun_eq_iff)
  { fix n
    have "f\<cdot>x = (\<Union>i\<in>{..n}. g\<cdot>(r\<^bsup>i\<^esup>\<cdot>x)) \<union> f\<cdot>(r\<^bsup>Suc n\<^esup>\<cdot>x)"
    proof(induct n)
      case 0 thus ?case by (auto simp add:expand[of x])
      case (Suc n)
      then have "f\<cdot>x = (\<Union>i\<in>{..n}. g\<cdot>(r\<^bsup>i\<^esup>\<cdot>x)) \<union> f\<cdot>(r\<^bsup>Suc n\<^esup>\<cdot>x)" by simp
      also have "\<dots> = (\<Union>i\<in>{..n}. g\<cdot>(r\<^bsup>i\<^esup>\<cdot>x))
                 \<union> g\<cdot>(r\<^bsup>Suc n\<^esup>\<cdot>x) \<union> f\<cdot>(r\<^bsup>Suc (Suc n)\<^esup>\<cdot>x)"
             by(subst expand[of "r\<^bsup>Suc n\<^esup>\<cdot>x"], auto)
      also have "\<dots> = (\<Union>i\<in>insert (Suc n) {..n}. g\<cdot>(r\<^bsup>i\<^esup>\<cdot>x)) \<union> f\<cdot>(r\<^bsup>Suc (Suc n)\<^esup>\<cdot>x)"
             by auto
      also have "\<dots> = (\<Union>i\<in>{..Suc n}. g\<cdot>(r\<^bsup>i\<^esup>\<cdot>x)) \<union> f\<cdot>(r\<^bsup>Suc (Suc n)\<^esup>\<cdot>x)"
             by (simp add:atMost_Suc)
      finally show ?case .
    qed
  } note fin = this
  have "(\<Union>i. g\<cdot>(r\<^bsup>i\<^esup>\<cdot>x)) \<subseteq> f\<cdot>x"
    proof(rule UN_least)
      fix i
      show "g\<cdot>(r\<^bsup>i\<^esup>\<cdot>x) \<subseteq> f\<cdot>x"
      using fin[of i] by auto
    qed
  thus ?case
    apply (subst sqsubset_is_subset) by auto
qed

subsection {* Branching case *}

text {*
Actually, our functions are more complicated than the one above: The abstract semantics functions recurse with multiple arguments. So we have to handle a recursive equation of the kind
\[
f\ x = g\ x \cup \bigcup_{a \in R\ x} f\ r.
\]
By moving to the power-set relatives of our function, e.g.
\[
{\uline g}Y = \bigcup_{a\in A} g\ a \quad \text{and} {\uline R}Y = \bigcup_{a\in R} R\ a
\]
the equation becomes
\[
{\uline f}Y ={\uline g}Y \cup {\uline f}\ ({\uline R}Y)
\]
(which is shown in Lemma 11) and we can apply Theorem 10 to obtain Theorem 12.

We define the power-set relative for a function together with some properties.
*}

definition powerset_lift :: "('a::cpo \<rightarrow> 'b::type set) \<Rightarrow> 'a set \<rightarrow> 'b set" ("\<^ps>")
  where "\<^ps>f = (\<Lambda> S. (\<Union>y\<in>S . f\<cdot>y))"

lemma powerset_lift_singleton[simp]:
  "\<^ps>f\<cdot>{x} = f\<cdot>x"
unfolding powerset_lift_def by simp

lemma powerset_lift_union[simp]:
  "\<^ps>f\<cdot>(A \<union> B) = \<^ps>f\<cdot>A \<union> \<^ps>f\<cdot>B"
unfolding powerset_lift_def by auto

lemma UNION_commute:"(\<Union>x\<in>A. \<Union>y\<in>B . P x y) = (\<Union>y\<in>B. \<Union>x\<in>A . P x y)"
  by auto

lemma powerset_lift_UNION:
  "(\<Union>x\<in>S. \<^ps>g\<cdot>(A x)) = \<^ps>g\<cdot>(\<Union>x\<in>S. A x)"
unfolding powerset_lift_def by auto

lemma powerset_lift_iterate_UNION:
  "(\<Union>x\<in>S. (\<^ps>g)\<^bsup>i\<^esup>\<cdot>(A x)) = (\<^ps>g)\<^bsup>i\<^esup>\<cdot>(\<Union>x\<in>S. A x)"
by (induct i, auto simp add:powerset_lift_UNION)

lemmas powerset_distr = powerset_lift_UNION powerset_lift_iterate_UNION

text {*
Lemma 11 shows that if a function satisfies the relation with the branching $R$, its power-set function satisfies the powerset variant of the equation.

*}

lemma lemma11:
  fixes f :: "'a \<rightarrow> 'b set" and g :: "'a \<rightarrow> 'b set" and R :: "'a \<rightarrow> 'a set"
  assumes "\<And>x. f\<cdot>x = g\<cdot>x \<union> (\<Union>y\<in>R\<cdot>x. f\<cdot>y)"
  shows "\<^ps>f\<cdot>S = \<^ps>g\<cdot>S \<union> \<^ps>f\<cdot>(\<^ps>R\<cdot>S)"
proof-
  have "\<^ps>f\<cdot>S = (\<Union>x\<in>S . f\<cdot>x)" unfolding powerset_lift_def by auto
  also have "\<dots> = (\<Union>x\<in>S . g\<cdot>x \<union> (\<Union>y\<in>R\<cdot>x. f\<cdot>y))" apply (subst assms) by simp
  also have "\<dots> = \<^ps>g\<cdot>S \<union> \<^ps>f\<cdot>(\<^ps>R\<cdot>S)" by (auto simp add:powerset_lift_def)
  finally
  show ?thesis .
qed

text {*
Theorem 10 as it will be used in Theorem 12.
*}
lemmas theorem10ps = theorem10[of "\<^ps>g" "\<^ps>r"] for g r

text {*
Now we can show Lemma 12: If $F$ is the least solution to the recursive power-set equation, then $x \mapsto F\ {x}$ is the least solution to the equation with branching $R$.

We fix the type variable @{text 'a} to be a discrete cpo, as otherwise $x \mapsto \{x\}$ is not continuous.
*}

(* discrete_cpo, otherwise x \<mapsto> {x} not continous *)
lemma theorem12':
  fixes g :: "'a::discrete_cpo \<rightarrow> 'b::type set" and R :: "'a \<rightarrow> 'a set"
  assumes F_fix: "F = fix\<cdot>(\<Lambda> F x. \<^ps>g\<cdot>x \<union> F\<cdot>(\<^ps>R\<cdot>x))"
  shows "fix\<cdot>(\<Lambda> f x. g\<cdot>x \<union> (\<Union>y\<in>R\<cdot>x. f\<cdot>y)) = (\<Lambda> x. F\<cdot>{x})"
proof(induct rule:fix_eqI[OF cfun_eqI cfun_belowI, case_names fp least])
have F_union: "F = (\<Lambda> x. \<Union>i. \<^ps>g\<cdot>((\<^ps>R)\<^bsup>i\<^esup>\<cdot>x))"
  using F_fix by(simp)(rule theorem10ps)
case (fp x)
   have "g\<cdot>x \<union> (\<Union>x'\<in>R\<cdot>x. F\<cdot>{x'}) = \<^ps>g\<cdot>{x} \<union> F\<cdot>(\<^ps>R\<cdot>{x})"
    unfolding powerset_lift_singleton
    by (auto simp add: powerset_distr UNION_commute F_union)
  also have "\<dots> = F\<cdot>{x}"
    by (subst (2) fix_eq4[OF F_fix], auto)
  finally show ?case by simp
next
case (least f' x)
  hence expand: "f' = (\<Lambda> x. g\<cdot>x \<union> (\<Union>y\<in>R\<cdot>x. f'\<cdot>y))" by simp
  have "\<^ps>f' = (\<Lambda> S. \<^ps>g\<cdot>S \<union> \<^ps>f'\<cdot>(\<^ps>R\<cdot>S))"
    by (subst expand, rule cfun_eqI, auto simp add:powerset_lift_def)
  hence "(\<Lambda> F. \<Lambda> x. \<^ps>g\<cdot>x \<union> F\<cdot>(\<^ps>R\<cdot>x))\<cdot>(\<^ps>f') = \<^ps>f'" by simp
  from fix_least[OF this] and F_fix
  have  "F \<sqsubseteq> \<^ps>f'"  by simp
  hence  "F\<cdot>{x} \<sqsubseteq> \<^ps>f'\<cdot>{x}"
    by (subst (asm)cfun_below_iff, auto simp del:powerset_lift_singleton)
  thus ?case by (auto simp add:sqsubset_is_subset)
qed

lemma theorem12:
  fixes g :: "'a::discrete_cpo \<rightarrow> 'b::type set" and R :: "'a \<rightarrow> 'a set"
  shows "fix\<cdot>(\<Lambda> f x. g\<cdot>x \<union> (\<Union>y\<in>R\<cdot>x. f\<cdot>y))\<cdot>x =  \<^ps>g\<cdot>(\<Union>i.((\<^ps>R)\<^bsup>i\<^esup>\<cdot>{x}))"
  by(subst theorem12'[OF theorem10ps[THEN sym]], auto simp add:powerset_distr)

end


section "Arithmetic and Boolean Expressions"

theory LExp imports Main begin

subsection "Arithmetic Expressions"

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

text {* A little syntax magic to write larger states compactly: *}

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

text {* \noindent
  We can now write a series of updates to the function @{text "\<lambda>x. 0"} compactly:
*}
lemma "<a := x, b := y> = (<> (a := x)) (b := (y::int))"
  by (rule refl)

lemma
  assumes "a \<noteq> b"
  shows"<a := x, b := y> = <b := (y::int), a := x>"
  using assms by auto

datatype aexp = N int | V vname | Plus aexp aexp

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
  "aval (N n) s = n" |
  "aval (V x) s = s x" |
  "aval (Plus a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s + aval a\<^sub>2 s"

text {* In  the @{term[source] "<a := b>"} syntax, variables that are not mentioned are 0 by default:
*}
value "aval (Plus (V ''x'') (N 5)) <''y'' := 7>"

value "aval (Plus (V ''x'') (N 5)) <''x'' := 7>"

  (* exercise 3.6 *)

(* The value of
Let x e\<^sub>x\<^sub>_\<^sub>i\<^sub>s e\<^sub>e\<^sub>v\<^sub>a\<^sub>l\<^sub>_\<^sub>m\<^sub>e
is: replace the value of x in the original state with e\<^sub>x\<^sub>_\<^sub>i\<^sub>s, and evaluate e\<^sub>e\<^sub>v\<^sub>a\<^sub>l\<^sub>_\<^sub>m\<^sub>e using
the new state*)
datatype lexp = Nl int | Vl vname | Plusl lexp lexp | Let vname lexp lexp

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> val" where
  "lval (Nl n) s = n" |
  "lval (Vl x) s = s x" |
  "lval (Plusl a\<^sub>1 a\<^sub>2) s = lval a\<^sub>1 s + lval a\<^sub>2 s"|
  "lval (Let x e\<^sub>x\<^sub>_\<^sub>i\<^sub>s e\<^sub>e\<^sub>v\<^sub>a\<^sub>l\<^sub>_\<^sub>m\<^sub>e) s\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r = lval e\<^sub>e\<^sub>v\<^sub>a\<^sub>l\<^sub>_\<^sub>m\<^sub>e (s\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r(x := (lval e\<^sub>x\<^sub>_\<^sub>i\<^sub>s s\<^sub>o\<^sub>u\<^sub>t\<^sub>e\<^sub>r)))"

value "aval (Plus (V ''x'') (N 5)) <''x'' := 2>"

value "lval (Let ''x'' (Plusl (Nl 1)(Nl 3)) (Plusl (Vl ''x'') (Nl 5))) <''x'' := 2>"

(* Convert every lexp into the corresponding aexp.
Let will have to be converted into a (V x). *)
fun inline :: "lexp \<Rightarrow> aexp"  where
  "inline (Nl n) = (N n)" |
 "inline (Vl x) = V x" |
 "inline (Plusl a\<^sub>1 a\<^sub>2) = Plus (inline a\<^sub>1) (inline a\<^sub>2)"|
(* Evaluate e\<^sub>e\<^sub>v\<^sub>a\<^sub>l\<^sub>_\<^sub>m\<^sub>e, with the state that x := e\<^sub>x\<^sub>_\<^sub>i\<^sub>s *)
(* The expression Let x e\<^sub>x\<^sub>_\<^sub>i\<^sub>s e\<^sub>e\<^sub>v\<^sub>a\<^sub>l\<^sub>_\<^sub>m\<^sub>e is inlined by substituting the converted form of e\<^sub>x\<^sub>_\<^sub>i\<^sub>s for x in the
converted form of e\<^sub>e\<^sub>v\<^sub>a\<^sub>l\<^sub>_\<^sub>m\<^sub>e. *)
 (* I think the problem is that lval e\<^sub>x\<^sub>_\<^sub>i\<^sub>s uses the empty state *)
 "inline (Let x e\<^sub>x\<^sub>_\<^sub>i\<^sub>s e\<^sub>e\<^sub>v\<^sub>a\<^sub>l\<^sub>_\<^sub>m\<^sub>e) = N (lval e\<^sub>e\<^sub>v\<^sub>a\<^sub>l\<^sub>_\<^sub>m\<^sub>e <x := (lval e\<^sub>x\<^sub>_\<^sub>i\<^sub>s <>)>)"

(* Prove the so-called substitution lemma that says that we can either substitute first and evaluate
afterwards or evaluate with an updated state *)
 (* lemma substitution:"aval (subst x a e) s = aval e (s(x := aval a s))" *)

theorem inline_substitution:
  (* The exercise didn't say to set s = <>, but there's no way the proof would work otherwise. I guess
it's possible I defined lval or inline incorrectly.*)
  shows "aval (inline expr) <> = lval expr <>"
  apply(induction expr arbitrary: s)
  by simp_all

    (* prove: *)
    (* lval expr2 <x1a := lval expr1 <>> = lval expr2 (s(x1a := lval expr1 s)) *)
    (* Evaluate expr1 using empty state; the variable referred to by x1a is now that N (a number).
    Evaluate expr2 with the state containing the one variable, x1a. *)
    (* Now compare the above to: *)
    (* Evaluate expr1 using state s; x1a is now that N. Evaluate expr2 using state s with x1a set as
    described. *)

    (* Obviously these are different, because s \<noteq> empty state. *)

    (* tried in vain *)
  (* apply(induction rule:inline.induct)  *)

subsection "Constant Folding"

text{* Evaluate constant subsexpressions: *}

fun asimp_const :: "aexp \<Rightarrow> aexp" where
  "asimp_const (N n) = N n" |
  "asimp_const (V x) = V x" |
  "asimp_const (Plus a\<^sub>1 a\<^sub>2) =
  (case (asimp_const a\<^sub>1, asimp_const a\<^sub>2) of
    (N n\<^sub>1, N n\<^sub>2) \<Rightarrow> N(n\<^sub>1+n\<^sub>2) |
    (b\<^sub>1,b\<^sub>2) \<Rightarrow> Plus b\<^sub>1 b\<^sub>2)"

theorem aval_asimp_const:
  "aval (asimp_const a) s = aval a s"
  apply(induction a)
    apply (auto split: aexp.split)
  done

text{* Now we also eliminate all occurrences 0 in additions. The standard
method: optimized versions of the constructors: *}

text_raw{*\snip{AExpplusdef}{0}{2}{% *}
fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
  "plus (N i\<^sub>1) (N i\<^sub>2) = N(i\<^sub>1+i\<^sub>2)" |
  "plus (N i) a = (if i=0 then a else Plus (N i) a)" |
  "plus a (N i) = (if i=0 then a else Plus a (N i))" |
  "plus a\<^sub>1 a\<^sub>2 = Plus a\<^sub>1 a\<^sub>2"
text_raw{*}%endsnip*}

lemma aval_plus[simp]:
  "aval (plus a1 a2) s = aval a1 s + aval a2 s"
  (* apply(induction a1 a2 rule: plus.induct) Original. The 'a1 a2' is extraneous. *)
  apply(induction rule: plus.induct)
    (* apply(induction a1) apply(induction a2)  Does not work*)
              apply simp_all (* just for a change from auto *)
  done

text_raw{*\snip{AExpasimpdef}{2}{0}{% *}
fun asimp :: "aexp \<Rightarrow> aexp" where
  "asimp (N n) = N n" |
  "asimp (V x) = V x" |
  "asimp (Plus a\<^sub>1 a\<^sub>2) = plus (asimp a\<^sub>1) (asimp a\<^sub>2)"
text_raw{*}%endsnip*}

text{* Note that in @{const asimp_const} the optimized constructor was
inlined. Making it a separate function @{const plus} improves modularity of
the code and the proofs. *}

value "asimp (Plus (Plus (N 0) (N 0)) (Plus (V ''x'') (N 0)))"

theorem aval_asimp[simp]:
  "aval (asimp a) s = aval a s"
  apply(induction a)
  apply simp_all
  done

(*
(* Define a substitution function
subst :: vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp
such that
subst x a e
is the result of replacing every
occurrence of variable x by a in e *)
fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
  "subst matchMe replaceWith (V vname) =
      (if matchMe = vname
      then replaceWith
      else V vname)"|
  "subst matchMe replaceWith (N n) = N n"|
  "subst matchMe replaceWith (Plus e\<^sub>1 e\<^sub>2) =
      Plus (subst matchMe replaceWith e\<^sub>1) (subst matchMe replaceWith e\<^sub>2)"

value "subst ''x'' (N 3) (Plus (V ''x'') (V ''y'')) = Plus (N 3) (V ''y'')"

(*   Prove the so-called substitution lemma that says that we can either
substitute first and evaluate afterwards or evaluate with an updated state:
aval (subst x a e) s = aval e (s(x := aval a s)). As a consequence prove
aval a1 s = aval a2 s =\<Rightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s. *)
lemma substitution:"aval (subst x a e) s = aval e (s(x := aval a s))"
  apply(induction e)
  by auto

theorem foo:
  "aval a\<^sub>1 s = aval a\<^sub>2 s
  \<Longrightarrow> aval (subst x a\<^sub>1 e) s = aval (subst x a\<^sub>2 e) s"
  apply(induction e)
  by auto *)

end


(*  Title:       Jech Exercises
    Author:      Georgy Dunaev <georgedunaev at gmail.com>, 2019
    Maintainer:  Georgy Dunaev <georgedunaev at gmail.com>
*)

section "Jech Exrecises"
theory JechExercises imports trivia
begin

text \<open>preliminaries\<close>
definition Ind :: \<open>i\<Rightarrow>o\<close>
  where Ind_def : \<open>Ind(x) == 0 \<in> x \<and> (\<forall>y\<in>x. succ(y) \<in> x)\<close>

lemma IndInf : \<open>Ind(Inf)\<close>
  by(unfold Ind_def, rule infinity)

lemma IndI :
  assumes c0 : \<open>0 \<in> x\<close>
      and cS : \<open>\<And>xa. xa \<in> x \<Longrightarrow> succ(xa) \<in> x\<close>
    shows \<open>Ind(x)\<close>
proof -
  from cS have \<open>\<And>xa. xa \<in> x \<longrightarrow> succ(xa) \<in> x\<close>
    by (rule impI)
  hence \<open>\<forall>xa. xa \<in> x \<longrightarrow> succ(xa) \<in> x\<close>
    by (rule allI)
  hence \<open>(\<forall>y\<in>x. succ(y) \<in> x)\<close>
    by (fold Ball_def)
  with c0 have \<open>0 \<in> x \<and> (\<forall>y\<in>x. succ(y) \<in> x)\<close>
    by (rule conjI)
  thus \<open>Ind(x)\<close> by (fold Ind_def)
qed

lemma IndE1 :
  assumes a:\<open>Ind(x)\<close>
  shows \<open>0 \<in> x\<close>
proof -
  from a
  have \<open>0 \<in> x \<and> (\<forall>y\<in>x. succ(y) \<in> x)\<close> by (unfold Ind_def)
  thus \<open>0 \<in> x\<close> by (rule conjunct1)
qed

lemma IndE2 :
  assumes a:\<open>Ind(x)\<close>
  shows \<open>\<forall>xa. xa \<in> x \<longrightarrow> succ(xa) \<in> x\<close>
proof -
  from a
  have \<open>0 \<in> x \<and> (\<forall>y\<in>x. succ(y) \<in> x)\<close> by (unfold Ind_def)
  hence \<open>(\<forall>y\<in>x. succ(y) \<in> x)\<close> by (rule conjunct2)
  thus \<open>\<forall>xa. xa \<in> x \<longrightarrow> succ(xa) \<in> x\<close> by (unfold Ball_def)
qed

lemma IndE2R :
  assumes \<open>Ind(x)\<close>
  shows \<open>\<And>xa. xa \<in> x \<Longrightarrow> succ(xa) \<in> x\<close>
proof -
  from \<open>Ind(x)\<close> have \<open>\<forall>xa. xa \<in> x \<longrightarrow> succ(xa) \<in> x\<close> by (rule IndE2)
  thus \<open>\<And>xa. xa \<in> x \<Longrightarrow> succ(xa) \<in> x\<close> by (rule spec[THEN impE])
qed

text \<open>ex 1.1: Verify (a, b) = (c, d) if and only if a = c and b = d.\<close>

theorem ex_1_1 : \<open><a,b> = <c,d> \<longleftrightarrow> a=c & b=d\<close>
  by (rule pair.Pair_iff)

text \<open>ex 1.2: There is no set X such that $Pow(X)\subseteq X$.\<close>
context
  fixes S
  fixes W defines W_def : \<open>W == {x\<in>S. x\<notin>x}\<close>
begin

lemma notWinW :
  assumes y : \<open>W \<in> W\<close>
  shows \<open>False\<close>
proof (rule notE[where P=\<open>W \<in> W\<close>])
  from y have \<open>W \<in> {x \<in> S . x \<notin> x}\<close> by (unfold W_def)
  then show \<open>W \<notin> W\<close> by (rule CollectD2)
next
  show \<open>W \<in> W\<close> by (rule y)
qed

theorem ex_1_2 : \<open>\<not> ( Pow(S) \<subseteq> S )\<close>
proof (rule notI)
  assume \<open>Pow(S) \<subseteq> S\<close>
  have \<open>{x \<in> S . x \<notin> x} \<subseteq> S\<close> using CollectD1 by (rule subsetI)
  hence \<open>W \<subseteq> S\<close> by (unfold W_def)
  hence \<open>W \<in> Pow(S)\<close> by (rule PowI)
  with \<open>Pow(S) \<subseteq> S\<close> have \<open>W \<in> S\<close> by (rule subsetD)
  show \<open>False\<close>
  proof (rule case_split[where P=\<open>W \<in> W\<close>])
    show \<open>W \<in> W \<Longrightarrow> False\<close> by (rule notWinW)
  next
    from \<open>W \<in> S\<close> have \<open>{x \<in> S . x \<notin> x} \<in> S\<close> by (unfold W_def) moreover
    assume \<open>W \<notin> W\<close>
    hence \<open>{x \<in> S . x \<notin> x} \<notin> {x \<in> S . x \<notin> x}\<close> by (unfold W_def)
    ultimately have \<open>{x \<in> S . x \<notin> x} \<in> {x \<in> S . x \<notin> x}\<close> by (rule CollectI)
    hence \<open>W \<in> W\<close> by (fold W_def)
    with \<open>W \<notin> W\<close>
    show \<open>False\<close> by (rule notE)
  qed
qed
end

text \<open>ex 1.3: If X is inductive, then the set $\{x \in X : x \subseteq X\}$ is inductive. Hence N is
transitive, and for each n, $n = \{m \in N : m < n\}$.\<close>
context
  fixes x
  assumes a:\<open>Ind(x)\<close>
begin
lemma subsetsu : \<open>\<And>xa. xa \<in> {y \<in> x . y \<subseteq> x} \<Longrightarrow>
          succ(xa) \<in> {y \<in> x . y \<subseteq> x}\<close>
proof -
  fix k
  assume h:\<open>k \<in> {y \<in> x . y \<subseteq> x}\<close>
  from h have h1:\<open>k \<in> x\<close> by (rule CollectD1[where A=\<open>x\<close>])
  from h have h2:\<open>k \<subseteq> x\<close> by (rule CollectD2[where P=\<open>\<lambda>w. w\<subseteq>x\<close>])
  from a and h1 have \<open>succ(k) \<in> x\<close> by (rule IndE2R)
  have \<open>\<And>xa. xa \<in> succ(k) \<Longrightarrow> xa \<in> x\<close>
  proof -
    fix xa
    assume \<open>xa \<in> succ(k)\<close>
    hence \<open>xa = k \<or> xa \<in> k\<close> by (rule SuccE)
    thus \<open>xa \<in> x\<close>
    proof (rule disjE)
      assume \<open>xa = k\<close>
      with h1 show \<open>xa \<in> x\<close> by (rule subst_elem)
    next
      assume \<open>xa \<in> k\<close>
      with h2  show \<open>xa \<in> x\<close> by (rule subsetD)
    qed
  qed
  hence \<open>succ(k) \<subseteq> x\<close> by (rule subsetI)
  with \<open>succ(k) \<in> x\<close>
  show \<open>succ(k) \<in> {y \<in> x . y \<subseteq> x}\<close> by (rule CollectI[where P=\<open>\<lambda>y. y\<subseteq>x\<close>])
qed

theorem ex1_3:
  shows \<open>Ind({y\<in>x. y\<subseteq>x})\<close>
proof -
  from a
  have \<open>0 \<in> x\<close> by (rule IndE1)
  have \<open>0 \<subseteq> x\<close> by (rule empty_subsetI)
  with \<open>0 \<in> x\<close> have d:\<open>0 \<in> {y \<in> x . y \<subseteq> x}\<close> by (rule CollectI)
  from d and subsetsu show \<open>Ind({y\<in>x. y\<subseteq>x})\<close> by (rule IndI)
qed

end

definition ClassInter :: \<open>(i\<Rightarrow>o)\<Rightarrow>(i\<Rightarrow>o)\<close>
  where ClassInter_def : \<open>ClassInter(P,x) == \<forall>y. P(y) \<longrightarrow> x\<in>y\<close>

definition Nat :: \<open>i\<Rightarrow>o\<close>
  where \<open>Nat == ClassInter(Ind)\<close>

lemma NatSubInf : \<open>\<And>x. Nat(x) \<Longrightarrow> x\<in>Inf\<close>
proof (unfold Nat_def)
  fix x
  assume p0:\<open>ClassInter(Ind, x)\<close>
  show \<open>x\<in>Inf\<close>
  proof -
    from p0 have \<open>\<forall>y. Ind(y) \<longrightarrow> x \<in> y\<close> by (unfold ClassInter_def)
    hence \<open>Ind(Inf) \<longrightarrow> x \<in> Inf\<close> by (rule spec)
    hence p3:\<open>Ind(Inf) \<Longrightarrow> x \<in> Inf\<close> by (rule mp)
    from IndInf show p4:\<open>x \<in> Inf\<close> by (rule p3)
  qed
qed

lemma NatSubInf' : \<open>\<forall>x. (Nat(x) \<longrightarrow> x\<in>Inf)\<close>
proof (rule allI)
  fix x from NatSubInf show \<open>(Nat(x) \<longrightarrow> x\<in>Inf)\<close> by (rule impI)
qed

definition IsTransClass :: \<open>(i\<Rightarrow>o)\<Rightarrow>o\<close>
  where IsTransClass_def : \<open>IsTransClass(P) == \<forall>y. P(y) \<longrightarrow> (\<forall>z. z\<in>y \<longrightarrow> P(z))\<close>

lemma Nat0 : \<open>Nat(0)\<close>
proof -
  have \<open>\<And>y. 0 \<in> y \<and> (\<forall>ya\<in>y. succ(ya) \<in> y) \<Longrightarrow> 0 \<in> y\<close> by (erule conjE)
  hence \<open>\<And>y. Ind(y) \<Longrightarrow> 0 \<in> y\<close> by (unfold Ind_def)
  hence \<open>\<And>y. Ind(y) \<longrightarrow> 0 \<in> y\<close> by (rule impI)
  hence \<open>\<forall>y. Ind(y) \<longrightarrow> 0 \<in> y\<close> by (rule allI)
  hence \<open>ClassInter(Ind, 0)\<close> by (unfold ClassInter_def)
  thus ?thesis by (unfold Nat_def)
qed

lemma NatSu:
  fixes x w
  assumes a:\<open>\<forall>y. Ind(y) \<longrightarrow> x \<in> y\<close>
  assumes b:\<open>Ind(w)\<close>
  shows \<open>succ(x) \<in> w\<close>
proof -
  from b have j:\<open>\<And>xa. xa \<in> w \<Longrightarrow> succ(xa) \<in> w\<close> by (rule IndE2R)
  from a have \<open>Ind(w) \<longrightarrow> x \<in> w\<close> by (rule spec)
  from this and b have \<open>x \<in> w\<close> by (rule mp)
  from \<open>x \<in> w\<close> show \<open>succ(x) \<in> w\<close> by (rule j)
qed

lemma NatSucc : \<open>\<forall>x. Nat(x) \<longrightarrow> Nat(succ(x))\<close>
proof (rule allI[OF impI])
  fix x
  assume \<open>Nat(x)\<close>
  hence \<open>ClassInter(Ind)(x)\<close> by (unfold Nat_def)
  hence \<open>\<forall>y. Ind(y) \<longrightarrow> x\<in>y\<close> by (unfold ClassInter_def)
  have \<open>\<forall>y. Ind(y) \<longrightarrow> succ(x)\<in>y\<close>
  proof (rule allI[OF impI])
    fix y
    assume \<open>Ind(y)\<close>
    with \<open>\<forall>y. Ind(y) \<longrightarrow> x\<in>y\<close> show \<open>succ(x)\<in>y\<close> by (rule NatSu)
  qed
  hence \<open>ClassInter(Ind)(succ(x))\<close> by (fold ClassInter_def)
  then show \<open>Nat(succ(x))\<close> by (fold Nat_def)
qed

definition IsIndClass :: \<open>(i\<Rightarrow>o)\<Rightarrow>o\<close>
  where IsIndClass_def : \<open>IsIndClass(P) == P(0) \<and> (\<forall>y. P(y) \<longrightarrow> P(succ(y)))\<close>

lemma NatIsInd : \<open>IsIndClass(Nat)\<close>
proof (unfold IsIndClass_def)
  from Nat0 and NatSucc
  show \<open>Nat(0) \<and> (\<forall>y. Nat(y) \<longrightarrow> Nat(succ(y)))\<close> by (rule conjI)
qed

definition Omega :: \<open>i\<close>
  where Omega_def : \<open>Omega == { y \<in> Inf . Nat(y) }\<close>

lemma NatSubOmega : \<open>\<And>x. Nat(x) \<Longrightarrow> x \<in> Omega\<close>
proof -
  fix x
  assume \<open>Nat(x)\<close>
  hence \<open>x \<in> Inf\<close> by (rule NatSubInf)
  from \<open>x \<in> Inf\<close> and \<open>Nat(x)\<close> have \<open>x \<in> {x\<in>Inf. Nat(x)}\<close> by (rule CollectI)
  thus \<open>x \<in> Omega\<close> by (fold Omega_def)
qed

notepad
begin
assume a: A and b: B
thm conjI
thm conjI [of A B] (*— instantiation*)
thm conjI [of A B, OF a b] (*— instantiation and composition*)
thm conjI [OF a b] (*— composition via unification (trivial)*)
(*thm conjI [OF "A" "B"]*)
thm conjI [OF disjI1]
end

(* image f of union is the union of images f *)
(* lemma image_UN: "r `` (\<Union>x\<in>A. B(x)) = (\<Union>x\<in>A. r `` B(x))" *)

lemma "r``(\<Union>A) = (\<Union>x\<in>A. r``x)"
  by blast

lemma "r``(\<Union>A) = (\<Union>x\<in>A. r``x)"
proof (rule equalityI)
  have l1:\<open>\<And>x. x \<in> r `` (\<Union>A) \<Longrightarrow>
         x \<in> (\<Union>x\<in>A. r `` x)\<close>
  proof -
    fix x
    assume a1:\<open>x \<in> r `` (\<Union>A)\<close>
    hence a2:\<open>x \<in> {y \<in> range(r) . \<exists>x\<in>\<Union>A. \<langle>x, y\<rangle> \<in> r}\<close> by (unfold image_def)
(*    from a2 have a3:\<open>x \<in> range(r)\<close> by (rule CollectE)*)
    from a2 have a4:\<open>\<exists>xa\<in>\<Union>A. \<langle>xa, x\<rangle> \<in> r\<close> by (rule CollectE)
    from a4 obtain xa where b1:"xa\<in>\<Union>A" and b2:"\<langle>xa, x\<rangle> \<in> r" by (rule bexE)
    from b1 obtain y where q1:\<open>xa\<in>y\<close> and q2:\<open>y\<in>A\<close> by (rule UnionE)
    from b2 and q1 have c1:\<open>x \<in> r `` y\<close>  by (rule imageI)
    from b2 have e1:\<open>x \<in> range(r)\<close> by (rule rangeI)
(*    from q2 and c1 show \<open>x \<in> (\<Union>x\<in>A. r `` x)\<close> by (rule UN_I)*)
    from q2 and c1 have q:\<open>x \<in> (\<Union>x\<in>A. r `` x)\<close> by (rule UN_I)
    show \<open>x \<in> (\<Union>x\<in>A. r `` x)\<close> by (rule q)
  qed
  thus \<open>r `` (\<Union>A) \<subseteq> (\<Union>x\<in>A. r `` x)\<close> by (rule subsetI)
next
  have l2:\<open>\<And>x. x \<in> (\<Union>x\<in>A. r `` x) \<Longrightarrow> x \<in> r `` (\<Union>A)\<close>
  proof -
    fix x
    assume a0:\<open>x \<in> (\<Union>x\<in>A. r `` x)\<close>
    (*! have \<open>x \<in> (\<Union>x\<in>A. r `` x)\<close> apply standard sorry !*)
    from a0 obtain B where \<open>B \<in> {r `` x . x \<in> A}\<close> and \<open>x \<in> B\<close> by standard
    (*! have \<open>B \<in> {r `` x . x \<in> A}\<close> apply standard sorry !*)
    from \<open>B \<in> {r `` x . x \<in> A}\<close> obtain g where \<open>B = r `` g\<close> and \<open>g \<in> A\<close> by standard
    from \<open>B = r `` g\<close> and \<open>x \<in> B\<close> have \<open>x \<in> r `` g\<close> by (rule subst)
(*    have  \<open>x \<in> r `` g\<close> apply standard *)
    from  \<open>x \<in> r `` g\<close> obtain aa where  "\<langle>aa, x\<rangle> \<in> r" and "aa \<in> g" by standard
    from \<open>g \<in> A\<close> and \<open>aa \<in> g\<close> have \<open>aa \<in> \<Union>A\<close> by (rule UnionI)
    from \<open>\<langle>aa, x\<rangle> \<in> r\<close> and \<open>aa \<in> \<Union>A\<close> show \<open>x \<in> r `` (\<Union>A)\<close> by standard
    (*show \<open>x \<in> r `` (\<Union>A)\<close> sorry*)
  qed
  thus \<open>(\<Union>x\<in>A. r `` x) \<subseteq> r `` (\<Union>A)\<close> by (rule subsetI)
qed

lemma Transset_trans_Memrel:
    "\<forall>j\<in>i. Transset(j) ==> trans(Memrel(i))"
  by (unfold Transset_def trans_def, blast)

(* comments:
(*
    from \<open>x \<in> \<Union>Pow(A)\<close> obtain B
      where p1:\<open>x \<in> B\<close> and p2:\<open>B \<in> Pow(A)\<close>
      by (erule UnionE)
*)
    have \<open>x \<in> {y \<in> range(r) . \<exists>x\<in>\<Union>A. \<langle>x, y\<rangle> \<in> r}\<close>
      apply (rule CollectI)
      sorry

    have \<open>x \<in> r `` (\<Union>A)\<close>
      apply (unfold image_def)
      sorry
...
    show \<open>x \<in> (\<Union>x\<in>A. r `` x)\<close>
      apply (rule UN_I)
       apply (rule q2)
      apply (rule c1)
      apply (unfold image_def)
      apply (rule CollectI)
      apply (unfold range_def)
    (*proof -
      show ?thesis by blast*)
      sorry
comments*)

(*
lemma
  fixes f A B
(*  assumes a:\<open>\<forall>y. Ind(y) \<longrightarrow> x \<in> y\<close> *)
  assumes b:\<open>Ind(w)\<close>
  shows \<open>succ(x) \<in> w\<close>
*)
(* recursion theorem *)

(*
text\<open>Cantor's theorem revisited\<close>
lemma cantor_surj: "f \<notin> surj(A,Pow(A))"
  apply (unfold surj_def, safe)
  apply (cut_tac cantor)
  apply (best del: subsetI)
  done
*)

axiomatization
  myeq :: \<open>[i\<Rightarrow>o, i\<Rightarrow>o] \<Rightarrow> o\<close>  (infixl \<open>=C\<close> 50)
where
  myrefl: \<open>a =C a\<close> and
  mysubst: \<open>a =C b \<Longrightarrow> P(a) \<Longrightarrow> P(b)\<close>

(*
axiomatization
  eq :: \<open>['a, 'a] \<Rightarrow> o\<close>  (infixl \<open>=\<close> 50)
where
  refl: \<open>a = a\<close> and
  subst: \<open>a = b \<Longrightarrow> P(a) \<Longrightarrow> P(b)\<close>
*)
(*
lemma qu:
  fixes C::\<open>i\<Rightarrow>o\<close>
  shows \<open>(=)(C,C)\<close>
*)
(*"\<lbrakk>C 0;\<And>\<alpha>. \<alpha>\<in>C\<Longrightarrow>\<alpha>+1\<in>C \<rbrakk> \<Longrightarrow> C=Ord"*)

lemma transfinite_induction111 : "\<lbrakk>0\<in>C;\<And>\<alpha>. \<alpha>\<in>C\<Longrightarrow>\<alpha>+1\<in>C \<rbrakk> \<Longrightarrow> 0\<in>C"
  apply assumption
  done

lemma transfinite_induction22 : "0\<in>C \<Longrightarrow> 0\<in>C"
  apply assumption
  done

(* untyped lambda calculus *)

(*definition
  POS  :: "[i,[i,i]\<Rightarrow>o]=>o"  where
    "POS(D,\<sqsubseteq>) == (\<forall>x\<in>D.\<sqsubseteq>(x,x))\<and>"*)

context
  fixes D::i
  (*fixes \<sqsubseteq>::[i,i]\<Rightarrow>o*)
  fixes otn::i ("\<sqsubseteq>")
  assumes reflrel:\<open>\<forall>x\<in>D. <x,y>\<in>\<sqsubseteq>\<close>
  assumes antisymrel:\<open>\<forall>x\<in>D. \<forall>y\<in>D. <x,y>\<in>\<sqsubseteq> \<and> <y,x>\<in>\<sqsubseteq> \<longrightarrow> x=y\<close>
  assumes transrel:\<open>\<forall>x\<in>D.\<forall>y\<in>D.\<forall>z\<in>D. <x,y>\<in>\<sqsubseteq> \<and> <y,z>\<in>\<sqsubseteq> \<longrightarrow> <x,z>\<in>\<sqsubseteq>\<close>
  (*assumes dpos:\<open>POS(D,\<sqsubseteq>)\<close>*)
begin
end

definition
  eqc  :: "[(i\<Rightarrow>o),(i\<Rightarrow>o)]=>o" where
    "eqc(A,B) == \<forall>x. A(x) \<longleftrightarrow> B(x)"

(* Transfinite induction. *)
lemma transfinite_induction:
  fixes C::"i\<Rightarrow>o"
  assumes c0:\<open>C(0)\<close>
  assumes cS:\<open>\<forall>x. C(x)\<longrightarrow>C(succ(x))\<close>
  assumes cL:\<open>\<forall>x. C(x)\<longrightarrow>C(succ(x))\<close>
assumes a:\<open>Ind(x)\<close>
  shows \<open>eqc(C,Ord)\<close>

  oops

end


(*  Title:      HOL/Proofs/Lambda/InductTermi.thy
    Author:     Tobias Nipkow
    Copyright   1998 TU Muenchen

Inductive characterization of terminating lambda terms.  Goes back to
Raamsdonk & Severi. On normalization. CWI TR CS-R9545, 1995.  Also
rediscovered by Matthes and Joachimski.
*)

section \<open>Inductive characterization of terminating lambda terms\<close>

theory InductTermi imports ListBeta begin

subsection \<open>Terminating lambda terms\<close>

inductive IT :: "dB => bool"
  where
    Var [intro]: "listsp IT rs ==> IT (Var n \<degree>\<degree> rs)"
  | Lambda [intro]: "IT r ==> IT (Abs r)"
  | Beta [intro]: "IT ((r[s/0]) \<degree>\<degree> ss) ==> IT s ==> IT ((Abs r \<degree> s) \<degree>\<degree> ss)"

subsection \<open>Every term in \<open>IT\<close> terminates\<close>

lemma double_induction_lemma [rule_format]:
  "termip beta s ==> \<forall>t. termip beta t -->
    (\<forall>r ss. t = r[s/0] \<degree>\<degree> ss --> termip beta (Abs r \<degree> s \<degree>\<degree> ss))"
  apply (erule accp_induct)
  apply (rule allI)
  apply (rule impI)
  apply (erule thin_rl)
  apply (erule accp_induct)
  apply clarify
  apply (rule accp.accI)
  apply (safe elim!: apps_betasE)
    apply (blast intro: subst_preserves_beta apps_preserves_beta)
   apply (blast intro: apps_preserves_beta2 subst_preserves_beta2 rtranclp_converseI
     dest: accp_downwards)  (* FIXME: acc_downwards can be replaced by acc(R ^* ) = acc(r) *)
  apply (blast dest: apps_preserves_betas)
  done

lemma IT_implies_termi: "IT t ==> termip beta t"
  apply (induct set: IT)
    apply (drule rev_predicate1D [OF _ listsp_mono [where B="termip beta"]])
    apply (fast intro!: predicate1I)
    apply (drule lists_accD)
    apply (erule accp_induct)
    apply (rule accp.accI)
    apply (blast dest: head_Var_reduction)
   apply (erule accp_induct)
   apply (rule accp.accI)
   apply blast
  apply (blast intro: double_induction_lemma)
  done

subsection \<open>Every terminating term is in \<open>IT\<close>\<close>

declare Var_apps_neq_Abs_apps [symmetric, simp]

lemma [simp, THEN not_sym, simp]: "Var n \<degree>\<degree> ss \<noteq> Abs r \<degree> s \<degree>\<degree> ts"
  by (simp add: foldl_Cons [symmetric] del: foldl_Cons)

inductive_cases [elim!]:
  "IT (Var n \<degree>\<degree> ss)"
  "IT (Abs t)"
  "IT (Abs r \<degree> s \<degree>\<degree> ts)"

theorem termi_implies_IT: "termip beta r ==> IT r"
  apply (erule accp_induct)
  apply (rename_tac r)
  apply (erule thin_rl)
  apply (erule rev_mp)
  apply simp
  apply (rule_tac t = r in Apps_dB_induct)
   apply clarify
   apply (rule IT.intros)
   apply clarify
   apply (drule bspec, assumption)
   apply (erule mp)
   apply clarify
   apply (drule_tac r=beta in conversepI)
   apply (drule_tac r="beta\<inverse>\<inverse>" in ex_step1I, assumption)
   apply clarify
   apply (rename_tac us)
   apply (erule_tac x = "Var n \<degree>\<degree> us" in allE)
   apply force
   apply (rename_tac u ts)
   apply (case_tac ts)
    apply simp
    apply blast
   apply (rename_tac s ss)
   apply simp
   apply clarify
   apply (rule IT.intros)
    apply (blast intro: apps_preserves_beta)
   apply (erule mp)
   apply clarify
   apply (rename_tac t)
   apply (erule_tac x = "Abs u \<degree> t \<degree>\<degree> ss" in allE)
   apply force
   done

end


(*  Title:      HOL/Induct/Comb.thy
    Author:     Lawrence C Paulson
    Copyright   1996  University of Cambridge
*)

section \<open>Combinatory Logic example: the Church-Rosser Theorem\<close>

theory Comb
imports Main
begin

text \<open>
  Combinator terms do not have free variables.
  Example taken from @{cite camilleri92}.
\<close>

subsection \<open>Definitions\<close>

text \<open>Datatype definition of combinators \<open>S\<close> and \<open>K\<close>.\<close>

datatype comb = K
              | S
              | Ap comb comb (infixl "\<bullet>" 90)

text \<open>
  Inductive definition of contractions, \<open>\<rightarrow>\<^sup>1\<close> and
  (multi-step) reductions, \<open>\<rightarrow>\<close>.
\<close>

inductive contract1 :: "[comb,comb] \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sup>1" 50)
  where
    K:     "K\<bullet>x\<bullet>y \<rightarrow>\<^sup>1 x"
  | S:     "S\<bullet>x\<bullet>y\<bullet>z \<rightarrow>\<^sup>1 (x\<bullet>z)\<bullet>(y\<bullet>z)"
  | Ap1:   "x \<rightarrow>\<^sup>1 y \<Longrightarrow> x\<bullet>z \<rightarrow>\<^sup>1 y\<bullet>z"
  | Ap2:   "x \<rightarrow>\<^sup>1 y \<Longrightarrow> z\<bullet>x \<rightarrow>\<^sup>1 z\<bullet>y"

abbreviation
  contract :: "[comb,comb] \<Rightarrow> bool"   (infixl "\<rightarrow>" 50) where
  "contract \<equiv> contract1\<^sup>*\<^sup>*"

text \<open>
  Inductive definition of parallel contractions, \<open>\<Rrightarrow>\<^sup>1\<close> and
  (multi-step) parallel reductions, \<open>\<Rrightarrow>\<close>.
\<close>

inductive parcontract1 :: "[comb,comb] \<Rightarrow> bool"  (infixl "\<Rrightarrow>\<^sup>1" 50)
  where
    refl:  "x \<Rrightarrow>\<^sup>1 x"
  | K:     "K\<bullet>x\<bullet>y \<Rrightarrow>\<^sup>1 x"
  | S:     "S\<bullet>x\<bullet>y\<bullet>z \<Rrightarrow>\<^sup>1 (x\<bullet>z)\<bullet>(y\<bullet>z)"
  | Ap:    "\<lbrakk>x \<Rrightarrow>\<^sup>1 y; z \<Rrightarrow>\<^sup>1 w\<rbrakk> \<Longrightarrow> x\<bullet>z \<Rrightarrow>\<^sup>1 y\<bullet>w"

abbreviation
  parcontract :: "[comb,comb] \<Rightarrow> bool"   (infixl "\<Rrightarrow>" 50) where
  "parcontract \<equiv> parcontract1\<^sup>*\<^sup>*"

text \<open>
  Misc definitions.
\<close>

definition
  I :: comb where
  "I \<equiv> S\<bullet>K\<bullet>K"

definition
  diamond   :: "([comb,comb] \<Rightarrow> bool) \<Rightarrow> bool" where
    \<comment> \<open>confluence; Lambda/Commutation treats this more abstractly\<close>
  "diamond r \<equiv> \<forall>x y. r x y \<longrightarrow>
                  (\<forall>y'. r x y' \<longrightarrow>
                    (\<exists>z. r y z \<and> r y' z))"

subsection \<open>Reflexive/Transitive closure preserves Church-Rosser property\<close>

text\<open>Remark: So does the Transitive closure, with a similar proof\<close>

text\<open>Strip lemma.
   The induction hypothesis covers all but the last diamond of the strip.\<close>
lemma strip_lemma [rule_format]:
  assumes "diamond r" and r: "r\<^sup>*\<^sup>* x y" "r x y'"
  shows "\<exists>z. r\<^sup>*\<^sup>* y' z \<and> r y z"
  using r
proof (induction rule: rtranclp_induct)
  case base
  then show ?case
    by blast
next
  case (step y z)
  then show ?case
    using \<open>diamond r\<close> unfolding diamond_def
    by (metis rtranclp.rtrancl_into_rtrancl)
qed

proposition diamond_rtrancl:
  assumes "diamond r"
  shows "diamond(r\<^sup>*\<^sup>*)"
  unfolding diamond_def
proof (intro strip)
  fix x y y'
  assume "r\<^sup>*\<^sup>* x y" "r\<^sup>*\<^sup>* x y'"
  then show "\<exists>z. r\<^sup>*\<^sup>* y z \<and> r\<^sup>*\<^sup>* y' z"
  proof (induction rule: rtranclp_induct)
    case base
    then show ?case
      by blast
  next
    case (step y z)
    then show ?case
      by (meson assms strip_lemma rtranclp.rtrancl_into_rtrancl)
  qed
qed

subsection \<open>Non-contraction results\<close>

text \<open>Derive a case for each combinator constructor.\<close>

inductive_cases
  K_contractE [elim!]: "K \<rightarrow>\<^sup>1 r"
  and S_contractE [elim!]: "S \<rightarrow>\<^sup>1 r"
  and Ap_contractE [elim!]: "p\<bullet>q \<rightarrow>\<^sup>1 r"

declare contract1.K [intro!] contract1.S [intro!]
declare contract1.Ap1 [intro] contract1.Ap2 [intro]

lemma I_contract_E [iff]: "\<not> I \<rightarrow>\<^sup>1 z"
  unfolding I_def by blast

lemma K1_contractD [elim!]: "K\<bullet>x \<rightarrow>\<^sup>1 z \<Longrightarrow> (\<exists>x'. z = K\<bullet>x' \<and> x \<rightarrow>\<^sup>1 x')"
  by blast

lemma Ap_reduce1 [intro]: "x \<rightarrow> y \<Longrightarrow> x\<bullet>z \<rightarrow> y\<bullet>z"
  by (induction rule: rtranclp_induct; blast intro: rtranclp_trans)

lemma Ap_reduce2 [intro]: "x \<rightarrow> y \<Longrightarrow> z\<bullet>x \<rightarrow> z\<bullet>y"
  by (induction rule: rtranclp_induct; blast intro: rtranclp_trans)

text \<open>Counterexample to the diamond property for \<^term>\<open>x \<rightarrow>\<^sup>1 y\<close>\<close>

lemma not_diamond_contract: "\<not> diamond(contract1)"
  unfolding diamond_def by (metis S_contractE contract1.K)

subsection \<open>Results about Parallel Contraction\<close>

text \<open>Derive a case for each combinator constructor.\<close>

inductive_cases
      K_parcontractE [elim!]: "K \<Rrightarrow>\<^sup>1 r"
  and S_parcontractE [elim!]: "S \<Rrightarrow>\<^sup>1 r"
  and Ap_parcontractE [elim!]: "p\<bullet>q \<Rrightarrow>\<^sup>1 r"

declare parcontract1.intros [intro]

subsection \<open>Basic properties of parallel contraction\<close>
text\<open>The rules below are not essential but make proofs much faster\<close>

lemma K1_parcontractD [dest!]: "K\<bullet>x \<Rrightarrow>\<^sup>1 z \<Longrightarrow> (\<exists>x'. z = K\<bullet>x' \<and> x \<Rrightarrow>\<^sup>1 x')"
  by blast

lemma S1_parcontractD [dest!]: "S\<bullet>x \<Rrightarrow>\<^sup>1 z \<Longrightarrow> (\<exists>x'. z = S\<bullet>x' \<and> x \<Rrightarrow>\<^sup>1 x')"
  by blast

lemma S2_parcontractD [dest!]: "S\<bullet>x\<bullet>y \<Rrightarrow>\<^sup>1 z \<Longrightarrow> (\<exists>x' y'. z = S\<bullet>x'\<bullet>y' \<and> x \<Rrightarrow>\<^sup>1 x' \<and> y \<Rrightarrow>\<^sup>1 y')"
  by blast

text\<open>Church-Rosser property for parallel contraction\<close>
proposition diamond_parcontract: "diamond parcontract1"
proof -
  have "(\<exists>z. w \<Rrightarrow>\<^sup>1 z \<and> y' \<Rrightarrow>\<^sup>1 z)" if "y \<Rrightarrow>\<^sup>1 w" "y \<Rrightarrow>\<^sup>1 y'" for w y y'
    using that by (induction arbitrary: y' rule: parcontract1.induct) fast+
  then show ?thesis
    by (auto simp: diamond_def)
qed

subsection \<open>Equivalence of \<^prop>\<open>p \<rightarrow> q\<close> and \<^prop>\<open>p \<Rrightarrow> q\<close>.\<close>

lemma contract_imp_parcontract: "x \<rightarrow>\<^sup>1 y \<Longrightarrow> x \<Rrightarrow>\<^sup>1 y"
  by (induction rule: contract1.induct; blast)

text\<open>Reductions: simply throw together reflexivity, transitivity and
  the one-step reductions\<close>

proposition reduce_I: "I\<bullet>x \<rightarrow> x"
  unfolding I_def
  by (meson contract1.K contract1.S r_into_rtranclp rtranclp.rtrancl_into_rtrancl)

lemma parcontract_imp_reduce: "x \<Rrightarrow>\<^sup>1 y \<Longrightarrow> x \<rightarrow> y"
proof (induction rule: parcontract1.induct)
  case (Ap x y z w)
  then show ?case
    by (meson Ap_reduce1 Ap_reduce2 rtranclp_trans)
qed auto

lemma reduce_eq_parreduce: "x \<rightarrow> y  \<longleftrightarrow>  x \<Rrightarrow> y"
  by (metis contract_imp_parcontract parcontract_imp_reduce predicate2I rtranclp_subset)

theorem diamond_reduce: "diamond(contract)"
  using diamond_parcontract diamond_rtrancl reduce_eq_parreduce by presburger

end


section \<open>Enumerating the SCCs of a Graph \label{sec:scc}\<close>
theory Gabow_SCC
imports Gabow_Skeleton
begin

text \<open>
  As a first variant, we implement an algorithm that computes a list of SCCs
  of a graph, in topological order. This is the standard variant described by
  Gabow~\cite{Gabow2000}.
\<close>

section \<open>Specification\<close>
context fr_graph
begin
  text \<open>We specify a distinct list that covers all reachable nodes and
    contains SCCs in topological order\<close>

  definition "compute_SCC_spec \<equiv> SPEC (\<lambda>l.
    distinct l \<and> \<Union>(set l) = E\<^sup>*``V0 \<and> (\<forall>U\<in>set l. is_scc E U)
    \<and> (\<forall>i j. i<j \<and> j<length l \<longrightarrow> l!j \<times> l!i \<inter> E\<^sup>* = {}) )"
end

section \<open>Extended Invariant\<close>

locale cscc_invar_ext = fr_graph G
  for G :: "('v,'more) graph_rec_scheme" +
  fixes l :: "'v set list" and D :: "'v set"
  assumes l_is_D: "\<Union>(set l) = D" \<comment> \<open>The output contains all done CNodes\<close>
  assumes l_scc: "set l \<subseteq> Collect (is_scc E)" \<comment> \<open>The output contains only SCCs\<close>
  assumes l_no_fwd: "\<And>i j. \<lbrakk>i<j; j<length l\<rbrakk> \<Longrightarrow> l!j \<times> l!i \<inter> E\<^sup>* = {}"
    \<comment> \<open>The output contains no forward edges\<close>
begin
  lemma l_no_empty: "{}\<notin>set l" using l_scc by (auto simp: in_set_conv_decomp)
end

locale cscc_outer_invar_loc = outer_invar_loc G it D + cscc_invar_ext G l D
  for G :: "('v,'more) graph_rec_scheme" and it l D
begin
  lemma locale_this: "cscc_outer_invar_loc G it l D" by unfold_locales
  lemma abs_outer_this: "outer_invar_loc G it D" by unfold_locales
end

locale cscc_invar_loc = invar_loc G v0 D0 p D pE + cscc_invar_ext G l D
  for G :: "('v,'more) graph_rec_scheme" and v0 D0 and l :: "'v set list"
  and p D pE
begin
  lemma locale_this: "cscc_invar_loc G v0 D0 l p D pE" by unfold_locales
  lemma invar_this: "invar_loc G v0 D0 p D pE" by unfold_locales
end

context fr_graph
begin
  definition "cscc_outer_invar \<equiv> \<lambda>it (l,D). cscc_outer_invar_loc G it l D"
  definition "cscc_invar \<equiv> \<lambda>v0 D0 (l,p,D,pE). cscc_invar_loc G v0 D0 l p D pE"
end

section \<open>Definition of the SCC-Algorithm\<close>

context fr_graph
begin
  definition compute_SCC :: "'v set list nres" where
    "compute_SCC \<equiv> do {
      let so = ([],{});
      (l,D) \<leftarrow> FOREACHi cscc_outer_invar V0 (\<lambda>v0 (l,D0). do {
        if v0\<notin>D0 then do {
          let s = (l,initial v0 D0);

          (l,p,D,pE) \<leftarrow>
          WHILEIT (cscc_invar v0 D0)
            (\<lambda>(l,p,D,pE). p \<noteq> []) (\<lambda>(l,p,D,pE).
          do {
            \<comment> \<open>Select edge from end of path\<close>
            (vo,(p,D,pE)) \<leftarrow> select_edge (p,D,pE);

            ASSERT (p\<noteq>[]);
            case vo of
              Some v \<Rightarrow> do {
                if v \<in> \<Union>(set p) then do {
                  \<comment> \<open>Collapse\<close>
                  RETURN (l,collapse v (p,D,pE))
                } else if v\<notin>D then do {
                  \<comment> \<open>Edge to new node. Append to path\<close>
                  RETURN (l,push v (p,D,pE))
                } else RETURN (l,p,D,pE)
              }
            | None \<Rightarrow> do {
                \<comment> \<open>No more outgoing edges from current node on path\<close>
                ASSERT (pE \<inter> last p \<times> UNIV = {});
                let V = last p;
                let (p,D,pE) = pop (p,D,pE);
                let l = V#l;
                RETURN (l,p,D,pE)
              }
          }) s;
          ASSERT (p=[] \<and> pE={});
          RETURN (l,D)
        } else
          RETURN (l,D0)
      }) so;
      RETURN l
    }"
end

section \<open>Preservation of Invariant Extension\<close>
context cscc_invar_ext
begin
  lemma l_disjoint:
    assumes A: "i<j" "j<length l"
    shows "l!i \<inter> l!j = {}"
  proof (rule disjointI)
    fix u
    assume "u\<in>l!i" "u\<in>l!j"
    with l_no_fwd A show False by auto
  qed

  corollary l_distinct: "distinct l"
    using l_disjoint l_no_empty
    by (metis distinct_conv_nth inf_idem linorder_cases nth_mem)
end

context fr_graph
begin
  definition "cscc_invar_part \<equiv> \<lambda>(l,p,D,pE). cscc_invar_ext G l D"

  lemma cscc_invarI[intro?]:
    assumes "invar v0 D0 PDPE"
    assumes "invar v0 D0 PDPE \<Longrightarrow> cscc_invar_part (l,PDPE)"
    shows "cscc_invar v0 D0 (l,PDPE)"
    using assms
    unfolding initial_def cscc_invar_def invar_def
    apply (simp split: prod.split_asm)
    apply intro_locales
    apply (simp add: invar_loc_def)
    apply (simp add: cscc_invar_part_def cscc_invar_ext_def)
    done

  thm cscc_invarI[of v_0 D_0 s l]

  lemma cscc_outer_invarI[intro?]:
    assumes "outer_invar it D"
    assumes "outer_invar it D \<Longrightarrow> cscc_invar_ext G l D"
    shows "cscc_outer_invar it (l,D)"
    using assms
    unfolding initial_def cscc_outer_invar_def outer_invar_def
    apply (simp split: prod.split_asm)
    apply intro_locales
    apply (simp add: outer_invar_loc_def)
    apply (simp add: cscc_invar_ext_def)
    done

  lemma cscc_invar_initial[simp, intro!]:
    assumes A: "v0\<in>it" "v0\<notin>D0"
    assumes INV: "cscc_outer_invar it (l,D0)"
    shows "cscc_invar_part (l,initial v0 D0)"
  proof -
    from INV interpret cscc_outer_invar_loc G it l D0
      unfolding cscc_outer_invar_def by simp

    show ?thesis
      unfolding cscc_invar_part_def initial_def
      apply simp
      by unfold_locales
  qed

  lemma cscc_invar_pop:
    assumes INV: "cscc_invar v0 D0 (l,p,D,pE)"
    assumes "invar v0 D0 (pop (p,D,pE))"
    assumes NE[simp]: "p\<noteq>[]"
    assumes NO': "pE \<inter> (last p \<times> UNIV) = {}"
    shows "cscc_invar_part (last p # l, pop (p,D,pE))"
  proof -
    from INV interpret cscc_invar_loc G v0 D0 l p D pE
      unfolding cscc_invar_def by simp

    have AUX_l_scc: "is_scc E (last p)"
      unfolding is_scc_pointwise
    proof safe
      {
        assume "last p = {}" thus False
          using p_no_empty by (cases p rule: rev_cases) auto
      }

      fix u v
      assume "u\<in>last p" "v\<in>last p"
      with p_sc[of "last p"] have "(u,v) \<in> (lvE \<inter> last p \<times> last p)\<^sup>*" by auto
      with lvE_ss_E show "(u,v)\<in>(E \<inter> last p \<times> last p)\<^sup>*"
        by (metis Int_mono equalityE rtrancl_mono_mp)

      fix u'
      assume "u'\<notin>last p" "(u,u')\<in>E\<^sup>*" "(u',v)\<in>E\<^sup>*"

      from \<open>u'\<notin>last p\<close> \<open>u\<in>last p\<close> \<open>(u,u')\<in>E\<^sup>*\<close>
        and rtrancl_reachable_induct[OF order_refl lastp_un_D_closed[OF NE NO']]
      have "u'\<in>D" by auto
      with \<open>(u',v)\<in>E\<^sup>*\<close> and rtrancl_reachable_induct[OF order_refl D_closed]
      have "v\<in>D" by auto
      with \<open>v\<in>last p\<close> p_not_D show False by (cases p rule: rev_cases) auto
    qed

    {
      fix i j
      assume A: "i<j" "j<Suc (length l)"
      have "l ! (j - Suc 0) \<times> (last p # l) ! i \<inter> E\<^sup>* = {}"
      proof (rule disjointI, safe)
        fix u v
        assume "(u, v) \<in> E\<^sup>*" "u \<in> l ! (j - Suc 0)" "v \<in> (last p # l) ! i"
        from \<open>u \<in> l ! (j - Suc 0)\<close> A have "u\<in>\<Union>(set l)"
          by (metis Ex_list_of_length Suc_pred UnionI length_greater_0_conv
            less_nat_zero_code not_less_eq nth_mem)
        with l_is_D have "u\<in>D" by simp
        with rtrancl_reachable_induct[OF order_refl D_closed] \<open>(u,v)\<in>E\<^sup>*\<close>
        have "v\<in>D" by auto

        show False proof cases
          assume "i=0" hence "v\<in>last p" using \<open>v \<in> (last p # l) ! i\<close> by simp
          with p_not_D \<open>v\<in>D\<close> show False by (cases p rule: rev_cases) auto
        next
          assume "i\<noteq>0" with \<open>v \<in> (last p # l) ! i\<close> have "v\<in>l!(i - 1)" by auto
          with l_no_fwd[of "i - 1" "j - 1"]
            and \<open>u \<in> l ! (j - Suc 0)\<close> \<open>(u, v) \<in> E\<^sup>*\<close> \<open>i\<noteq>0\<close> A
          show False by fastforce
        qed
      qed
    } note AUX_l_no_fwd = this

    show ?thesis
      unfolding cscc_invar_part_def pop_def apply simp
      apply unfold_locales
      apply clarsimp_all
      using l_is_D apply auto []

      using l_scc AUX_l_scc apply auto []

      apply (rule AUX_l_no_fwd, assumption+) []
      done
  qed

  thm cscc_invar_pop[of v_0 D_0 l p D pE]

  lemma cscc_invar_unchanged:
    assumes INV: "cscc_invar v0 D0 (l,p,D,pE)"
    shows "cscc_invar_part (l,p',D,pE')"
    using INV unfolding cscc_invar_def cscc_invar_part_def cscc_invar_loc_def
    by simp

  corollary cscc_invar_collapse:
    assumes INV: "cscc_invar v0 D0 (l,p,D,pE)"
    shows "cscc_invar_part (l,collapse v (p',D,pE'))"
    unfolding collapse_def
    by (simp add: cscc_invar_unchanged[OF INV])

  corollary cscc_invar_push:
    assumes INV: "cscc_invar v0 D0 (l,p,D,pE)"
    shows "cscc_invar_part (l,push v (p',D,pE'))"
    unfolding push_def
    by (simp add: cscc_invar_unchanged[OF INV])

  lemma cscc_outer_invar_initial: "cscc_invar_ext G [] {}"
    by unfold_locales auto

  lemma cscc_invar_outer_newnode:
    assumes A: "v0\<notin>D0" "v0\<in>it"
    assumes OINV: "cscc_outer_invar it (l,D0)"
    assumes INV: "cscc_invar v0 D0 (l',[],D',pE)"
    shows "cscc_invar_ext G l' D'"
  proof -
    from OINV interpret cscc_outer_invar_loc G it l D0
      unfolding cscc_outer_invar_def by simp
    from INV interpret inv: cscc_invar_loc G v0 D0 l' "[]" D' pE
      unfolding cscc_invar_def by simp

    show ?thesis
      by unfold_locales

  qed

  lemma cscc_invar_outer_Dnode:
    assumes "cscc_outer_invar it (l, D)"
    shows "cscc_invar_ext G l D"
    using assms
    by (simp add: cscc_outer_invar_def cscc_outer_invar_loc_def)

  lemmas cscc_invar_preserve = invar_preserve
    cscc_invar_initial
    cscc_invar_pop cscc_invar_collapse cscc_invar_push cscc_invar_unchanged
    cscc_outer_invar_initial cscc_invar_outer_newnode cscc_invar_outer_Dnode

  text \<open>On termination, the invariant implies the specification\<close>
  lemma cscc_finI:
    assumes INV: "cscc_outer_invar {} (l,D)"
    shows fin_l_is_scc: "\<lbrakk>U\<in>set l\<rbrakk> \<Longrightarrow> is_scc E U"
    and fin_l_distinct: "distinct l"
    and fin_l_is_reachable: "\<Union>(set l) = E\<^sup>* `` V0"
    and fin_l_no_fwd: "\<lbrakk>i<j; j<length l\<rbrakk> \<Longrightarrow> l!j \<times>l!i \<inter> E\<^sup>* = {}"
  proof -
    from INV interpret cscc_outer_invar_loc G "{}" l D
      unfolding cscc_outer_invar_def by simp

    show "\<lbrakk>U\<in>set l\<rbrakk> \<Longrightarrow> is_scc E U" using l_scc by auto

    show "distinct l" by (rule l_distinct)

    show "\<Union>(set l) = E\<^sup>* `` V0"
      using fin_outer_D_is_reachable[OF outer_invar_this] l_is_D
      by auto

    show "\<lbrakk>i<j; j<length l\<rbrakk> \<Longrightarrow> l!j \<times>l!i \<inter> E\<^sup>* = {}"
      by (rule l_no_fwd)

  qed

end

section \<open>Main Correctness Proof\<close>

context fr_graph
begin
  lemma invar_from_cscc_invarI: "cscc_invar v0 D0 (L,PDPE) \<Longrightarrow> invar v0 D0 PDPE"
    unfolding cscc_invar_def invar_def
    apply (simp split: prod.splits)
    unfolding cscc_invar_loc_def by simp

  lemma outer_invar_from_cscc_invarI:
    "cscc_outer_invar it (L,D) \<Longrightarrow>outer_invar it D"
    unfolding cscc_outer_invar_def outer_invar_def
    apply (simp split: prod.splits)
    unfolding cscc_outer_invar_loc_def by simp

  text \<open>With the extended invariant and the auxiliary lemmas, the actual
    correctness proof is straightforward:\<close>
  theorem compute_SCC_correct: "compute_SCC \<le> compute_SCC_spec"
  proof -
    note [[goals_limit = 2]]
    note [simp del] = Union_iff

    show ?thesis
      unfolding compute_SCC_def compute_SCC_spec_def select_edge_def select_def
      apply (refine_rcg
        WHILEIT_rule[where R="inv_image (abs_wf_rel v0) snd" for v0]
        refine_vcg
      )

      apply (vc_solve
        rec: cscc_invarI cscc_outer_invarI
        solve: cscc_invar_preserve cscc_finI
        intro: invar_from_cscc_invarI outer_invar_from_cscc_invarI
        dest!: sym[of "pop A" for A]
        simp: pE_fin'[OF invar_from_cscc_invarI] finite_V0
      )
      apply auto
      done
  qed

  text \<open>Simple proof, for presentation\<close>
  context
    notes [refine]=refine_vcg
    notes [[goals_limit = 1]]
  begin
    theorem "compute_SCC \<le> compute_SCC_spec"
      unfolding compute_SCC_def compute_SCC_spec_def select_edge_def select_def
      by (refine_rcg
        WHILEIT_rule[where R="inv_image (abs_wf_rel v0) snd" for v0])
      (vc_solve
        rec: cscc_invarI cscc_outer_invarI solve: cscc_invar_preserve cscc_finI
        intro: invar_from_cscc_invarI outer_invar_from_cscc_invarI
        dest!: sym[of "pop A" for A]
        simp: pE_fin'[OF invar_from_cscc_invarI] finite_V0, auto)
  end

end

section \<open>Refinement to Gabow's Data Structure\<close>

context GS begin
  definition "seg_set_impl l u \<equiv> do {
    (_,res) \<leftarrow> WHILET
      (\<lambda>(l,_). l<u)
      (\<lambda>(l,res). do {
        ASSERT (l<length S);
        let x = S!l;
        ASSERT (x\<notin>res);
        RETURN (Suc l,insert x res)
      })
      (l,{});

    RETURN res
  }"

    apply (auto simp: less_Suc_eq nth_eq_iff_index_eq)
    done

  lemma (in GS_invar) seg_set_impl_correct:
    assumes "i<length B"
    shows "seg_set_impl (seg_start i) (seg_end i) \<le> SPEC (\<lambda>r. r=p_\<alpha>!i)"
    apply (refine_rcg order_trans[OF seg_set_impl_aux] refine_vcg)

    using assms
    apply (simp_all add: seg_start_less_end seg_end_bound S_distinct) [3]

    apply (auto simp: p_\<alpha>_def assms seg_def) []
    done

  definition "last_seg_impl
    \<equiv> do {
      ASSERT (length B - 1 < length B);
      seg_set_impl (seg_start (length B - 1)) (seg_end (length B - 1))
    }"

  lemma (in GS_invar) last_seg_impl_correct:
    assumes "p_\<alpha> \<noteq> []"
    shows "last_seg_impl \<le> SPEC (\<lambda>r. r=last p_\<alpha>)"
    unfolding last_seg_impl_def
    apply (refine_rcg order_trans[OF seg_set_impl_correct] refine_vcg)
    using assms apply (auto simp add: p_\<alpha>_def last_conv_nth)
    done

end

context fr_graph
begin

  definition "last_seg_impl s \<equiv> GS.last_seg_impl s"
  lemmas last_seg_impl_def_opt =
    last_seg_impl_def[abs_def, THEN opt_GSdef,
      unfolded GS.last_seg_impl_def GS.seg_set_impl_def
    GS.seg_start_def GS.seg_end_def GS_sel_simps]
    (* TODO: Some potential for optimization here: the assertion
      guarantees that length B - 1 + 1 = length B !*)

  lemma last_seg_impl_refine:
    assumes A: "(s,(p,D,pE))\<in>GS_rel"
    assumes NE: "p\<noteq>[]"
    shows "last_seg_impl s \<le> \<Down>Id (RETURN (last p))"
  proof -
    from A have
      [simp]: "p=GS.p_\<alpha> s \<and> D=GS.D_\<alpha> s \<and> pE=GS.pE_\<alpha> s"
        and INV: "GS_invar s"
      by (auto simp add: GS_rel_def br_def GS_\<alpha>_split)

    show ?thesis
      unfolding last_seg_impl_def[abs_def]
      apply (rule order_trans[OF GS_invar.last_seg_impl_correct])
      using INV NE
      apply (simp_all)
      done
  qed

  definition compute_SCC_impl :: "'v set list nres" where
    "compute_SCC_impl \<equiv> do {
      stat_start_nres;
      let so = ([],Map.empty);
      (l,D) \<leftarrow> FOREACHi (\<lambda>it (l,s). cscc_outer_invar it (l,oGS_\<alpha> s))
        V0 (\<lambda>v0 (l,I0). do {
          if \<not>is_done_oimpl v0 I0 then do {
            let ls = (l,initial_impl v0 I0);

            (l,(S,B,I,P))\<leftarrow>WHILEIT (\<lambda>(l,s). cscc_invar v0 (oGS_\<alpha> I0) (l,GS.\<alpha> s))
              (\<lambda>(l,s). \<not>path_is_empty_impl s) (\<lambda>(l,s).
            do {
              \<comment> \<open>Select edge from end of path\<close>
              (vo,s) \<leftarrow> select_edge_impl s;

              case vo of
                Some v \<Rightarrow> do {
                  if is_on_stack_impl v s then do {
                    s\<leftarrow>collapse_impl v s;
                    RETURN (l,s)
                  } else if \<not>is_done_impl v s then do {
                    \<comment> \<open>Edge to new node. Append to path\<close>
                    RETURN (l,push_impl v s)
                  } else do {
                    \<comment> \<open>Edge to done node. Skip\<close>
                    RETURN (l,s)
                  }
                }
              | None \<Rightarrow> do {
                  \<comment> \<open>No more outgoing edges from current node on path\<close>
                  scc \<leftarrow> last_seg_impl s;
                  s\<leftarrow>pop_impl s;
                  let l = scc#l;
                  RETURN (l,s)
                }
            }) (ls);
            RETURN (l,I)
          } else RETURN (l,I0)
      }) so;
      stat_stop_nres;
      RETURN l
    }"

  lemma compute_SCC_impl_refine: "compute_SCC_impl \<le> \<Down>Id compute_SCC"
  proof -
    note [refine2] = bind_Let_refine2[OF last_seg_impl_refine]

    have [refine2]: "\<And>s' p D pE l' l v' v. \<lbrakk>
      (s',(p,D,pE))\<in>GS_rel;
      (l',l)\<in>Id;
      (v',v)\<in>Id;
      v\<in>\<Union>(set p)
    \<rbrakk> \<Longrightarrow> do { s'\<leftarrow>collapse_impl v' s'; RETURN (l',s') }
      \<le> \<Down>(Id \<times>\<^sub>r GS_rel) (RETURN (l,collapse v (p,D,pE)))"
      apply (refine_rcg order_trans[OF collapse_refine] refine_vcg)
      apply assumption+
      apply (auto simp add: pw_le_iff refine_pw_simps)
      done

    note [[goals_limit = 1]]
    show ?thesis
      unfolding compute_SCC_impl_def compute_SCC_def
      apply (refine_rcg
        bind_refine'
        select_edge_refine push_refine
        pop_refine
        (*collapse_refine*)
        initial_refine
        oinitial_refine
        (*last_seg_impl_refine*)
        prod_relI IdI
        inj_on_id
      )

      apply refine_dref_type
      apply (vc_solve (nopre) solve: asm_rl I_to_outer
        simp: GS_rel_def br_def GS.\<alpha>_def oGS_rel_def oGS_\<alpha>_def
        is_on_stack_refine path_is_empty_refine is_done_refine is_done_orefine
      )

      done
  qed

end

end


(*  Title:      FOL/ex/Propositional_Cla.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section {* First-Order Logic: propositional examples (classical version) *}

theory Propositional_Cla
imports FOL
begin

text {* commutative laws of @{text "&"} and @{text "|"} *}

lemma "P & Q  -->  Q & P"
  by (tactic "IntPr.fast_tac @{context} 1")

lemma "P | Q  -->  Q | P"
  by fast

text {* associative laws of @{text "&"} and @{text "|"} *}
lemma "(P & Q) & R  -->  P & (Q & R)"
  by fast

lemma "(P | Q) | R  -->  P | (Q | R)"
  by fast

text {* distributive laws of @{text "&"} and @{text "|"} *}
lemma "(P & Q) | R  --> (P | R) & (Q | R)"
  by fast

lemma "(P | R) & (Q | R)  --> (P & Q) | R"
  by fast

lemma "(P | Q) & R  --> (P & R) | (Q & R)"
  by fast

lemma "(P & R) | (Q & R)  --> (P | Q) & R"
  by fast

text {* Laws involving implication *}

lemma "(P-->R) & (Q-->R) <-> (P|Q --> R)"
  by fast

lemma "(P & Q --> R) <-> (P--> (Q-->R))"
  by fast

lemma "((P-->R)-->R) --> ((Q-->R)-->R) --> (P&Q-->R) --> R"
  by fast

lemma "~(P-->R) --> ~(Q-->R) --> ~(P&Q-->R)"
  by fast

lemma "(P --> Q & R) <-> (P-->Q)  &  (P-->R)"
  by fast

text {* Propositions-as-types *}

-- {* The combinator K *}
lemma "P --> (Q --> P)"
  by fast

-- {* The combinator S *}
lemma "(P-->Q-->R)  --> (P-->Q) --> (P-->R)"
  by fast

-- {* Converse is classical *}
lemma "(P-->Q) | (P-->R)  -->  (P --> Q | R)"
  by fast

lemma "(P-->Q)  -->  (~Q --> ~P)"
  by fast

text {* Schwichtenberg's examples (via T. Nipkow) *}

lemma stab_imp: "(((Q-->R)-->R)-->Q) --> (((P-->Q)-->R)-->R)-->P-->Q"
  by fast

lemma stab_to_peirce:
  "(((P --> R) --> R) --> P) --> (((Q --> R) --> R) --> Q)
                              --> ((P --> Q) --> P) --> P"
  by fast

lemma peirce_imp1: "(((Q --> R) --> Q) --> Q)
                --> (((P --> Q) --> R) --> P --> Q) --> P --> Q"
  by fast

lemma peirce_imp2: "(((P --> R) --> P) --> P) --> ((P --> Q --> R) --> P) --> P"
  by fast

lemma mints: "((((P --> Q) --> P) --> P) --> Q) --> Q"
  by fast

lemma mints_solovev: "(P --> (Q --> R) --> Q) --> ((P --> Q) --> R) --> R"
  by fast

lemma tatsuta: "(((P7 --> P1) --> P10) --> P4 --> P5)
  --> (((P8 --> P2) --> P9) --> P3 --> P10)
  --> (P1 --> P8) --> P6 --> P7
  --> (((P3 --> P2) --> P9) --> P4)
  --> (P1 --> P3) --> (((P6 --> P1) --> P2) --> P9) --> P5"
  by fast

lemma tatsuta1: "(((P8 --> P2) --> P9) --> P3 --> P10)
  --> (((P3 --> P2) --> P9) --> P4)
  --> (((P6 --> P1) --> P2) --> P9)
  --> (((P7 --> P1) --> P10) --> P4 --> P5)
  --> (P1 --> P3) --> (P1 --> P8) --> P6 --> P7 --> P5"
  by fast

end


theory Teoreme_Kompleksnih
  imports Complex_Main
begin

definition "ccsqrt z = rcis (sqrt (cmod z)) (arg z / 2)"

(*ideja se oslanja na osobinu da su dva kompleksna broja jednaka ako su
im jednaki realni deo i imaginarni deo*)
lemma square_ccsqrt [simp]:
  shows "(ccsqrt x)\<^sup>2 = x"
proof
  show "Re ((ccsqrt x)\<^sup>2) = Re x"
  proof-
    have "Re ((ccsqrt x)\<^sup>2) = Re (ccsqrt x * ccsqrt x)"
      by (simp add: power2_eq_square)
    also have "... = Re ((rcis (sqrt (cmod x)) (arg x / 2)) * (rcis (sqrt (cmod x)) (arg x / 2)))"
      using ccsqrt_def by presburger
    also have "... = Re (rcis (sqrt (cmod x) * sqrt (cmod x)) (arg x / 2 + arg x / 2))"
      using rcis_mult by presburger
    also have "... = Re (rcis (cmod x) (arg x))"
      by (metis abs_norm_cancel field_sum_of_halves real_sqrt_mult_self)
    also have "... = Re x"
      using rcis_cmod_arg by presburger
    finally show ?thesis .
  qed
next
  show "Im ((ccsqrt x)\<^sup>2) = Im x"
  proof-
    have "Im ((ccsqrt x)\<^sup>2) = Im (ccsqrt x * ccsqrt x)"
      by (simp add: power2_eq_square)
    also have "... = Im ((rcis (sqrt (cmod x)) (arg x / 2)) * (rcis (sqrt (cmod x)) (arg x / 2)))"
      using ccsqrt_def by presburger
    also have "... = Im (rcis (sqrt (cmod x) * sqrt (cmod x)) (arg x / 2 + arg x / 2))"
      using rcis_mult by presburger
    also have "... = Im (rcis (cmod x) (arg x))"
      by (metis abs_norm_cancel field_sum_of_halves real_sqrt_mult_self)
    also have "... = Im x"
      using rcis_cmod_arg by presburger
    finally show ?thesis .
  qed
qed
(*ista ideja se primenjuje i ovde*)
lemma ex_complex_sqrt [simp]:
  shows "\<exists> s::complex. s*s = z"
  apply (rule_tac x = "ccsqrt z" in exI)
proof
  show "Re (ccsqrt z * ccsqrt z) = Re z"
  proof-
    have "Re (ccsqrt z * ccsqrt z) = Re ((rcis (sqrt (cmod z)) (arg z / 2)) * (rcis (sqrt (cmod z)) (arg z / 2)))"
      using ccsqrt_def by presburger
    also have "... = Re (rcis (sqrt (cmod z) * sqrt (cmod z)) (arg z /2 + arg z / 2))"
      using rcis_mult by presburger
    also have "... = Re (rcis (cmod z) (arg z))"
    by (metis ccsqrt_def power2_eq_square rcis_cmod_arg rcis_mult square_ccsqrt)
  also have "... = Re z"
    using rcis_cmod_arg by presburger
  finally show ?thesis .
  qed
next
  show "Im (ccsqrt z * ccsqrt z) = Im z"
  proof-
    have "Im (ccsqrt z * ccsqrt z) = Im ((rcis (sqrt (cmod z)) (arg z / 2)) * (rcis (sqrt (cmod z)) (arg z / 2)))"
      using ccsqrt_def by presburger
    also have "... = Im (rcis (sqrt (cmod z) * sqrt (cmod z)) (arg z /2 + arg z / 2))"
      using rcis_mult by presburger
    also have "... = Im (rcis (cmod z) (arg z))"
    by (metis ccsqrt_def power2_eq_square rcis_cmod_arg rcis_mult square_ccsqrt)
  also have "... = Im z"
    using rcis_cmod_arg by presburger
  finally show ?thesis .
  qed
qed

lemma ccsqrt [simp]:
  assumes "s*s = z"
  shows "s = ccsqrt z \<or> s = -ccsqrt z"
proof-
  have "s\<^sup>2 = s*s"
    by (simp add: power2_eq_square)
  then have "... = z"
    using assms
    by simp
  then have "... = ccsqrt z * ccsqrt z"
    by (metis power2_eq_square square_ccsqrt)
  then have "... = (ccsqrt z)\<^sup>2"
    by auto
  then have "s\<^sup>2 = (ccsqrt z)\<^sup>2"
    using \<open>s\<^sup>2 = s * s\<close> assms by auto
  then have "s = ccsqrt z \<or> s = -ccsqrt z"
    using power2_eq_iff by blast
  then show ?thesis.
qed

lemma ccsqrt_mult [simp]:
  shows  "ccsqrt (a*b) = ccsqrt a * ccsqrt b \<or> ccsqrt (a*b) = - ccsqrt a * ccsqrt b"
proof -
  have "(ccsqrt (a*b))^2 = a*b"
  by simp
  then have "a * b = (ccsqrt a * ccsqrt a) * (ccsqrt b * ccsqrt b)"
    by (metis power2_eq_square square_ccsqrt)
  then have "... = (ccsqrt a * ccsqrt b)*(ccsqrt a * ccsqrt b)"
    by simp
  then have "... = (ccsqrt a * ccsqrt b)^2"
    by (simp add: semiring_normalization_rules(29))
  then have "(ccsqrt (a*b))\<^sup>2 = (ccsqrt a * ccsqrt b)\<^sup>2"
  by (simp add: \<open>a * b = ccsqrt a * ccsqrt a * (ccsqrt b * ccsqrt b)\<close> \<open>ccsqrt a * ccsqrt a * (ccsqrt b * ccsqrt b) = ccsqrt a * ccsqrt b * (ccsqrt a * ccsqrt b)\<close>)
  then have "ccsqrt (a*b) = ccsqrt a * ccsqrt b \<or> ccsqrt (a*b) = - ccsqrt a * ccsqrt b"
    using power2_eq_iff by fastforce
  then show ?thesis.
qed

(*neke pomocne leme za resavanje izraza*)
lemma pomocna [simp]:
  fixes a b :: complex
  shows "(a/b)\<^sup>2 = a\<^sup>2 / b\<^sup>2"
  by (simp add: power_divide)

lemma pomocna1 [simp]:
  fixes a b ::complex
  shows "(a - b)\<^sup>2 = a\<^sup>2 - 2*a*b + b\<^sup>2"
  by (simp add: power2_diff)

lemma pomocna2 [simp]:
  fixes a b::complex
  shows "(a*b\<^sup>2)/(4*a\<^sup>2) = b\<^sup>2 / (4*a) "
  by (simp add: power2_eq_square)

lemma pomocna3 [simp]:
  fixes a b c::complex
  shows "(a*2*b*c) / (4*a\<^sup>2) = (b*c) / (2*a)"
proof-
  have "(a*2*b*c) / (4*a\<^sup>2) = (2*a*b*c) / (4*a\<^sup>2)"
    by auto
  also have "... = (2*a)*(b*c) / (2*a)\<^sup>2"
    by auto
  finally show ?thesis
    by (simp add: power2_eq_square)
qed

lemma pomocna4 [simp]:
  fixes a b::complex
  assumes "a\<noteq>0"
  shows " - (4*a*b) / (4*a) = -b"
  using assms by auto

lemma pomocna5 [simp]:
  fixes a b:: complex
  shows "(-a+b)\<^sup>2 = a\<^sup>2 - 2*a*b + b\<^sup>2"
  by auto

lemma pomocna6 [simp]:
  fixes a b::complex
  shows "(-a-b)\<^sup>2 = a\<^sup>2 + 2*a*b + b\<^sup>2"
  by simp

(*dodala sam pretpostavku da je a razlicito od nule kako bi moglo da se deli sa a*)
lemma quadratic_equation:
  fixes a b c x :: complex
  assumes "a \<noteq> 0"
  shows "a*x\<^sup>2+b*x+c=0 \<longleftrightarrow> x = (-b + ccsqrt (b\<^sup>2-4*a*c)) / (2*a) \<or> x = (-b - ccsqrt (b\<^sup>2 - 4*a*c)) / (2*a)"
proof
  assume "x = (- b + ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) \<or> x = (- b - ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a)"
  show "a*x\<^sup>2 + b*x+c=0"
  proof-
    have "a*x\<^sup>2 + b*x+c=a* ((- b + ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a))\<^sup>2 + b * ((- b + ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a)) + c   \<or> a*x\<^sup>2 + b*x+c= a* ((- b - ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a))\<^sup>2 + b * ((- b - ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a)) + c "
      using \<open>x = (- b + ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) \<or> x = (- b - ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a)\<close> by blast
    then have "a*x\<^sup>2 + b*x+c = a * ((- b + ccsqrt (b\<^sup>2 - 4 * a * c))\<^sup>2 / (2*a)\<^sup>2) +  b * ((- b + ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a)) + c \<or> a*x\<^sup>2 + b*x+c = a* ((- b - ccsqrt (b\<^sup>2 - 4 * a * c))\<^sup>2 / (2 * a)\<^sup>2) + b * ((- b - ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a)) + c "
      by simp
    then have "a*x\<^sup>2 + b*x+c = a * ((- b + ccsqrt (b\<^sup>2 - 4 * a * c))\<^sup>2 / (2*a)\<^sup>2) +  (b*(- b + ccsqrt (b\<^sup>2 - 4 * a * c))) / (2 * a) + c \<or> a*x\<^sup>2 + b*x+c=a * ((- b - ccsqrt (b\<^sup>2 - 4 * a * c))\<^sup>2 / (2*a)\<^sup>2) +  (b*(- b - ccsqrt (b\<^sup>2 - 4 * a * c))) / (2 * a) + c "
      by simp
    then have "a*x\<^sup>2 + b*x+c = a * ((b\<^sup>2-2*b*(ccsqrt (b\<^sup>2 - 4 * a * c)) + (ccsqrt (b\<^sup>2 - 4 * a * c))\<^sup>2) / (4*a\<^sup>2)) +  (b*(- b + ccsqrt (b\<^sup>2 - 4 * a * c))) / (2 * a) + c \<or> a*x\<^sup>2 + b*x+c=a * ((b\<^sup>2 + 2*b*(ccsqrt (b\<^sup>2 - 4 * a * c)) + (ccsqrt (b\<^sup>2 - 4 * a * c))\<^sup>2)/(4*a\<^sup>2)) +  (b*(- b - ccsqrt (b\<^sup>2 - 4 * a * c))) / (2 * a) + c "
      by auto
    then have "a*x\<^sup>2 + b*x+c = a * ((b\<^sup>2-2*b*(ccsqrt (b\<^sup>2 - 4 * a * c)) + (b\<^sup>2 - 4 * a * c)) / (4*a\<^sup>2)) +  (-b\<^sup>2 + b*ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) + c \<or> a*x\<^sup>2 + b*x+c=a * ((b\<^sup>2 + 2*b*(ccsqrt (b\<^sup>2 - 4 * a * c)) + (b\<^sup>2 - 4 * a * c))/(4*a\<^sup>2)) +  (- b\<^sup>2 - b*ccsqrt (b\<^sup>2 - 4 * a * c)) / (2 * a) + c "
      by (smt diff_0 mult_zero_right power2_eq_square right_diff_distrib square_ccsqrt uminus_add_conv_diff)
    then have "a*x\<^sup>2 + b*x+c = ((b\<^sup>2-2*b*(ccsqrt (b\<^sup>2 - 4 * a * c)) + (b\<^sup>2 - 4 * a * c)) / (4*a)) -b\<^sup>2/(2*a) + b*ccsqrt (b\<^sup>2 - 4 * a * c) / (2 * a) + c \<or> a*x\<^sup>2 + b*x+c=((b\<^sup>2 + 2*b*(ccsqrt (b\<^sup>2 - 4 * a * c)) + (b\<^sup>2 - 4 * a * c))/(4*a)) - b\<^sup>2/(2*a) - b*ccsqrt (b\<^sup>2 - 4 * a * c) / (2 * a) + c"
    by (smt ab_group_add_class.ab_diff_conv_add_uminus add.assoc add_divide_distrib minus_divide_left pomocna2 pomocna5 pomocna6 square_ccsqrt times_divide_eq_right)
  then have "a*x\<^sup>2 + b*x+c = b\<^sup>2 / (4*a)-2*b*(ccsqrt (b\<^sup>2 - 4 * a * c))/(4*a) + b\<^sup>2/(4*a) - (4 * a * c) / (4*a) -b\<^sup>2/(2*a) + b*ccsqrt (b\<^sup>2 - 4 * a * c) / (2 * a) + c \<or> a*x\<^sup>2 + b*x+c=b\<^sup>2/(4*a) + 2*b*(ccsqrt (b\<^sup>2 - 4 * a * c))/(4*a) + b\<^sup>2/(4*a) - (4 * a * c)/(4*a) - b\<^sup>2/(2*a) - b*ccsqrt (b\<^sup>2 - 4 * a * c) / (2 * a) + c"
    by (simp add: add_divide_distrib diff_divide_distrib)
  then have  "a*x\<^sup>2 + b*x+c = b\<^sup>2 / (4*a)-b*(ccsqrt (b\<^sup>2 - 4 * a * c))/(2*a) + b\<^sup>2/(4*a) - c -b\<^sup>2/(2*a) + b*ccsqrt (b\<^sup>2 - 4 * a * c) / (2 * a) + c \<or> a*x\<^sup>2 + b*x+c=b\<^sup>2/(4*a) + b*(ccsqrt (b\<^sup>2 - 4 * a * c))/(2*a) + b\<^sup>2/(4*a) - c - b\<^sup>2/(2*a) - b*ccsqrt (b\<^sup>2 - 4 * a * c) / (2 * a) + c"
    using assms by auto
  then have "a*x\<^sup>2 + b*x+c = b\<^sup>2 / (4*a) + b\<^sup>2/(4*a)  -b\<^sup>2/(2*a)  \<or> a*x\<^sup>2 + b*x+c=b\<^sup>2/(4*a)  + b\<^sup>2/(4*a) - b\<^sup>2/(2*a)"
    by simp
  then have "a*x\<^sup>2 + b*x+c = 2*b\<^sup>2 / (4*a)   -b\<^sup>2/(2*a)  \<or> a*x\<^sup>2 + b*x+c=2*b\<^sup>2/(4*a) - b\<^sup>2/(2*a)"
    by auto
  then have "a*x\<^sup>2 + b*x+c = b\<^sup>2 / (2*a)   -b\<^sup>2/(2*a)  \<or> a*x\<^sup>2 + b*x+c=b\<^sup>2/(2*a) - b\<^sup>2/(2*a)"
    by auto
  then have "a*x\<^sup>2 + b*x+c = 0  \<or> a*x\<^sup>2 + b*x+c=0"
    by simp
  then show ?thesis
    by blast
qed
next
  assume "a * x\<^sup>2 + b * x + c = 0 "
  show "x = (- b + ccsqrt (b\<^sup>2 - 4 * a * c)) / (2*a) \<or> x = (- b - ccsqrt (b\<^sup>2 - 4 * a * c)) / (2*a)"
  proof-
    have "a*x\<^sup>2+b*x+c = 0 \<longleftrightarrow> 4*a*(a*x\<^sup>2+b*x+c) = 0"
      by (simp add: \<open>a * x\<^sup>2 + b * x + c = 0\<close>)
    also have "4*a*(a*x\<^sup>2+b*x+c) = 4*a\<^sup>2*x\<^sup>2 +4*a*b*x + 4*a*c + b\<^sup>2 -b\<^sup>2"
      by (simp add: distrib_left power2_eq_square)
    also have "... = (2*a*x+b)\<^sup>2 -b\<^sup>2+4*a*c"
    by (smt add_diff_cancel_right' mult_2_right numeral_Bit0 power2_eq_square power2_sum semiring_normalization_rules(16) semiring_normalization_rules(18) semiring_normalization_rules(23))
  also have "(2*a*x+b)\<^sup>2 - b\<^sup>2 + 4*a*c=0"
    using \<open>a * x\<^sup>2 + b * x + c = 0\<close> calculation by blast
  also have "(2*a*x+b)\<^sup>2 = b\<^sup>2 - 4*a*c"
    by (metis \<open>(2 * a * x + b)\<^sup>2 - b\<^sup>2 + 4 * a * c = 0\<close> add_diff_cancel diff_0 diff_add_cancel uminus_add_conv_diff)
  then have "2*a*x+b = ccsqrt (b\<^sup>2 - 4*a*c) \<or> 2*a*x + b = -ccsqrt (b\<^sup>2 - 4*a*c)"
    by (metis \<open>(2 * a * x + b)\<^sup>2 = b\<^sup>2 - 4 * a * c\<close> ccsqrt power2_eq_square)
  then have "2*a*x = -b + ccsqrt (b\<^sup>2 - 4*a*c) \<or> 2*a*x = -b-ccsqrt (b\<^sup>2 - 4*a*c)"
    by (smt \<open>2 * a * x + b = ccsqrt (b\<^sup>2 - 4 * a * c) \<or> 2 * a * x + b = - ccsqrt (b\<^sup>2 - 4 * a * c)\<close> diff_minus_eq_add eq_diff_eq uminus_add_conv_diff)
  then have "x = (-b+ccsqrt (b\<^sup>2 - 4*a*c)) / (2*a) \<or> x = (-b - ccsqrt (b\<^sup>2 - 4*a*c))/ (2*a)"
    by (metis assms divisors_zero nonzero_mult_div_cancel_left zero_neq_numeral)
  thus ?thesis .
  qed
qed
end


theory a2
imports Main
begin

section "Part 1"

datatype condition =
  Above nat nat | Joinable nat nat

inductive_set connection :: "condition set \<Rightarrow> condition set"
  for A :: "condition set" where
  con_refl:
    "Above a a \<in> connection A"
| con_in:
    "\<phi> \<in> A \<Longrightarrow> \<phi> \<in> connection A"
| con_mirror:
    "Joinable a b \<in> connection A
     \<Longrightarrow> Joinable b a \<in> connection A"
| con_trans:
    "\<lbrakk>Above a b \<in> connection A;
      Above b c \<in> connection A\<rbrakk>
     \<Longrightarrow> Above a c \<in> connection A"
| con_join:
    "\<lbrakk>Above a b \<in> connection A;
      Above c b \<in> connection A\<rbrakk>
     \<Longrightarrow> Joinable a c \<in> connection A"
| con_ext_join:
    "\<lbrakk>Above a b \<in> connection A;
      Joinable b c \<in> connection A\<rbrakk>
     \<Longrightarrow> Joinable a c \<in> connection A"

print_theorems

primrec is_refl :: "_" where
  "is_refl(Above a b) = (a = b)"
| "is_refl(Joinable a b) = (a = b)"

section "Question 1 (a)"

(*4 is router1 5 is router2*)
definition example_network where
"example_network = {
Above 1 4 , Above 2 4, Above 2 5 , Above 3 5
}"  (* TODO *)

lemma "Joinable 1 2 \<in> connection example_network"
  apply (unfold example_network_def)
  apply (rule_tac b=4 in con_join)
   apply (rule con_in)
   apply (blast)
  apply (simp add:con_in)
  done

subsection "Questions 1 (b)-(j)"

(* 1-b *)
lemma connection_monotonic:
  assumes "\<phi> \<in> connection A"
  shows   "\<phi> \<in> connection(A \<union> B)"
  using assms
  apply (induct rule:connection.induct)
       apply (auto intro:connection.intros)
  done

lemma connection_mono :
  "connection (connection A) \<subseteq> connection A"
  apply (safe)
  apply (erule connection.induct)
  apply (simp_all add: connection.intros)
  done

(* 1-c *)
lemma connection_idem:
  shows "connection(connection A) = connection A"
  apply (rule equalityI)
  apply (simp add:  connection_mono)
  apply (auto intro:connection.intros)
  done

(* 1-d *)
lemma connection_decompose:
  assumes "\<phi> \<in> connection(A \<union> B)"
  shows   "\<exists>C D. C \<subseteq> connection A \<and>
                 D \<subseteq> connection B \<and>
                 \<phi> \<in> connection(C \<union> D)"
  using assms
  apply -
  apply (simp add: connection.induct)
  apply (auto intro:connection.intros)
  done

(* 1-e *)
lemma connection_nil:
  assumes "\<phi> \<in> connection {}"
  shows "is_refl \<phi>"
  (* TODO *)
  using assms
  apply (induct \<phi>)
   apply (simp_all)
  done

(* 1-f *)
lemma con_is_refl:
  assumes "is_refl \<phi>"
  shows "\<phi> \<in> connection A"
  (* TODO *)
  using assms
  apply -
  apply (induct)
   apply (simp_all add: connection.inducts)
  apply (auto intro:connection.intros)
  done

(* 1-g *)
lemma refl_wont_loss: "is_refl x \<Longrightarrow> x \<in> connection A"
  apply induct
  apply (auto intro: connection_nil con_is_refl)
  done

lemma connection_filter_refl:
  assumes "\<phi> \<in> connection A"
  shows "\<phi> \<in> connection(A - {\<phi>. is_refl \<phi>})"
  using assms
  using refl_wont_loss
  apply induct
  apply (simp_all add:connection.intros)
  by (metis DiffI connection.con_in mem_Collect_eq)

(* 1-h *)
lemma not_refl_wont_derive_nil:
  "\<And>a b . a \<noteq> b \<Longrightarrow> Above a b \<notin> connection {} "
  apply safe
  using connection.inducts
  using connection_nil
  using is_refl.simps(1) by blast

lemma not_refl_wont_derive_no_reason:
  "\<lbrakk>a \<noteq> b; Above a b \<notin> A; Above a c \<in> A \<and> Above c b \<in> A \<rbrakk> \<Longrightarrow> Above a b \<in> connection A"
  using connection.con_in connection.con_trans
  by blast

lemma no_above_from_join_lemma_gen:
  "\<forall> x \<in> A. x = Above c c \<Longrightarrow> Above a b \<in> connection A \<Longrightarrow> a = b"
  using connection_idem connection_monotonic not_refl_wont_derive_nil refl_wont_loss
  using le_iff_sup subsetI
  by (metis is_refl.simps(1))

lemma refl_derive_no_reson_2:
  "\<And>a b. Above a b \<notin> A \<Longrightarrow> Above a a \<in> connection A \<and> Above b b \<in> connection A"
  using connection.intros
  by blast

lemma
  "\<And>a b c. \<lbrakk>a \<noteq> b; a \<noteq> c; Above a c \<notin> connection A ; Above c b \<notin> connection A\<rbrakk> \<Longrightarrow> Above a b \<notin> connection A"
  apply (case_tac "c = b")
   apply simp
  oops

lemma must_be_above_or_joinable:
  " x \<in> A \<Longrightarrow>\<exists> a b. x = Joinable a b \<or> x = Above a b"
  using condition.exhaust by blast

lemma no_joinable_from_join_lemma_gen:
  "\<forall> x \<in> A. x = Joinable c d \<Longrightarrow> Above a b \<in> connection A \<Longrightarrow> a = b"
  using connection.intros
  using connection.inducts
  sorry

lemma have_not_have_able_only_joinable:
 " x \<in> A\<Longrightarrow> \<lbrakk>\<And>a b. Above a b \<notin> A\<rbrakk> \<Longrightarrow>  x = Joinable c d"

  sorry

lemma no_above_from_join_lemma:
  assumes "Above a b \<in> connection A"
  and "\<And>a b. Above a b \<notin> A"
  shows "a = b"
  using assms
  using no_joinable_from_join_lemma_gen
  using have_not_have_able_only_joinable
  by meson

(* 1-i *)
lemma "\<lbrakk> x \<in> C \<union> D ;C \<subseteq> A ; D \<subseteq> B \<rbrakk> \<Longrightarrow> x \<in> A \<union> B"
  by blast

lemma connections_idem_simp: "x \<in> connection (connection C) \<Longrightarrow> x \<in> connection C"
  using connection_idem
  by blast

lemma connection_subset_simp: "x \<in> connection A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> x \<in> connection B"
  by (metis connection_monotonic le_iff_sup)

lemma connection_subset_con_simp: "x \<in> connection A \<Longrightarrow> A \<subseteq> connection B \<Longrightarrow> x \<in> connection B"
  using connections_idem_simp connection_subset_simp
  by blast

lemma connection_union_subset:
  "\<lbrakk>A\<subseteq>C; B\<subseteq>D \<rbrakk> \<Longrightarrow> connection(A\<union> B) \<subseteq> connection (C\<union> D)"
  by (meson Un_mono connection_subset_simp subset_eq)

lemma connection_union_simp:
  "connection(connection A \<union> connection B) = connection(A \<union> B)"
  apply safe
  using connection_union_subset connection_subset_con_simp
  apply (metis (no_types, lifting) sup.bounded_iff sup.idem sup_ge2)
  using connection_decompose connection_union_subset by blast

lemma connection_compose:
  assumes "\<phi> \<in> connection(C \<union> D)"
  and     "C \<subseteq> connection A"
  and     "D \<subseteq> connection B"
  shows   "\<phi> \<in> connection(A \<union> B)"
  using assms
  using connection_union_subset connection_subset_con_simp connection_union_simp
  by (smt connection_idem)

(* 1-j *)
lemma connection_compositional:
  assumes "connection A = connection B"
  shows   "connection(A \<union> C) = connection(B \<union> C)"
  using assms
  using connection_compose
  by (metis connection_union_simp)

section "Part 2"

datatype process =
  Cond condition
  | Par process process
  | Input nat process
  | Output nat process
  | Nil

datatype action =
  LInput nat | LOutput nat | LTau

primrec frame :: "process \<Rightarrow> condition set" where
  "frame Nil = {}"
| "frame(Cond \<phi>) = {\<phi>}"
| "frame(Par P Q) = frame P \<union> frame Q"
| "frame(Input \<phi> P) = {}"
| "frame(Output \<phi> P) = {}"

inductive semantics :: "condition set \<Rightarrow> process \<Rightarrow> action \<Rightarrow> process \<Rightarrow> bool"
  where
  semantics_input:
     "semantics A (Input n P) (LInput n) P"
| semantics_output:
    "semantics A (Output n P) (LOutput n) P"
| semantics_par_l:
    "semantics (A \<union> frame Q) P \<alpha> P'
     \<Longrightarrow> semantics A (Par P Q) \<alpha> (Par P' Q)"
| semantics_par_r:
    "semantics (A \<union> frame P) Q \<alpha> Q'
     \<Longrightarrow> semantics A (Par P Q) \<alpha> (Par P Q')"
| semantics_com_l:
    "\<lbrakk>semantics (A \<union> frame Q) P (LOutput n) P';
      semantics (A \<union> frame P) Q (LInput m) Q';
      Joinable n m \<in> connection(A \<union> frame P \<union> frame Q)\<rbrakk>
     \<Longrightarrow> semantics A (Par P Q) LTau (Par P' Q')"
| semantics_com_r:
    "\<lbrakk>semantics (A \<union> frame Q) P (LInput n) P';
      semantics (A \<union> frame P) Q (LOutput m) Q';
      Joinable n m \<in> connection(A \<union> frame P \<union> frame Q)\<rbrakk>
     \<Longrightarrow> semantics A (Par P Q) LTau (Par P' Q')"

inductive_cases
  par: "semantics A (Par P Q) x R" and
  nil: "semantics A Nil x R" and
  cond: "semantics A (Cond cond) x R"

subsection "Questions 2 (a)-(c)"

(* 2-a *)
lemma semantics_monotonic:
  assumes "semantics A P \<alpha> Q"
  shows "semantics (A \<union> B) P \<alpha> Q"
  using assms
  apply induct
       apply (simp_all add:semantics.intros sup_assoc sup_commute  sup_left_commute)
   apply (smt Un_assoc connection_monotonic inf_sup_aci(5) semantics_com_l)
  apply (smt Un_commute connection_monotonic semantics_com_r sup_assoc)
  done

(* 2-b *)
lemma semantics_empty_env:
  assumes "semantics A P \<alpha> Q"
  shows "\<exists>\<beta> Q'. semantics {} P \<beta> Q'"
  (* TODO *)

  apply (rule_tac exI)+
  using assms
  apply induct

  oops

(* 2-c *)
lemma semantics_swap_frame:
  assumes "semantics A P \<alpha> Q"
  and "connection A = connection B"
  shows "semantics B P \<alpha> Q"
  using assms
  apply -
  apply induct
  oops

section "Part 3"

definition stuck :: "process \<Rightarrow> bool"
where
  "stuck P \<equiv> \<forall>\<alpha> P'. semantics {} P \<alpha> P' \<longrightarrow> False"

primrec list_trans :: "_" where
  "list_trans A P [] Q = (P = Q)"
| "list_trans A P (\<alpha>#tr) Q =
    (\<exists>R. semantics A P \<alpha> R \<and> list_trans A R tr Q)"

definition traces_of :: "process \<Rightarrow> action list set"
  where "traces_of P = {tr | tr. \<exists>Q. list_trans {} P tr Q \<and> stuck Q}"

definition trace_eq :: "process \<Rightarrow> process \<Rightarrow> bool"
  where "trace_eq P Q = (traces_of P = traces_of Q)"

subsection "Question 3 (a)"

lemma trace_eq_refl:
  shows "trace_eq P P"
  (* TODO *)
  oops

lemma trace_eq_sym:
  assumes "trace_eq P Q"
    shows "trace_eq Q P"
  (* TODO *)
  oops

lemma trace_eq_trans:
  assumes "trace_eq P Q"
      and "trace_eq Q R"
    shows "trace_eq P R"
  (* TODO *)
  oops

subsection "Question 3 (b)"

lemma trace_eq_stuck:
  assumes "stuck P"
      and "stuck Q"
    shows "trace_eq P Q"
  (* TODO *)
  oops

subsection "Question 3 (c)"

lemma traces_of_monotonic:
  assumes "stuck R"
  shows "traces_of P \<subseteq> traces_of (Par P R)"
  (* TODO *)
  oops

subsection "Question 3 (d)"

text \<open>Feel free to give this answer in free-text comments,
      or as Isabelle definitions. \<close>

subsection "Question 3 (e)"

lemma traces_of_not_antimonotonic:
  assumes "\<And>P R. stuck R \<Longrightarrow> traces_of (Par P R) \<subseteq> traces_of P"
  shows "False"
  (* TODO *)
  oops

subsection "Question 3 (f)"

lemma semantics_par_assoc1:
  assumes "semantics A (Par P (Par Q S)) \<alpha> R"
  shows "\<exists>P' Q' S'.
           R = Par P' (Par Q' S') \<and>
           semantics A (Par (Par P Q) S) \<alpha> (Par (Par P' Q') S')"
  (* TODO *)
  oops

text \<open>
  This similar lemma will be needed later.
  You may use it without proof. \<close>
lemma semantics_par_assoc2:
  "semantics A (Par (Par P Q) S) \<alpha> R \<Longrightarrow>
  \<exists> P' Q' S'. R = Par (Par P' Q') S' \<and> semantics A (Par P (Par Q S)) \<alpha> (Par P' (Par Q' S'))"
  sorry

subsection "Question 3 (g)"

lemma list_trans_par_assoc:
  "list_trans A (Par (Par P Q) S) tr (Par (Par P' Q') S') =
       list_trans A (Par P (Par Q S)) tr (Par P' (Par Q' S'))"
  (* TODO *)
  oops

subsection "Question 3 (h)"

lemma stuck_par:
  "stuck(Par P Q) = (stuck P \<and> stuck Q)"
  (* TODO *)
  oops

subsection "Question 3 (i)"

lemma trace_eq_par_assoc:
  shows "trace_eq (Par (Par P Q) S) (Par P (Par Q S))"
  (* TODO *)
  oops

subsection "Question 3 (j)"

lemma trace_eq_nil_par:
  shows "trace_eq P (Par P Nil)"
  (* TODO *)
  oops

subsection "Question 3 (k)"

lemma trace_eq_par_comm:
  shows "trace_eq (Par P Q) (Par Q P)"
  (* TODO *)
  oops

end


theory Ex19
imports Main
begin

(*distributivity of "and" over "or"*)
lemma "A \<and> (B \<or> C) \<longleftrightarrow> (A \<and> B) \<or> (A \<and> C)"
proof -
{
  assume "A \<and> (B \<or> C)"
  hence A by (rule conjE)
  from \<open>A \<and> (B \<or> C)\<close> have "B \<or> C" by (rule conjE)
  {
    assume B
    with  \<open>A\<close> have "A \<and> B" by (rule conjI)
    hence "(A \<and> B) \<or> (A \<and> C)" by (rule disjI1)
  }
  moreover
  {
    assume C
    with \<open>A\<close> have "A \<and> C" by (rule conjI)
    hence "(A \<and> B) \<or> (A \<and> C)" by (rule disjI2)
  }
  from \<open>B \<or> C\<close> and calculation and this have "(A \<and> B) \<or> (A \<and> C)" by (rule disjE)
}
moreover
{
  assume "(A \<and> B) \<or> (A \<and> C)"
  {
    assume "A \<and> B"
    hence A by (rule conjE)
    from \<open>A \<and> B\<close> have B by (rule conjE)
    hence "B \<or> C" by (rule disjI1)
    with \<open>A\<close> have "A \<and> (B \<or> C)" by (rule conjI)
  }
  moreover
  {
    assume "A \<and> C"
    hence A by (rule conjE)
    from \<open>A \<and> C\<close> have C by (rule conjE)
    hence "B \<or> C" by (rule disjI2)
    with \<open>A\<close> have "A \<and> (B \<or> C)" by (rule conjI)
  }
  from \<open>(A \<and> B) \<or> (A \<and> C)\<close> and calculation and this have "A \<and> (B \<or> C)" by (rule disjE)
}
ultimately show ?thesis by (rule iffI)
qed