(*  Title:       Jive Data and Store Model
    Author:      Norbert Schirmer <schirmer at informatik.tu-muenchen.de>, 2003
    Maintainer:  Nicole Rauch <rauch at informatik.uni-kl.de>
    License:     LGPL
*)

section \<open>Widening the Direct Subtype Relation\<close>

theory Subtype
imports "../Isa_Counter/DirectSubtypes"
begin

text \<open>
In this theory, we define the widening subtype relation of types and prove
that it is a partial order.
\<close>

subsection \<open>Auxiliary lemmas\<close>

text \<open>These general lemmas are not especially related to Jive.
They capture
some useful properties of general relations.
\<close>
lemma distinct_rtrancl_into_trancl:
  assumes neq_x_y: "x\<noteq>y"
  assumes x_y_rtrancl: "(x,y) \<in> r\<^sup>*"
  shows "(x,y) \<in> r\<^sup>+"
  using x_y_rtrancl neq_x_y
proof (induct)
  assume "x\<noteq>x" thus "(x, x) \<in> r\<^sup>+" by simp
next
  fix y z
  assume x_y_rtrancl: "(x, y) \<in> r\<^sup>*"
  assume y_z_r: "(y, z) \<in> r"
  assume "x \<noteq> y \<Longrightarrow> (x, y) \<in> r\<^sup>+"
  assume "x \<noteq> z"
  from x_y_rtrancl
  show "(x, z) \<in> r\<^sup>+"
  proof (cases)
    assume "x=y"
    with y_z_r have "(x,z) \<in> r" by simp
    thus "(x,z) \<in>  r\<^sup>+"..
  next
    fix w
    assume "(x, w) \<in> r\<^sup>*"
    moreover assume "(w, y) \<in> r"
    ultimately have "(x,y) \<in> r\<^sup>+"
      by (rule rtrancl_into_trancl1)
    from this y_z_r
    show "(x, z) \<in> r\<^sup>+"..
  qed
qed

lemma acyclic_imp_antisym_rtrancl: "acyclic r \<Longrightarrow> antisym (r\<^sup>*)"
proof (clarsimp simp only: acyclic_def antisym_def)
  fix x y
  assume acyclic: "\<forall>x. (x, x) \<notin> r\<^sup>+"
  assume x_y: "(x, y) \<in> r\<^sup>*"
  assume y_x: "(y, x) \<in> r\<^sup>*"
  show "x=y"
  proof (cases "x=y")
    case True thus ?thesis .
  next
    case False
    from False x_y have "(x, y) \<in> r\<^sup>+"
      by (rule distinct_rtrancl_into_trancl)
    also
    from False y_x have "(y, x) \<in> r\<^sup>+"
      by (fastforce intro: distinct_rtrancl_into_trancl)
    finally have "(x,x) \<in> r\<^sup>+".
    with acyclic show ?thesis by simp
  qed
qed

lemma acyclic_trancl_rtrancl:
  assumes acyclic: "acyclic r"
  shows "(x,y) \<in> r\<^sup>+ = ((x,y) \<in> r\<^sup>* \<and> x\<noteq>y)"
proof
  assume x_y_trancl: "(x,y) \<in> r\<^sup>+"
  show "(x,y) \<in> r\<^sup>* \<and> x\<noteq>y"
  proof
    from x_y_trancl show "(x,y) \<in> r\<^sup>*"..
  next
    from x_y_trancl acyclic show "x\<noteq>y" by (auto simp add: acyclic_def)
  qed
next
  assume "(x,y) \<in> r\<^sup>* \<and> x\<noteq>y"
  thus "(x,y) \<in> r\<^sup>+"
    by (auto intro: distinct_rtrancl_into_trancl)
qed

subsection \<open>The Widening (Subtype) Relation of Javatypes\<close>

text \<open>\label{widening_subtypes}
In this section we widen the direct subtype relations specified in Sec.
\ref{direct_subtype_relations}.
It is done by a calculation of the transitive closure of the
direct subtype relation.
\<close>

text \<open>This is the concrete syntax that expresses the subtype relations
between all types.
\label{subtype_relations_concrete_syntax}\<close>

abbreviation
  direct_subtype_syntax :: "Javatype \<Rightarrow> Javatype \<Rightarrow> bool" ("_ \<prec>1 _" [71,71] 70)
where \<comment> \<open>direct subtype relation\<close>
  "A \<prec>1 B == (A,B) \<in> direct_subtype"

abbreviation
  widen_syntax :: "Javatype \<Rightarrow> Javatype \<Rightarrow> bool" ("_ \<preceq> _" [71,71] 70)
where \<comment> \<open>reflexive transitive closure of direct subtype relation\<close>
  "A \<preceq> B == (A,B) \<in> direct_subtype\<^sup>*"

abbreviation
  widen_strict_syntax :: "Javatype \<Rightarrow> Javatype \<Rightarrow> bool" ("_ \<prec> _" [71,71] 70)
where \<comment> \<open>transitive closure of direct subtype relation\<close>
  "A \<prec> B == (A,B) \<in> direct_subtype\<^sup>+"

subsection \<open>The Subtype Relation as Partial Order\<close>

text \<open>We prove the axioms required for partial orders, i.e.\
reflexivity, transitivity and antisymmetry, for the widened subtype
relation. The direct subtype relation has been
defined in Sec. \ref{direct_subtype_relations}.
The reflexivity lemma is
added to the Simplifier and to the Classical reasoner (via the
attribute iff), and the transitivity and antisymmetry lemmas
are made known as transitivity rules (via the attribute trans).
This way, these lemmas will be automatically used in subsequent proofs.
\<close>

lemma acyclic_direct_subtype: "acyclic direct_subtype"
proof (clarsimp simp add: acyclic_def)
  fix x show "x \<prec> x \<Longrightarrow> False"
  by (cases x) (fastforce elim: tranclE simp add: direct_subtype_def)+
     (* takes a very long time to calculate *)
qed

lemma antisym_rtrancl_direct_subtype: "antisym (direct_subtype\<^sup>*)"
using acyclic_direct_subtype by (rule acyclic_imp_antisym_rtrancl)

lemma widen_strict_to_widen: "C \<prec> D = (C \<preceq> D \<and> C\<noteq>D)"
using acyclic_direct_subtype by (rule acyclic_trancl_rtrancl)

text \<open>The widening relation on Javatype is reflexive.\<close>

lemma widen_refl [iff]: "X \<preceq> X" ..

text \<open>The widening relation on Javatype is transitive.\<close>

lemma widen_trans [trans] :
  assumes a_b: "a \<preceq> b"
  shows "\<And> c. b \<preceq> c \<Longrightarrow> a \<preceq> c"
  by (insert a_b, rule rtrancl_trans)

text \<open>The widening relation on Javatype is antisymmetric.\<close>

lemma widen_antisym [trans]:
  assumes a_b: "a \<preceq> b"
  assumes b_c: "b \<preceq> a"
  shows "a = b"
  using a_b b_c antisym_rtrancl_direct_subtype
  by (unfold antisym_def) blast

subsection \<open>Javatype Ordering Properties\<close>

text \<open>The type class @{term ord} allows us to overwrite the two comparison
operators $<$ and $\leq$.
  These are  the two comparison operators on @{typ Javatype} that we want
to use subsequently.\<close>

text \<open>We can also prove that @{typ Javatype} is in the type class @{term order}.
For this we
  have to prove reflexivity, transitivity, antisymmetry and that $<$ and $\leq$ are
defined in such
  a way that @{thm Orderings.order_less_le [no_vars]} holds. This proof can easily
be achieved by using the
  lemmas proved above and the definition of @{term less_Javatype_def}.
\<close>

instantiation Javatype:: order
begin

definition
  le_Javatype_def:   "A \<le> B \<equiv> A \<preceq> B"

definition
  less_Javatype_def: "A < B \<equiv> A \<le> B \<and> \<not> B \<le> (A::Javatype)"

instance proof
  fix x y z:: "Javatype"
  {
    show "x \<le> x"
      by (simp add: le_Javatype_def )
  next
    assume "x \<le> y" "y \<le> z"
    then show "x \<le> z"
      by (unfold le_Javatype_def) (rule rtrancl_trans)
  next
    assume "x \<le> y" "y \<le> x"
    then show "x = y"
      apply (unfold le_Javatype_def)
      apply (rule widen_antisym)
      apply assumption +
      done
  next
    show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
      by (simp add: less_Javatype_def)
  }
qed

end

subsection \<open>Enhancing the Simplifier\<close>

lemmas subtype_defs = le_Javatype_def less_Javatype_def
                      direct_subtype_def
(*
                      direct_subtype
                      direct_subtype[THEN r_into_rtrancl]
*)
lemmas subtype_ok_simps = subtype_defs
lemmas subtype_wrong_elims = rtranclE

text \<open>During verification we will often have to solve the goal that one type
widens to the other. So we equip the simplifier with a special solver-tactic.
\<close>

lemmas direct_subtype_widened = direct_subtype[THEN r_into_rtrancl]

ML \<open>
local val ss = simpset_of @{context} in

fun widen_tac ctxt =
  resolve_tac ctxt @{thms widen_asm} THEN'
  simp_tac (put_simpset ss ctxt addsimps @{thms le_Javatype_def}) THEN'
  Method.insert_tac ctxt @{thms direct_subtype_widened} THEN'
  simp_tac (put_simpset (simpset_of @{theory_context Transitive_Closure}) ctxt)

end
\<close>

declaration \<open>fn _ =>
  Simplifier.map_ss (fn ss => ss addSolver (mk_solver "widen" widen_tac))
\<close>

text \<open>In this solver-tactic, we first try the trivial resolution with \<open>widen_asm\<close> to
check if the actual subgaol really is a request to solve a subtyping problem.
If so, we unfold the comparison operator, insert the direct subtype
relations and call the simplifier.
\<close>

subsection \<open>Properties of the Subtype Relation\<close>

text \<open>The class \<open>Object\<close> has to be the root of the class hierarchy,
i.e.~it is supertype of each concrete class, abstract class, interface
and array type.
  The proof scripts should run on every correctly generated type hierarchy.
\<close>

lemma Object_root: "CClassT C \<le> CClassT Object"
  by (cases C, simp_all)

lemma Object_root_abs: "AClassT C \<le> CClassT Object"
  by (cases C, simp_all)

lemma Object_root_int: "InterfaceT C \<le> CClassT Object"
  by (cases C, simp_all)

lemma Object_root_array: "ArrT C \<le> CClassT Object"
  proof (cases C)
    fix x
    assume c: "C = CClassAT x"
    show "ArrT C \<le> CClassT Object"
      using c by (cases x, simp_all)
  next
    fix x
    assume c: "C = AClassAT x"
    show "ArrT C \<le> CClassT Object"
      using c by (cases x, simp_all)
  next
    fix x
    assume c: "C = InterfaceAT x"
    show "ArrT C \<le> CClassT Object"
      using c by (cases x, simp_all)
  next
    assume c: "C = BoolAT"
    show "ArrT C \<le> CClassT Object"
      using c by simp
  next
    assume c: "C = IntgAT"
    show "ArrT C \<le> CClassT Object"
      using c by simp
  next
    assume c: "C = ShortAT"
    show "ArrT C \<le> CClassT Object"
      using c by simp
  next
    assume c: "C = ByteAT"
    show "ArrT C \<le> CClassT Object"
      using c by simp
qed

text \<open>If another type is (non-strict) supertype of Object,
then it must be the type Object itself.\<close>

lemma Object_rootD:
  assumes p: "CClassT Object \<le> c"
  shows "CClassT Object = c"
  using p
  apply (cases c)
  apply (fastforce elim: subtype_wrong_elims simp add: subtype_defs) +
  \<comment> \<open>In this lemma, we only get contradictory cases except for Object itself.\<close>
done

text \<open>The type NullT has to be the leaf of each branch of the class
hierarchy, i.e.~it is subtype of each type.\<close>

lemma NullT_leaf [simp]: "NullT \<le> CClassT C"
  by (cases C, simp_all)

lemma NullT_leaf_abs [simp]: "NullT \<le> AClassT C"
  by (cases C, simp_all)

lemma NullT_leaf_int [simp]: "NullT \<le> InterfaceT C"
  by (cases C, simp_all)

lemma NullT_leaf_array: "NullT \<le> ArrT C"
  proof (cases C)
    fix x
    assume c: "C = CClassAT x"
    show "NullT \<le> ArrT C"
      using c by (cases x, simp_all)
  next
    fix x
    assume c: "C = AClassAT x"
    show "NullT \<le> ArrT C"
      using c by (cases x, simp_all)
  next
    fix x
    assume c: "C = InterfaceAT x"
    show "NullT \<le> ArrT C"
      using c by (cases x, simp_all)
  next
    assume c: "C = BoolAT"
    show "NullT \<le> ArrT C"
      using c by simp
  next
    assume c: "C = IntgAT"
    show "NullT \<le> ArrT C"
      using c by simp
  next
    assume c: "C = ShortAT"
    show "NullT \<le> ArrT C"
      using c by simp
  next
    assume c: "C = ByteAT"
    show "NullT \<le> ArrT C"
      using c by simp
qed

end


theory prop_05
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun count :: "Nat => Nat list => Nat" where
  "count x (Nil2) = Z"
  | "count x (Cons2 z ys) =
       (if equal2 x z then S (count x ys) else count x ys)"
  (*hipster equal2 count *)
  hipster equal2
lemma lemma_a [thy_expl]: "equal2 x x = True"
apply (induction x)
apply simp
by simp

lemma lemma_aa [thy_expl]: "equal2 Z x = equal2 x Z"
apply (induction x)
apply simp
by simp

lemma lemma_ab [thy_expl]: "equal2 (S x) y = equal2 y (S x)"
apply (induction y)
(*apply (metis equal2.elims(2) equal2.simps(1))*)
sledgehammer
apply simp
apply simp
sledgehammer
oops

lemma lemma_ac [thy_expl]: "equal2 x (S x) = False"
apply (induction x)
apply simp
by simp
(*
lemma lemma_ad [thy_expl]: "equal2 (S x) (S y) = equal2 y x"
apply (induction x)
apply (metis equal2.elims(2) equal2.simps(1) equal2.simps(3))
apply (metis Nat.distinct(1) Nat.inject equal2.elims(2) equal2.elims(3) equal2.simps(2) equal2.simps(3) equal2.simps(4))
apply simp
by simp
lemma lemma_a [thy_expl]: "equal2 x4 y4 = equal2 y4 x4"
by (hipster_induct_schemes prop_05.equal2.simps)

lemma lemma_aa [thy_expl]: "equal2 x2 x2 = True"
by (hipster_induct_schemes prop_05.equal2.simps)

lemma lemma_ab [thy_expl]: "equal2 x2 (S x2) = False"
by (hipster_induct_schemes prop_05.equal2.simps)
  theorem x0 :
    "(n = x) ==> ((S (count n xs)) = (count n (Cons2 x xs)))"
    by (tactic {* Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1 *})
end


(*<*)
theory Infinite_Proof_Soundness
imports Finite_Proof_Soundness "HOL-Library.BNF_Corec"
begin

(* Reference: A Generic Cyclic Theorem Prover
by James Brotherston, Nikos Gorogiannis, and Rasmus L. Petersen
*)
(*>*)

section \<open>Soundness of Infinite Proof Trees\<close>

context
begin

private definition "num P xs \<equiv> LEAST n. list_all (Not o P) (stake n xs) \<and> P (xs!!n)"

private lemma num:
  assumes ev: "ev (\<lambda>xs. P (shd xs)) xs"
  defines "n \<equiv> num P xs"
  shows
    "(list_all (Not o P) (stake n xs) \<and> P (xs!!n)) \<and>
 (\<forall>m. list_all (Not o P) (stake m xs) \<and> P (xs!!m) \<longrightarrow> n \<le> m)"
  unfolding n_def num_def
proof (intro conjI[OF LeastI_ex] allI impI Least_le)
  from ev show "\<exists>n. list_all (Not o P) (stake n xs) \<and> P (xs !! n)"
    by (induct rule: ev_induct_strong) (auto intro: exI[of _ 0] exI[of _ "Suc _"])
qed (simp_all add: o_def)

private lemma num_stl[simp]:
  assumes "ev (\<lambda>xs. P (shd xs)) xs" and "\<not> P (shd xs)"
  shows "num P xs = Suc (num P (stl xs))"
  unfolding num_def by (rule trans[OF Least_Suc[of _ "num P xs"]])
    (auto simp: num[OF assms(1)] assms(2))

corecursive decr0 where
  "decr0 Ord minSoFar js =
    (if \<not> (ev (\<lambda>js. (shd js, minSoFar) \<in> Ord \<and> shd js \<noteq> minSoFar)) js
     then undefined
     else if ((shd js, minSoFar) \<in> Ord \<and> shd js \<noteq> minSoFar)
          then shd js ## decr0 Ord (shd js) js
          else decr0 Ord minSoFar (stl js))"
  by (relation "measure (\<lambda>(Ord,m,js). num (\<lambda>j. (j, m) \<in> Ord \<and> j \<noteq> m) js)") auto

end

lemmas well_order_on_defs =
  well_order_on_def linear_order_on_def partial_order_on_def
  preorder_on_def trans_def antisym_def refl_on_def

lemma sdrop_length_shift[simp]:
  "sdrop (length xs) (xs @- s) = s"
  by (simp add: sdrop_shift)

lemma ev_iff_shift:
  "ev \<phi> xs \<longleftrightarrow> (\<exists>xl xs2. xs = xl @- xs2 \<and> \<phi> xs2)"
  by (meson ev.base ev_imp_shift ev_shift)

locale Infinite_Soundness = RuleSystem_Defs eff rules for
  eff :: "'rule \<Rightarrow> 'sequent \<Rightarrow> 'sequent fset \<Rightarrow> bool"
  and rules :: "'rule stream"
  +
  fixes "structure" :: "'structure set"
    and sat :: "'structure \<Rightarrow> 'sequent \<Rightarrow> bool"
    and \<delta> :: "'sequent \<Rightarrow> 'rule \<Rightarrow> 'sequent \<Rightarrow> ('marker \<times> bool \<times> 'marker) set"
    and Ord :: "'ord rel"
    and \<sigma> :: "'marker \<times> 'structure \<Rightarrow> 'ord"
  assumes
    Ord: "well_order Ord"
    and
    descent: (* The original paper has an error in stating this: quantifies existentially
  instead of universally over r *)
    "\<And>r s sl S.
      \<lbrakk>r \<in> R; eff r s sl; S \<in> structure; \<not> sat S s\<rbrakk>
      \<Longrightarrow>
      \<exists>s' S'.
        s' |\<in>| sl \<and> S' \<in> structure \<and> \<not> sat S' s' \<and>
        (\<forall>v v' b.
          (v,b,v') \<in> \<delta> s r s' \<longrightarrow>
             (\<sigma>(v',S'), \<sigma>(v,S)) \<in> Ord \<and> (b \<longrightarrow> \<sigma>(v',S') \<noteq> \<sigma>(v,S)))"

(* The descent property subsumes local_soundness: *)
sublocale Infinite_Soundness < Soundness where eff = eff and rules = rules
  and "structure" = "structure" and sat = sat
  by standard (blast dest: descent)

context Infinite_Soundness
begin

(* The notion of a trace of markers following a path: to make the original paper definition
into a rigorous one, we include the trace of "progressing bits" as well:  *)
coinductive follow :: "bool stream \<Rightarrow> 'marker stream \<Rightarrow> ('sequent,'rule)step stream \<Rightarrow> bool" where
  "\<lbrakk>M' = shd Ms; s' = fst (shd steps); (M,b,M') \<in> \<delta> s r s'; follow bs Ms steps\<rbrakk>
 \<Longrightarrow>
 follow (SCons b bs) (SCons M Ms) (SCons (s,r) steps)"

(* Now infinite progress simply means "always eventually the bit is True": *)
definition infDecr :: "bool stream \<Rightarrow> bool" where
  "infDecr \<equiv> alw (ev (\<lambda>bs. shd bs))"

(* Good trees: *)
definition good :: "('sequent,'rule)dtree \<Rightarrow> bool" where
  "good t \<equiv> \<forall>steps.
  ipath t steps
  \<longrightarrow>
  ev (\<lambda>steps'. \<exists>bs Ms. follow bs Ms steps' \<and> infDecr bs) steps"
(* Note the mixture of temporal connectives and standard HOL quantifiers:
an advantage of the shallow embedding of LTL *)

(* Trivially, finite trees are particular cases of good trees, since they
have no infinite paths: *)
lemma tfinite_good: "tfinite t \<Longrightarrow> good t"
  using ftree_no_ipath unfolding good_def by auto

context
  fixes inv :: "'sequent \<times> 'a \<Rightarrow> bool"
    and pred :: "'sequent \<times> 'a \<Rightarrow> 'rule \<Rightarrow> 'sequent \<times> 'a \<Rightarrow> bool"
begin

primcorec konigDtree ::
  "('sequent,'rule) dtree \<Rightarrow> 'a \<Rightarrow> (('sequent,'rule) step \<times> 'a) stream" where
  "shd (konigDtree t a) = (root t, a)"
|"stl (konigDtree t a) =
  (let s = fst (root t); r = snd (root t);
   (s',a') = (SOME (s',a'). s' |\<in>| fimage (fst o root) (cont t) \<and> pred (s,a) r (s',a') \<and> inv (s',a'));
   t' = (SOME t'. t' |\<in>| cont t \<and> s' = fst (root t'))
   in konigDtree t' a'
  )"

lemma stl_konigDtree:
  fixes t defines "s \<equiv> fst (root t)" and "r \<equiv> snd (root t)"
  assumes s': "s' |\<in>| fimage (fst o root) (cont t)"  and "pred (s,a) r (s',a'')" and "inv (s',a'')"
  shows "\<exists>t' a'. t' |\<in>| cont t \<and> pred (s,a) r (fst (root t'),a') \<and> inv (fst (root t'),a')
  \<and> stl (konigDtree t a) = konigDtree t' a'"
proof-
  define P where "P \<equiv> \<lambda>(s',a'). s' |\<in>| fimage (fst o root) (cont t) \<and> pred (s,a) r (s',a') \<and> inv (s',a')"
  define s'a' where "s'a' \<equiv> SOME (s',a'). P (s',a')"  let ?s' = "fst s'a'"  let ?a' = "snd s'a'"
  define t' where "t' \<equiv> SOME (t'::('sequent,'rule)dtree). t' |\<in>| cont t \<and> ?s' = fst (root t')"
  have "P (s',a'')" using assms unfolding P_def by auto
  hence P: "P (?s',?a')" using someI[of P] unfolding s'a'_def by auto
  hence "\<exists>t'. t' |\<in>| cont t \<and> ?s' = fst (root t')" unfolding P_def by auto
  hence t': "t' |\<in>| cont t" and s': "?s' = fst (root t')"
    using someI_ex[of "\<lambda>t'. t' |\<in>| cont t \<and> ?s' = fst (root t')"] unfolding t'_def by auto
  show ?thesis using t' P s' assms P_def s'a'_def t'_def by (intro exI[of _ t'] exI[of _ ?a']) auto
qed

declare konigDtree.simps(2)[simp del]

lemma konigDtree:
  assumes 1: "\<And>r s sl a.
  \<lbrakk>r \<in> R; eff r s sl; inv (s,a)\<rbrakk> \<Longrightarrow>
  \<exists>s' a'. s' |\<in>| sl \<and> inv (s',a') \<and> pred (s,a) r (s',a')"
    and 2: "wf t" "inv (fst (root t), a)"
  shows
    "alw (\<lambda>stepas.
        let ((s,r),a) = shd stepas; ((s',_),a') = shd (stl stepas) in
          inv (s,a) \<and> pred (s,a) r (s',a'))
     (konigDtree t a)"
  using assms proof (coinduction arbitrary: t a)
  case (alw t a)
  then obtain s' a' where "s' |\<in>| (fst \<circ> root) |`| cont t" "inv (s', a')"
    "pred (fst (root t), a) (snd (root t)) (s', a')"
    by (auto elim!: wf.cases dest!: spec[of _ "snd (root t)"] spec[of _ "fst (root t)"]
        spec[of _ "(fst \<circ> root) |`| cont t"] spec[of _ a], fastforce)
  with alw stl_konigDtree[of s' t a a'] show ?case
    by (auto split: prod.splits elim!: wf.cases) fastforce
qed

lemma konigDtree_ipath:
  assumes "\<And>r s sl a.
  \<lbrakk>r \<in> R; eff r s sl; inv (s,a)\<rbrakk> \<Longrightarrow>
  \<exists>s' a'. s' |\<in>| sl \<and> inv (s',a') \<and> pred (s,a) r (s',a')"
    and "wf t" and "inv (fst (root t), a)"
  shows "ipath t (smap fst (konigDtree t a))"
  using assms proof (coinduction arbitrary: t a)
  case (ipath t a)
  then obtain s' a' where "s' |\<in>| (fst \<circ> root) |`| cont t" "inv (s', a')"
    "pred (fst (root t), a) (snd (root t)) (s', a')"
    by (auto elim!: wf.cases dest!: spec[of _ "snd (root t)"] spec[of _ "fst (root t)"]
        spec[of _ "(fst \<circ> root) |`| cont t"] spec[of _ a], fastforce)
  with ipath stl_konigDtree[of s' t a a'] show ?case
    by (auto split: prod.splits elim!: wf.cases) force
qed

end (* context *)

lemma follow_stl_smap_fst[simp]:
  "follow bs Ms (smap fst stepSs) \<Longrightarrow>
   follow (stl bs) (stl Ms) (smap fst (stl stepSs))"
  by (erule follow.cases) (auto simp del: stream.map_sel simp add: stream.map_sel[symmetric])

lemma epath_stl_smap_fst[simp]:
  "epath (smap fst stepSs) \<Longrightarrow>
   epath (smap fst (stl stepSs))"
  by (erule epath.cases) (auto simp del: stream.map_sel simp add: stream.map_sel[symmetric])

lemma infDecr_tl[simp]: "infDecr bs \<Longrightarrow> infDecr (stl bs)"
  unfolding infDecr_def by auto

(* Proof of the main theorem: *)
fun descent where "descent (s,S) r (s',S') =
 (\<forall>v v' b.
    (v,b,v') \<in> \<delta> s r s' \<longrightarrow>
    (\<sigma>(v',S'), \<sigma>(v,S)) \<in> Ord \<and> (b \<longrightarrow> \<sigma>(v',S') \<noteq> \<sigma>(v,S)))"

lemma descentE[elim]:
  assumes "descent (s,S) r (s',S')" and "(v,b,v') \<in> \<delta> s r s'"
  shows "(\<sigma>(v',S'), \<sigma>(v,S)) \<in> Ord \<and> (b \<longrightarrow> \<sigma>(v',S') \<noteq> \<sigma>(v,S))"
  using assms by auto

definition "konigDown \<equiv> konigDtree (\<lambda>(s,S). S \<in> structure \<and> \<not> sat S s) descent"

lemma konigDown:
  assumes "wf t" and "S \<in> structure" and "\<not> sat S (fst (root t))"
  shows
    "alw (\<lambda>stepSs. let ((s,r),S) = shd stepSs; ((s',_),S') = shd (stl stepSs) in
                    S \<in> structure \<and> \<not> sat S s \<and> descent (s,S) r (s',S'))
     (konigDown t S)"
  using konigDtree[of "\<lambda>(s,S). S \<in> structure \<and> \<not> sat S s" descent, unfolded konigDown_def[symmetric]]
  using assms descent by auto

lemma konigDown_ipath:
  assumes "wf t" and "S \<in> structure" and "\<not> sat S (fst (root t))"
  shows
    "ipath t (smap fst (konigDown t S))"
  using konigDtree_ipath[of "\<lambda>(s,S). S \<in> structure \<and> \<not> sat S s" descent, unfolded konigDown_def[symmetric]]
  using assms descent by auto

context
  fixes t S
  assumes w: "wf t" and t: "good t" and S: "S \<in> structure" "\<not> sat S (fst (root t))"
begin

lemma alw_ev_Ord:
  obtains ks where "alw (\<lambda>ks. (shd (stl ks), shd ks) \<in> Ord) ks"
    and "alw (ev (\<lambda>ks. shd (stl ks) \<noteq> shd ks)) ks"
proof-
  define P where "P \<equiv> \<lambda>stepSs. let ((s,r),S) = shd stepSs; ((s',_),S') = shd (stl stepSs) in
                      S \<in> structure \<and> \<not> sat S s \<and> descent (s,S) r (s',S')"
  have "alw P (konigDown t S)" using konigDown[OF w S] unfolding P_def by auto
  obtain srs steps bs Ms where 0: "smap fst (konigDown t S) = srs @- steps" and
    f: "follow bs Ms steps" and i: "infDecr bs"
    using konigDown_ipath[OF w S] t unfolding good_def ev_iff_shift by auto
  define stepSs where "stepSs = sdrop (length srs) (konigDown t S)"
  have steps: "steps = smap fst stepSs" unfolding stepSs_def sdrop_smap[symmetric] 0 by simp
  have e: "epath steps"
    using wf_ipath_epath[OF w konigDown_ipath[OF w S]] 0 epath_shift by simp
  have "alw P (konigDown t S)" using konigDown[OF w S] unfolding P_def by auto
  hence P: "alw P stepSs" using alw_sdrop unfolding stepSs_def by auto
  let ?ks = "smap \<sigma> (szip Ms (smap snd stepSs))"
  show ?thesis proof(rule that[of ?ks])
    show "alw (\<lambda>ks. (shd (stl ks), shd ks) \<in> Ord) ?ks"
      using e f P unfolding steps proof(coinduction arbitrary: bs Ms stepSs rule: alw_coinduct)
      case (alw bs Ms stepSs)
      let ?steps = "smap fst stepSs" let ?Ss = "smap snd stepSs"
      let ?MSs = "szip Ms (smap snd stepSs)"
      let ?s = "fst (shd ?steps)"  let ?s' = "fst (shd (stl ?steps))"
      let ?r = "snd (shd ?steps)"
      let ?S = "snd (shd stepSs)"  let ?S' = "snd (shd (stl stepSs))"
      let ?M = "shd Ms"  let ?M' = "shd (stl Ms)"  let ?b = "shd bs"
      have 1: "(?M, ?b, ?M') \<in> \<delta> ?s ?r ?s'"
        using \<open>follow bs Ms (smap fst stepSs)\<close> by (cases rule: follow.cases) auto
      have 2: "descent (?s,?S) ?r (?s',?S')"
        using \<open>alw P stepSs\<close> unfolding P_def by (cases rule: alw.cases) auto
      have "(\<sigma>(?M',?S'), \<sigma>(?M,?S)) \<in> Ord" using descentE[OF 2 1] by simp
      thus ?case by simp
    next
      case (stl bs Ms stepSs)
      thus ?case
        by (intro exI[of _ "stl bs"] exI[of _ "stl Ms"] exI[of _ "stl stepSs"])
          (auto elim: epath.cases)
    qed
  next
    show "alw (ev (\<lambda>ks. shd (stl ks) \<noteq> shd ks)) ?ks"
      using e f P i unfolding steps proof(coinduction arbitrary: bs Ms stepSs rule: alw_coinduct)
      case (alw bs Ms stepSs)
      let ?steps = "smap fst stepSs" let ?Ss = "smap snd stepSs"
      let ?MSs = "szip Ms (smap snd stepSs)"
      let ?s = "fst (shd ?steps)"  let ?s' = "fst (shd (stl ?steps))"
      let ?r = "snd (shd ?steps)"
      let ?S = "snd (shd stepSs)"  let ?S' = "snd (shd (stl stepSs))"
      let ?M = "shd Ms"  let ?M' = "shd (stl Ms)"  let ?b = "shd bs"
      have 1: "(?M, ?b, ?M') \<in> \<delta> ?s ?r ?s'"
        using \<open>follow bs Ms (smap fst stepSs)\<close> by (cases rule: follow.cases) auto
      have 2: "descent (?s,?S) ?r (?s',?S')"
        using \<open>alw P stepSs\<close> unfolding P_def by (cases rule: alw.cases) auto
      have "(\<sigma>(?M',?S'), \<sigma>(?M,?S)) \<in> Ord" using descentE[OF 2 1] by simp
      have "ev shd bs" using \<open>infDecr bs\<close> unfolding infDecr_def by auto
      thus ?case using \<open>epath ?steps\<close> \<open>follow bs Ms ?steps\<close> \<open>alw P stepSs\<close>
      proof (induction arbitrary: Ms stepSs)
        case (base bs Ms stepSs)
        let ?steps = "smap fst stepSs" let ?Ss = "smap snd stepSs"
        let ?MSs = "szip Ms (smap snd stepSs)"
        let ?s = "fst (shd ?steps)"  let ?s' = "fst (shd (stl ?steps))"
        let ?r = "snd (shd ?steps)"
        let ?S = "snd (shd stepSs)"  let ?S' = "snd (shd (stl stepSs))"
        let ?M = "shd Ms"  let ?M' = "shd (stl Ms)"  let ?b = "shd bs"
        have 1: "(?M, ?b, ?M') \<in> \<delta> ?s ?r ?s'"
          using \<open>follow bs Ms (smap fst stepSs)\<close> by (cases rule: follow.cases) auto
        have 2: "descent (?s,?S) ?r (?s',?S')"
          using \<open>alw P stepSs\<close> unfolding P_def by (cases rule: alw.cases) auto
        have "\<sigma>(?M',?S') \<noteq> \<sigma>(?M,?S)" using descentE[OF 2 1] \<open>shd bs\<close> by simp
        thus ?case by auto
      next
        case (step bs Ms stepSs)
        have "ev (\<lambda>ks. shd (stl ks) \<noteq> shd ks)
                  (smap \<sigma>
                  (szip (stl Ms) (smap snd (stl stepSs))))"
          using step(3-5) step(2)[of "stl stepSs" "stl Ms"] by auto
        thus ?case by auto
      qed
    next
      case (stl bs Ms stepSs)
      thus ?case
        by (intro exI[of _ "stl bs"] exI[of _ "stl Ms"] exI[of _ "stl stepSs"])
          (auto elim: epath.cases)
    qed
  qed
qed

definition
  "ks \<equiv> SOME ks.
        alw (\<lambda>ks. (shd (stl ks), shd ks) \<in> Ord) ks \<and>
        alw (ev (\<lambda>ks. shd (stl ks) \<noteq> shd ks)) ks"

lemma alw_ks: "alw (\<lambda>ks. (shd (stl ks), shd ks) \<in> Ord) ks"
  and alw_ev_ks: "alw (ev (\<lambda>ks. shd (stl ks) \<noteq> shd ks)) ks"
  unfolding ks_def using alw_ev_Ord someI_ex[of "\<lambda>ks.
        alw (\<lambda>ks. (shd (stl ks), shd ks) \<in> Ord) ks \<and>
        alw (ev (\<lambda>ks. shd (stl ks) \<noteq> shd ks)) ks"]
  by auto

abbreviation decr where "decr \<equiv> decr0 Ord"

lemmas decr_simps = decr0.code[of Ord]

context
  fixes js
  assumes a: "alw (\<lambda>js. (shd (stl js), shd js) \<in> Ord) js"
    and ae: "alw (ev (\<lambda>js. shd (stl js) \<noteq> shd js)) js"
begin

lemma decr_ev:
  assumes m: "(shd js, m) \<in> Ord"
  shows "ev (\<lambda>js. (shd js, m) \<in> Ord \<and> shd js \<noteq> m) js"
    (is "ev (\<lambda>js. ?\<phi> m js) js")
proof-
  have "ev (\<lambda>js. shd (stl js) \<noteq> shd js) js" using ae by auto
  thus ?thesis
    using a m proof induction
    case (base ls)
    hence "ev (?\<phi> (shd ls)) ls" by auto
    moreover have "\<And>js. ?\<phi> (shd ls) js \<Longrightarrow> ?\<phi> m js"
      using \<open>(shd ls, m) \<in> Ord\<close> Ord unfolding well_order_on_defs by blast
    ultimately show ?case using ev_mono[of "?\<phi> (shd ls)" _ "?\<phi> m"] by auto
  qed auto
qed

lemma decr_simps_diff[simp]:
  assumes m: "(shd js, m) \<in> Ord"
    and "shd js \<noteq> m"
  shows "decr m js = shd js ## decr (shd js) js"
  using decr_ev[OF m] assms by (subst decr_simps) simp

lemma decr_simps_eq[simp]:
  "decr (shd js) js = decr (shd js) (stl js)"
proof-
  have m: "(shd js, shd js) \<in> Ord" using Ord
    unfolding well_order_on_def linear_order_on_def partial_order_on_def
      preorder_on_def refl_on_def by auto
  show ?thesis using decr_ev[OF m] by (subst decr_simps) simp
qed

end (* context *)

lemma stl_decr:
  assumes a: "alw (\<lambda>js. (shd (stl js), shd js) \<in> Ord) js"
    and ae: "alw (ev (\<lambda>js. shd (stl js) \<noteq> shd js)) js"
    and m: "(shd js, m) \<in> Ord"
  shows
    "\<exists>js1 js2. js = js1 @- js2 \<and> set js1 \<subseteq> {m} \<and>
 (shd js2, m) \<in> Ord \<and> shd js2 \<noteq> m \<and>
  shd (decr m js) = shd js2 \<and> stl (decr m js) = decr (shd js2) js2"
    (is "\<exists>js1 js2. ?\<phi> js js1 js2")
  using decr_ev[OF assms] m a ae proof (induction rule: ev_induct_strong)
  case (base js)
  thus ?case by  (intro exI[of _ "[]"] exI[of _ js]) auto
next
  case (step js)
  then obtain js1 js2 where 1: "?\<phi> (stl js) js1 js2" and [simp]: "shd js = m" by auto
  thus ?case
    by (intro exI[of _ "shd js # js1"] exI[of _ js2],
      simp, metis (lifting) decr_simps_eq step(2,4,5,6) stream.collapse)
qed

corollary stl_decr_shd:
  assumes a: "alw (\<lambda>js. (shd (stl js), shd js) \<in> Ord) js" and
    ae: "alw (ev (\<lambda>js. shd (stl js) \<noteq> shd js)) js"
  shows
    "\<exists>js1 js2. js = js1 @- js2 \<and> set js1 \<subseteq> {shd js} \<and>
 (shd js2, shd js) \<in> Ord \<and> shd js2 \<noteq> shd js \<and>
  shd (decr (shd js) js) = shd js2 \<and> stl (decr (shd js) js) = decr (shd js2) js2"
  using Ord unfolding well_order_on_defs by (intro stl_decr[OF assms]) blast

lemma decr:
  assumes a: "alw (\<lambda>js. (shd (stl js), shd js) \<in> Ord) js" (is "?a js")
    and ae: "alw (ev (\<lambda>js. shd (stl js) \<noteq> shd js)) js" (is "?ae js")
  shows
    "alw (\<lambda>js. (shd (stl js), shd js) \<in> Ord \<and> shd (stl js) \<noteq> shd js) (decr (shd js) js)"
    (is "alw ?\<phi> _")
proof-
  let ?\<xi> = "\<lambda>ls js. ls = decr (shd js) js \<and> ?a js \<and> ?ae js"
  {fix ls assume "\<exists>js. ?\<xi> ls js"
    hence "alw ?\<phi> ls" proof(elim alw_coinduct)
      fix ls assume "\<exists>js. ?\<xi> ls js"
      then obtain js where 1: "?\<xi> ls js" by auto
      then obtain js1 js2 where js: "js = js1 @- js2 \<and> set js1 \<subseteq> {shd js} \<and>
       (shd js2, shd js) \<in> Ord \<and> shd js2 \<noteq> shd js \<and>
       shd ls = shd js2 \<and> stl ls = decr (shd js2) js2"
        using stl_decr_shd by blast
      then obtain js3 js4 where js2: "js2 = js3 @- js4 \<and> set js3 \<subseteq> {shd js2} \<and>
       (shd js4, shd js2) \<in> Ord \<and> shd js4 \<noteq> shd js2 \<and>
       shd (decr (shd js2) js2) = shd js4 \<and> stl ((decr (shd js2) js2)) = decr (shd js4) js4"
        using stl_decr_shd[of js2] a ae using 1 alw_shift by blast
      show "?\<phi> ls" using 1 js js2 by metis
    qed (metis (no_types, lifting) alw_shift stl_decr_shd)
  }
  thus ?thesis using assms by blast
qed

lemma alw_snth:
  assumes "alw (\<lambda>xs. P (shd (stl xs)) (shd xs)) xs"
  shows "P (xs!!(Suc n)) (xs!! n)"
  using assms
  by (induction n, auto, metis (mono_tags) alw.cases alw_iff_sdrop sdrop_simps(1) sdrop_stl)

lemma F: False
proof-
  define ls where "ls = decr (shd ks) ks"
  have 0: "alw (\<lambda>js. (shd (stl js), shd js) \<in> Ord \<and> shd (stl js) \<noteq> shd js) ls"
    using decr[OF alw_ks alw_ev_ks] unfolding ls_def .
  define Q where "Q = range (snth ls)"  let ?wf = "Wellfounded.wf"
  have Q: "Q \<noteq> {}" unfolding Q_def by auto
  have 1: "?wf (Ord - Id)" using Ord unfolding well_order_on_def by auto
  obtain q where q: "q \<in> Q" and 2: "\<forall>q'. (q',q) \<in> Ord - Id \<longrightarrow> q' \<notin> Q"
    using wfE_min[OF 1] Q by auto
  obtain n where "ls!!n = q" using q unfolding Q_def by auto
  hence "(ls!!(Suc n),q) \<in> Ord - Id" using alw_snth[OF 0] by auto
  thus False using 2 Q_def by blast
qed

end (* context *)

(* Main theorem: *)
theorem infinite_soundness:
  assumes "wf t" and "good t" and "S \<in> structure"
  shows "sat S (fst (root t))"
  using F[OF assms] by auto

end (* context Infinite_Soundness *)

section \<open>Soundness of Cyclic Proof Trees\<close>

(* Cyclic trees *)

datatype (discs_sels) ('sequent, 'rule, 'link) ctree =
  Link 'link |
  cNode  "('sequent,'rule) step" "('sequent, 'rule, 'link) ctree fset"

corecursive treeOf where
  "treeOf pointsTo ct =
   (if \<exists>l l'. pointsTo l = Link l'
    \<comment> \<open>makes sense only if backward links point to normal nodes, not to backwards links:\<close>
     then undefined
     else (case ct of
             Link l \<Rightarrow> treeOf pointsTo (pointsTo l)
            |cNode step cts \<Rightarrow> Node step (fimage (treeOf pointsTo) cts)
          )
   )"
  by (relation "measure (\<lambda>(p,t). case t of Link l' => Suc 0 | _ => 0)") (auto split: ctree.splits)

declare treeOf.code[simp]

context Infinite_Soundness
begin

context
  fixes pointsTo :: "'link \<Rightarrow> ('sequent, 'rule, 'link)ctree"
  assumes pointsTo: "\<forall>l l'. pointsTo l \<noteq> Link l'"
begin

function seqOf where
  "seqOf (Link l) = seqOf (pointsTo l)"
|
  "seqOf (cNode (s,r) _) = s"
  by pat_completeness auto
termination
  by (relation "measure (\<lambda>t. case t of Link l' => Suc 0 | _ => 0)")
    (auto split: ctree.splits simp: pointsTo)

    (* Note: Here, "inductive" instead of "coinductive" would not do! *)
coinductive cwf where
  Node[intro!]: "cwf (pointsTo l) \<Longrightarrow> cwf (Link l)"
|
  cNode[intro]:
  "\<lbrakk>r \<in> R; eff r s (fimage seqOf cts); \<And>ct'. ct' |\<in>| cts \<Longrightarrow> cwf ct'\<rbrakk>
\<Longrightarrow>
cwf (cNode (s,r) cts)"

definition "cgood ct \<equiv> good (treeOf pointsTo ct)"

lemma cwf_Link: "cwf (Link l) \<longleftrightarrow> cwf (pointsTo l)"
  by (auto elim: cwf.cases)

lemma cwf_cNode_seqOf:
  "cwf (cNode (s, r) cts) \<Longrightarrow> eff r s (fimage seqOf cts)"
  by (auto elim: cwf.cases)

lemma treeOf_seqOf[simp]:
  "fst \<circ> root \<circ> treeOf pointsTo = seqOf"
proof(rule ext, unfold o_def)
  fix ct show "fst (root (treeOf pointsTo ct)) = seqOf ct"
    by induct (auto split: ctree.splits simp: pointsTo)
qed

lemma wf_treeOf:
  assumes "cwf ct"
  shows "wf (treeOf pointsTo ct)"
proof-
  {fix t let ?\<phi> = "\<lambda>ct t. cwf ct \<and> t = treeOf pointsTo ct"
    assume "\<exists>ct. ?\<phi> ct t" hence "wf t"
    proof(elim wf.coinduct, safe)
      fix ct let ?t = "treeOf pointsTo ct"
      assume ct: "cwf ct"
      show "
       \<exists>t. treeOf pointsTo ct = t \<and>
           snd (root t) \<in> R \<and>
           effStep (root t) (fimage (fst \<circ> root) (cont t)) \<and>
           (\<forall>t'. t' |\<in>| cont t \<longrightarrow> (\<exists>ct'. ?\<phi> ct' t') \<or> wf t')"
      proof(rule exI[of _ ?t], safe)
        show "snd (root ?t) \<in> R" using pointsTo ct
          by (auto elim: cwf.cases split: ctree.splits simp: cwf_Link)
        show "effStep (root ?t) (fimage (fst \<circ> root) (cont ?t))"
          using pointsTo ct by (auto  elim: cwf.cases split: ctree.splits simp: cwf_Link)
        {fix t' assume t': "t' |\<in>| cont ?t"
          show "\<exists>ct'. ?\<phi> ct' t'"
          proof(cases ct)
            case (Link l)
            then obtain s r cts where pl: "pointsTo l = cNode (s,r) cts"
              using pointsTo by (cases "pointsTo l") auto
            obtain ct' where ct': "ct' |\<in>| cts" and "t' = treeOf pointsTo ct'"
              using t' by (auto simp: Link pl pointsTo split: ctree.splits)
            moreover have "cwf ct'" using ct' ct pl unfolding Link
              by (auto simp: cwf_Link elim: cwf.cases)
            ultimately show ?thesis by blast
          next
            case (cNode step cts)
            then obtain s r where cNode: "ct = cNode (s,r) cts" by (cases step) auto
            obtain ct' where ct': "ct' |\<in>| cts" and "t' = treeOf pointsTo ct'"
              using t' by (auto simp: cNode pointsTo split: ctree.splits)
            moreover have "cwf ct'" using ct' ct unfolding cNode
              by (auto simp: cwf_Link elim: cwf.cases)
            ultimately show ?thesis by blast
          qed
        }
      qed
    qed
  }
  thus ?thesis using assms by blast
qed

theorem cyclic_soundness:
  assumes "cwf ct" and "cgood ct" and "S \<in> structure"
  shows "sat S (seqOf ct)"
  using infinite_soundness wf_treeOf assms
  unfolding cgood_def treeOf_seqOf[symmetric] comp_def
  by blast

end (* context *)

end (* context Infinite_Soundness *)

section \<open>Appendix: The definition of treeOf under more flexible assumptions about pointsTo\<close>

definition rels where
  "rels pointsTo \<equiv> {((pointsTo, pointsTo l'), (pointsTo, Link l')) | l'. True}"

definition rel :: "(('link \<Rightarrow> ('sequent, 'rule, 'link) ctree) \<times> ('sequent, 'rule, 'link) ctree) rel" where
  "rel \<equiv> \<Union> (rels ` {pointsTo. wf {(l, l'). pointsTo l' = Link l}})"

lemma wf_rels[simp]:
  assumes "wf {(l,l'). (pointsTo :: 'link \<Rightarrow> ('sequent, 'rule, 'link)ctree) l' = Link l}"
    (is "wf ?w")
  shows "wf (rels pointsTo)" using wf_map_prod_image
proof -
  define r1 :: "(('link \<Rightarrow> ('sequent, 'rule, 'link) ctree) \<times> ('sequent, 'rule, 'link) ctree) rel" where
    "r1 = {((pointsTo,pointsTo l'), (pointsTo, Link l'::('sequent, 'rule, 'link) ctree)) | l'.
                 (\<forall>l''. pointsTo l' \<noteq> Link l'')}"
  define r2 :: "(('link \<Rightarrow> ('sequent, 'rule, 'link) ctree) \<times> ('sequent, 'rule, 'link) ctree) rel" where
    "r2 = image (map_prod (map_prod id Link) (map_prod id Link)) (inv_image ?w snd)"
  have 0: "rels pointsTo \<subseteq> r1 \<union> r2"
    unfolding rels_def r1_def r2_def unfolding inv_image_def image_Collect by auto
  let ?m = "measure (\<lambda>(tOfL,t). case t of Link l' => Suc 0 | _ => 0)"
  have 1: "wf r1" unfolding r1_def by (rule wf_subset[of ?m]) (auto split: ctree.splits)
  have 2: "wf r2" using assms unfolding r2_def
    by (intro wf_map_prod_image wf_inv_image) (auto simp: inj_on_def)
  have 3: "Domain r1 \<inter> Range r2 = {}" unfolding r1_def r2_def by auto
  show ?thesis using 1 2 3 by (intro wf_subset[OF _ 0] wf_Un) auto
qed

lemma rel: "wf rel"
  unfolding rel_def
  apply(rule wf_UN)
  subgoal by (auto intro: wf_UN)
  unfolding rels_def by auto

corecursive treeOf' where
  "treeOf' pointsTo ct =
   (if \<not> wf {(l',l).  pointsTo l = Link l'}
    \<comment> \<open>makes sense only if backward links point to normal nodes, not to backwards links:\<close>
     then undefined
     else (case ct of
             Link l \<Rightarrow> treeOf' pointsTo (pointsTo l)
            |cNode step cts \<Rightarrow> Node step (fimage (treeOf' pointsTo) cts)
          )
   )"
  apply(relation rel) using rel unfolding rel_def rels_def[abs_def] by auto

(*<*)
end
(*>*)


section \<open>A kildall's algorithm for computing dominators\<close>

theory Dom_Kildall
imports Dom_Semi_List  "HOL-Library.While_Combinator" "Jinja.SemilatAlg"
begin

text \<open>A kildall's algorithm for computing dominators.
      It uses the ideas and the framework of kildall's algorithm implemented in Jinja \<^cite>\<open>"Kildall-AFP"\<close>,
      and modifications are needed to make it work for a fast algorithm for computing dominators\<close>

type_synonym state_dom = "nat list "

primrec  propa ::
  "'s binop \<Rightarrow> (nat \<times> 's) list \<Rightarrow> 's list \<Rightarrow> nat list \<Rightarrow> 's list * nat list"
where
  "propa f []      \<tau>s wl = (\<tau>s,wl)"
| "propa f (q'# qs) \<tau>s wl = (let (q,\<tau>) = q';
                             u =  (\<tau> \<squnion>\<^bsub>f\<^esub> \<tau>s!q);
                             wl' = (if u = \<tau>s!q then wl
                                    else (insort q (remove1 q wl)))
                         in propa f qs (\<tau>s[q := u]) wl')"

definition  iter ::
  "'s binop \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> nat list \<Rightarrow> 's list \<times> nat list"
where
  "iter f step \<tau>s w =
   while (\<lambda>(\<tau>s,w). w \<noteq> [])
         (\<lambda>(\<tau>s,w). let p = hd w
                   in propa f (step p (\<tau>s!p)) \<tau>s (tl w))
         (\<tau>s,w)"

definition unstables :: "state_dom ord \<Rightarrow>  state_dom step_type \<Rightarrow> state_dom list \<Rightarrow> nat list"
where
  "unstables r step \<tau>s = sorted_list_of_set  {p. p < size \<tau>s \<and> \<not> stable r step \<tau>s p}"

definition  kildall :: "state_dom ord \<Rightarrow>state_dom binop  \<Rightarrow> state_dom step_type \<Rightarrow> state_dom list \<Rightarrow> state_dom list" where
  "kildall r f step \<tau>s = fst(iter f step \<tau>s (unstables r step \<tau>s))"

lemma init_worklist_is_sorted: "sorted (unstables r step \<tau>s)"
  by (simp add:sorted_less_sorted_list_of_set unstables_def)

context cfg_doms

begin

definition transf :: "node \<Rightarrow> state_dom \<Rightarrow> state_dom " where
"transf n input \<equiv>  (n # input)"

definition exec :: "node \<Rightarrow> state_dom \<Rightarrow> (node \<times> state_dom) list"
  where "exec n xs = map (\<lambda>pc. (pc, (transf n xs))) (rev (sorted_list_of_set(succs n)))"

lemma transf_res_is_rev: "sorted (rev ns) \<Longrightarrow> n > hd ns  \<Longrightarrow> sorted (rev ((transf n ( ns))))"
  by (induct ns) (auto simp add:transf_def sorted_wrt_append)

abbreviation "start \<equiv>  [] # (replicate (length (g_V G) - 1) ( (rev[0..<length(g_V G)])))"

definition dom_kildall :: "state_dom list \<Rightarrow> state_dom list"
  where "dom_kildall = kildall (fst (snd nodes_semi)) (snd (snd nodes_semi)) exec"

definition dom:: "nat \<Rightarrow> nat \<Rightarrow> bool" where
"dom i j \<equiv>(let res = (dom_kildall start) !j in i \<in> (set res) \<or> i = j )"

lemma dom_refl: "dom i i"
  by (unfold dom_def) simp

definition strict_dom :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
"strict_dom i j \<equiv> (let res = (dom_kildall start) !j in  i \<in> set res)"

lemma strict_domI1: "(dom_kildall ([] # (replicate (length (g_V G) - 1) ( (rev[0..<length(g_V G)])))))!j =  res \<Longrightarrow> i \<in> set res \<Longrightarrow> strict_dom i j"
  by (auto simp add:strict_dom_def )

lemma strict_domD:
  "strict_dom i j \<Longrightarrow>
  dom_kildall (( [] # (replicate (length (g_V G) - 1) ( (rev[0..<length(g_V G)])))))!j  =  a \<Longrightarrow>
  i \<in> set a"
  by (auto simp add:strict_dom_def )

lemma sdom_dom: "strict_dom i j \<Longrightarrow> dom i j"
  by (unfold strict_dom_def) (auto simp add:dom_def)

lemma not_sdom_not_dom: "\<not>strict_dom i j \<Longrightarrow> i \<noteq> j \<Longrightarrow> \<not>dom i j"
  by (unfold strict_dom_def) (auto simp add:dom_def)

lemma dom_sdom: "dom i j \<Longrightarrow> i \<noteq> j \<Longrightarrow> strict_dom i j"
  by (unfold dom_def)  (auto simp add:dom_def strict_dom_def)

end

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_69
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun t22 :: "Nat => Nat => Nat" where
  "t22 (Z) y = y"
| "t22 (S z) y = S (t22 z y)"

fun t2 :: "Nat => Nat => bool" where
  "t2 (Z) y = True"
| "t2 (S z) (Z) = False"
| "t2 (S z) (S x2) = t2 z x2"

theorem property0 :
  "t2 n (t22 m n)"
  oops

end


(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection \<open>A fast coprimality approximation\<close>

text \<open>We adapt the integer polynomial gcd algorithm so that it
  first tests whether $f$ and $g$ are coprime modulo a few primes.
  If so, we are immediately done.\<close>

theory Gcd_Finite_Field_Impl
imports
  Suitable_Prime
  Code_Abort_Gcd
  "HOL-Library.Code_Target_Int" (* to be able to efficiently primality of medium large numbers *)
begin

definition coprime_approx_main :: "int \<Rightarrow> 'i arith_ops_record \<Rightarrow> int poly \<Rightarrow> int poly \<Rightarrow> bool" where
  "coprime_approx_main p ff_ops f g = (gcd_poly_i ff_ops (of_int_poly_i ff_ops (poly_mod.Mp p f))
     (of_int_poly_i ff_ops (poly_mod.Mp p g)) = one_poly_i ff_ops)"

lemma (in prime_field_gen) coprime_approx_main:
  shows "coprime_approx_main p ff_ops f g \<Longrightarrow> coprime_m f g"
proof -
  define F where F: "(F :: 'a mod_ring poly) = of_int_poly (Mp f)"
  define G where G: "(G :: 'a mod_ring poly) = of_int_poly (Mp g)"  let ?f' = "of_int_poly_i ff_ops (Mp f)"
  let ?g' = "of_int_poly_i ff_ops (Mp g)"
  define f'' where "f'' \<equiv> of_int_poly (Mp f) :: 'a mod_ring poly"
  define g'' where "g'' \<equiv> of_int_poly (Mp g) :: 'a mod_ring poly"
  have rel_f[transfer_rule]: "poly_rel ?f' f''"
    by (rule poly_rel_of_int_poly[OF refl], simp add: f''_def)
  have rel_f[transfer_rule]: "poly_rel ?g' g''"
    by (rule poly_rel_of_int_poly[OF refl], simp add: g''_def)
  have id: "(gcd_poly_i ff_ops (of_int_poly_i ff_ops (Mp f)) (of_int_poly_i ff_ops (Mp g)) = one_poly_i ff_ops)
    = coprime f'' g''" (is "?P \<longleftrightarrow> ?Q")
  proof -
    have "?P \<longleftrightarrow> gcd f'' g'' = 1"
      unfolding separable_i_def by transfer_prover
    also have "\<dots> \<longleftrightarrow> ?Q"
      by (simp add: coprime_iff_gcd_eq_1)
    finally show ?thesis .
  qed
  have fF: "MP_Rel (Mp f) F" unfolding F MP_Rel_def
    by (simp add: Mp_f_representative)
  have gG: "MP_Rel (Mp g) G" unfolding G MP_Rel_def
    by (simp add: Mp_f_representative)
  have "coprime f'' g'' = coprime F G" unfolding f''_def F g''_def G by simp
  also have "\<dots> = coprime_m (Mp f) (Mp g)"
    using coprime_MP_Rel[unfolded rel_fun_def, rule_format, OF fF gG] by simp
  also have "\<dots> = coprime_m f g" unfolding coprime_m_def dvdm_def by simp
  finally have id2: "coprime f'' g'' = coprime_m f g" .
  show "coprime_approx_main p ff_ops f g \<Longrightarrow> coprime_m f g" unfolding coprime_approx_main_def
    id id2 by auto
qed

context poly_mod_prime begin

lemmas coprime_approx_main_uint32 = prime_field_gen.coprime_approx_main[OF
        prime_field.prime_field_finite_field_ops32, unfolded prime_field_def mod_ring_locale_def
   poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas coprime_approx_main_uint64 = prime_field_gen.coprime_approx_main[OF
        prime_field.prime_field_finite_field_ops64, unfolded prime_field_def mod_ring_locale_def
   poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

end

lemma coprime_mod_imp_coprime: assumes
  p: "prime p" and
  cop_m: "poly_mod.coprime_m p f g" and
  cop: "coprime (lead_coeff f) p \<or> coprime (lead_coeff g) p" and
  cnt: "content f = 1 \<or> content g = 1"
  shows "coprime f g"
proof -
  interpret poly_mod_prime p by (standard, rule p)
  from cop_m[unfolded coprime_m_def] have cop_m: "\<And> h. h dvdm f \<Longrightarrow> h dvdm g \<Longrightarrow> h dvdm 1"  by auto
  show ?thesis
  proof (rule coprimeI)
    fix h
    assume dvd: "h dvd f" "h dvd g"
    hence "h dvdm f" "h dvdm g" unfolding dvdm_def dvd_def by auto
    from cop_m[OF this] obtain k where unit: "Mp (h * Mp k) = 1" unfolding dvdm_def by auto
    from content_dvd_contentI[OF dvd(1)] content_dvd_contentI[OF dvd(2)] cnt
    have cnt: "content h = 1" by auto
    let ?k = "Mp k"
    from unit have h0: "h \<noteq> 0" by auto
    from unit have k0: "?k \<noteq> 0" by fastforce
    from p have p0: "p \<noteq> 0" by auto
    from dvd have "lead_coeff h dvd lead_coeff f" "lead_coeff h dvd lead_coeff g"
      by (metis dvd_def lead_coeff_mult)+
    with cop have coph: "coprime (lead_coeff h) p"
      by (meson dvd_trans not_coprime_iff_common_factor)
    let ?k = "Mp k"
    from arg_cong[OF unit, of degree] have degm0: "degree_m (h * ?k) = 0" by simp
    have "lead_coeff ?k \<in> {0 ..< p}" unfolding Mp_coeff M_def using m1 by simp
    with k0 have lk: "lead_coeff ?k \<ge> 1" "lead_coeff ?k < p"
      by (auto simp add: int_one_le_iff_zero_less order.not_eq_order_implies_strict)
    have id: "lead_coeff (h * ?k) = lead_coeff h * lead_coeff ?k" unfolding lead_coeff_mult ..
    from coph prime lk have "coprime (lead_coeff h * lead_coeff ?k) p"
      by (simp add: ac_simps prime_imp_coprime zdvd_not_zless)
    with id have cop_prod: "coprime (lead_coeff (h * ?k)) p" by simp
    from h0 k0 have lc0: "lead_coeff (h * ?k) \<noteq> 0"
      unfolding lead_coeff_mult by auto
    from p have lcp: "lead_coeff (h * ?k) mod p \<noteq> 0"
      using M_1 M_def cop_prod by auto
    have deg_eq: "degree_m (h * ?k) = degree (h * Mp k)"
      by (rule degree_m_eq[OF _ m1], insert lcp)
    from this[unfolded degm0] have "degree (h * Mp k) = 0" by simp
    with degree_mult_eq[OF h0 k0] have deg0: "degree h = 0" by auto
    from degree0_coeffs[OF this] obtain h0 where h: "h = [:h0:]" by auto
    have "content h = abs h0" unfolding content_def h by (cases "h0 = 0", auto)
    hence "abs h0 = 1" using cnt by auto
    hence "h0 \<in> {-1,1}" by auto
    hence "h = 1 \<or> h = -1" unfolding h by (auto)
    thus "is_unit h" by auto
  qed
qed

text \<open>We did not try to optimize the set of chosen primes. They have just been picked
  randomly from a list of primes.\<close>

definition gcd_primes32 :: "int list" where
  "gcd_primes32 = [383, 1409, 19213, 22003, 41999]"

lemma gcd_primes32: "p \<in> set gcd_primes32 \<Longrightarrow> prime p \<and> p \<le> 65535"
proof -
  have "list_all (\<lambda> p. prime p \<and> p \<le> 65535) gcd_primes32" by eval
  thus "p \<in> set gcd_primes32 \<Longrightarrow> prime p \<and> p \<le> 65535" by (auto simp: list_all_iff)
qed

definition gcd_primes64 :: "int list" where
  "gcd_primes64 = [383, 21984191, 50329901, 80329901, 219849193]"

lemma gcd_primes64: "p \<in> set gcd_primes64 \<Longrightarrow> prime p \<and> p \<le> 4294967295"
proof -
  have "list_all (\<lambda> p. prime p \<and> p \<le> 4294967295) gcd_primes64" by eval
  thus "p \<in> set gcd_primes64 \<Longrightarrow> prime p \<and> p \<le> 4294967295" by (auto simp: list_all_iff)
qed

definition coprime_heuristic :: "int poly \<Rightarrow> int poly \<Rightarrow> bool" where
  "coprime_heuristic f g = (let lcf = lead_coeff f; lcg = lead_coeff g in
    find (\<lambda> p. (coprime lcf p \<or> coprime lcg p) \<and> coprime_approx_main p (finite_field_ops64 (uint64_of_int p)) f g)
    gcd_primes64 \<noteq> None)"

lemma coprime_heuristic: assumes "coprime_heuristic f g"
  and "content f = 1 \<or> content g = 1"
  shows "coprime f g"
proof (cases "find (\<lambda>p. (coprime (lead_coeff f) p \<or> coprime (lead_coeff g) p) \<and>
            coprime_approx_main p (finite_field_ops64 (uint64_of_int p)) f g)
   gcd_primes64")
  case (Some p)
  from find_Some_D[OF Some] gcd_primes64 have p: "prime p" and small: "p \<le> 4294967295"
    and cop: "coprime (lead_coeff f) p \<or> coprime (lead_coeff g) p"
    and copp: "coprime_approx_main p (finite_field_ops64 (uint64_of_int p)) f g" by auto
  interpret poly_mod_prime p using p by unfold_locales
  from coprime_approx_main_uint64[OF small copp] have "poly_mod.coprime_m p f g" by auto
  from coprime_mod_imp_coprime[OF p this cop assms(2)] show "coprime f g" .
qed (insert assms(1)[unfolded coprime_heuristic_def], auto simp: Let_def)

definition gcd_int_poly :: "int poly \<Rightarrow> int poly \<Rightarrow> int poly" where
  "gcd_int_poly f g =
    (if f = 0 then normalize g
     else if g = 0 then normalize f
          else let
            cf = Polynomial.content f;
            cg = Polynomial.content g;
            ct = gcd cf cg;
            ff = map_poly (\<lambda> x. x div cf) f;
            gg = map_poly (\<lambda> x. x div cg) g
          in if coprime_heuristic ff gg then [:ct:] else smult ct (gcd_poly_code_aux ff gg))"

lemma gcd_int_poly_code[code_unfold]: "gcd = gcd_int_poly"
proof (intro ext)
  fix f g :: "int poly"
  let ?ff = "primitive_part f"
  let ?gg = "primitive_part g"
  note d = gcd_int_poly_def gcd_poly_code gcd_poly_code_def
  show "gcd f g = gcd_int_poly f g"
  proof (cases "f = 0 \<or> g = 0 \<or> \<not> coprime_heuristic ?ff ?gg")
    case True
    thus ?thesis unfolding d by (auto simp: Let_def primitive_part_def)
  next
    case False
    hence cop: "coprime_heuristic ?ff ?gg" by simp
    from False have "f \<noteq> 0" by auto
    from content_primitive_part[OF this] coprime_heuristic[OF cop]
    have id: "gcd ?ff ?gg = 1" by auto
    show ?thesis unfolding gcd_poly_decompose[of f g] unfolding gcd_int_poly_def Let_def id
      using False by (auto simp: primitive_part_def)
  qed
qed

end