theory embedding_frames
  imports embedding_shallow
begin

(*we introduce some default modalities and constraints*)
consts \<R>::"w\<Rightarrow>\<sigma>"  (*binary accessibility relation*)
consts \<T>::"w\<Rightarrow>(w\<Rightarrow>\<sigma>)"  (*ternary accessibility relation*)
(*for multi-modal logics we can provide the accessibility relation as a parameter*)

definition box::"\<sigma>\<Rightarrow>\<sigma>" ("\<box>_" [57]58) where "\<box>A \<equiv> \<lambda>w. \<forall>v. \<R> w v \<longrightarrow> A v"
definition dia::"\<sigma>\<Rightarrow>\<sigma>" ("\<diamond>_" [57]58) where "\<diamond>A \<equiv> \<lambda>w. \<exists>v. \<R> w v \<and>  A v"
definition fusion::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr "\<otimes>" 80) where "A \<otimes> B \<equiv> \<lambda>x. (\<exists>y z. (\<T> y z x \<and> A y) \<and> B z)"
definition impl::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr "\<Rightarrow>" 80) where "A \<Rightarrow> B \<equiv> \<lambda>x. (\<forall>y z. (\<T> y x z \<and> A y) \<longrightarrow> B z)"
definition lpmi::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr "\<Leftarrow>" 80) where "B \<Leftarrow> A \<equiv> \<lambda>x. (\<forall>y z. (\<T> x y z \<and> A y) \<longrightarrow> B z)"

lemma assoc: "(A \<otimes> (B \<otimes> C)) = ((A \<otimes> B) \<otimes> C)" nitpick oops (*non assoc*)
lemma exchange: "(A \<otimes> B) = (B \<otimes> A)" nitpick oops  (*non comm*)
lemma contraction: "(A \<otimes> A) = A" nitpick oops (*non idem*)
lemma lw: "(A \<otimes> B) \<subseteq> A" nitpick oops

lemma "A \<otimes> (A \<Rightarrow> B) \<subseteq> B" using impl_def fusion_def subset_def by fastforce
lemma "B \<subseteq> A \<Rightarrow> (A \<otimes> B)" using impl_def fusion_def subset_def by fastforce
lemma "(B \<Leftarrow> A) \<otimes> A \<subseteq> B" using fusion_def lpmi_def subset_def by fastforce

lemma "A \<subseteq> B \<and> C \<subseteq> D \<longrightarrow> A \<otimes> C \<subseteq> B \<otimes> D" by (smt (verit, del_insts) fusion_def subset_def)
lemma "A \<subseteq> B \<and> C \<subseteq> D \<longrightarrow> B \<Rightarrow> C \<subseteq> A \<Rightarrow> D" by (smt (verit, ccfv_SIG) impl_def subset_def)
lemma "A \<subseteq> B \<and> C \<subseteq> D \<longrightarrow> C \<Leftarrow> B \<subseteq> D \<Leftarrow> A" by (smt (verit, best) lpmi_def subset_def)

(*We can say of two unary operators \<phi> and \<psi> that they form an "adjoint" or "residuated" pair.
 We then call \<phi> (\<psi>) the down (up) adjoint/residue to/of \<psi> (\<phi>).*)
definition Residuated::"\<sigma> Rel \<Rightarrow> (\<sigma>\<Rightarrow>\<sigma>)Rel" ("_-RESID")
  where "R-RESID \<phi> \<psi> \<equiv> \<forall>A B. R (\<phi> A) B \<longleftrightarrow> R A (\<psi> B)"

(*We can express residuation for binary operators in two different flavours*)
abbreviation Residuated_left::"\<sigma> Rel \<Rightarrow> (\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>)Rel" ("_-RESID\<^sup>l")
  where "R-RESID\<^sup>l \<phi> \<psi> \<equiv> \<forall>A. R-RESID (\<phi> A) (\<psi> A)"
abbreviation Residuated_right::"\<sigma> Rel \<Rightarrow> (\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>)Rel" ("_-RESID\<^sup>r")
  where "R-RESID\<^sup>r \<phi> \<psi> \<equiv> \<forall>A. R-RESID (\<phi>\<^sup>T A) (\<psi>\<^sup>T A)"

lemma "R-RESID\<^sup>l \<phi> \<psi> = (\<forall>A B C. R (\<phi> A B) C \<longleftrightarrow> R B (\<psi> A C))" unfolding Residuated_def by simp
lemma "R-RESID\<^sup>r \<phi> \<psi> = (\<forall>A B C. R (\<phi> B A) C \<longleftrightarrow> R B (\<psi> C A))" unfolding Residuated_def by simp

(*For instance*)
lemma "(\<preceq>)-RESID\<^sup>l (\<inter>) (\<rightarrow>) \<longleftrightarrow> (A \<inter> B \<preceq> C \<longleftrightarrow> B \<preceq> A \<rightarrow> C)" by (smt (verit, best) Residuated_def base.impl_def inter_def subset_def)
lemma "(\<preceq>)-RESID\<^sup>r (\<leftharpoonup>) (\<union>) \<longleftrightarrow> (B \<leftharpoonup> A \<preceq> C \<longleftrightarrow> B \<preceq> C \<union> A)" by (smt (verit) Residuated_def diff_def subset_def union_def)

(*We have in fact*)
lemma "(\<preceq>)-RESID\<^sup>l (\<inter>) (\<rightarrow>)" by (smt (verit, ccfv_SIG) Residuated_def base.impl_def inter_def subset_def)
lemma "(\<preceq>)-RESID\<^sup>r (\<leftharpoonup>) (\<union>)" by (smt (verit, best) Residuated_def diff_def subset_def union_def)
(*And also*)
lemma "(\<preceq>)-RESID\<^sup>l (\<otimes>) (\<Rightarrow>)" by (smt (z3) Residuated_def impl_def fusion_def subset_def)
lemma "(\<preceq>)-RESID\<^sup>r (\<otimes>) (\<Leftarrow>)" by (smt (z3) Residuated_def fusion_def lpmi_def subset_def)

lemma "(\<Leftarrow>) = (\<Rightarrow>)\<^sup>T" nitpick oops

axiomatization
  where assoc\<T>: "\<forall>x y z u. (\<exists>s. \<T> x y s \<and> \<T> s z u) \<longleftrightarrow> (\<exists>t. \<T> x t u \<and> \<T> y z t) "

lemma assoc: "(A \<otimes> (B \<otimes> C)) = ((A \<otimes> B) \<otimes> C)" unfolding fusion_def using assoc\<T> by fastforce (*assoc*)

axiomatization
  where comm\<T>: "\<forall>x y u. \<T> x y u \<longleftrightarrow> (\<T> y x u) "

lemma exchange: "(A \<otimes> B) = (B \<otimes> A)" unfolding fusion_def by (meson comm\<T>)
lemma "(\<preceq>)-RESID\<^sup>r (\<otimes>) (\<Leftarrow>)" by (smt (z3) Residuated_def fusion_def lpmi_def subset_def)
lemma "(\<Leftarrow>) = (\<Rightarrow>)\<^sup>T" using comm\<T> impl_def lpmi_def by presburger

lemma contraction1: "(A \<otimes> A) \<subseteq> A" nitpick oops
lemma contraction2: "A  \<subseteq> (A \<otimes> A)" nitpick oops
lemma lw: "(A \<otimes> B) \<subseteq> A" nitpick oops

definition par::"\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr "\<oplus>" 79) where "A \<oplus> B \<equiv> \<midarrow>(\<midarrow>A \<otimes> \<midarrow>B)"
lemma "A \<otimes> \<midarrow>A \<approx> \<emptyset>" nitpick oops
lemma "A \<oplus> \<midarrow>A \<approx> \<UU>" nitpick oops

end


theory ModalEmbedCompleteness
  imports Main

begin
declare [["syntax_ambiguity_warning" = false]]

context begin

(* ########################################################################## *)
(* utility methods: conversion from sets to precidates and vice versa.  *)
definition set_to_pred :: "'a set \<Rightarrow> ('a \<Rightarrow> bool)"
  where "set_to_pred M \<equiv> \<lambda>x. (x \<in> M)"
definition pred_to_set :: "('a \<Rightarrow> bool) \<Rightarrow> 'a set"
  where "pred_to_set P \<equiv> {x. P x}"

lemma setPred1: "\<forall>M. x \<in> M \<longleftrightarrow> (set_to_pred M) x" unfolding set_to_pred_def by auto
lemma setPred2: "\<forall>P. P x \<longleftrightarrow> x \<in> (pred_to_set P)" unfolding pred_to_set_def by auto

definition rel_to_pred :: "'a rel \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)"
  where "rel_to_pred R \<equiv> \<lambda>x y. (x,y) \<in> R"
definition pred_to_rel :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a rel"
  where "pred_to_rel P \<equiv> {(x,y) | x y. P x y}"

lemma relPred1: "\<forall>R. (x,y) \<in> R \<longleftrightarrow> (rel_to_pred R) x y" unfolding rel_to_pred_def by auto
lemma relPred2: "\<forall>P. P x y \<longleftrightarrow> (x, y) \<in> (pred_to_rel P)" unfolding pred_to_rel_def by auto
(* utility end *)
(* ########################################################################## *)

type_synonym id = string  \<comment> \<open>type of atomic propositions, here: strings\<close>
typedecl i
type_synonym acc = "i \<Rightarrow> i \<Rightarrow> bool" \<comment> \<open>accessibility relation type\<close>
type_synonym varassgn = "id \<Rightarrow> i \<Rightarrow> bool" \<comment> \<open>type of variable assignment\<close>

(* ########################################################################## *)
(* Embedding BEGIN *)
datatype fm              \<comment> \<open>type of modal logic formulas\<close>
 = Atom id ("\<langle>_\<rangle>")
 | Impl fm fm (infixr "\<^bold>\<longrightarrow>" 49)
 | Neg fm ("\<^bold>\<not> _" [52]53)
 | Box fm ("\<^bold>\<box> _" [52]53)

(* embedding function on the object logic level *)
fun embed :: "fm \<Rightarrow> acc \<Rightarrow> varassgn \<Rightarrow> (i \<Rightarrow> bool)" ("\<lceil>_\<rceil>"[50]50)
  where
    "\<lceil>Atom p\<rceil> = (\<lambda>r. \<lambda>g.(\<lambda>w. g p w))"
  | "\<lceil>Impl p q\<rceil> = (\<lambda>r. \<lambda>g. (\<lambda>w. (((\<lceil>p\<rceil>) r g) w) \<longrightarrow> (((\<lceil>q\<rceil>) r g) w)))"
  | "\<lceil>Neg p\<rceil> = (\<lambda>r. \<lambda>g. (\<lambda>w. \<not> (((\<lceil>p\<rceil>) r g) w)))"
  | "\<lceil>Box p\<rceil> = (\<lambda>r. \<lambda>g. (\<lambda>w. \<forall>v. (r w v) \<longrightarrow> (((\<lceil>p\<rceil>) r g) v)))"

abbreviation disj :: "fm \<Rightarrow> fm \<Rightarrow> fm" (infixr "\<^bold>\<or>" 50)
  where "\<phi> \<^bold>\<or> \<psi> \<equiv> (\<^bold>\<not>\<phi>) \<^bold>\<longrightarrow> \<psi>"
abbreviation conj :: "fm \<Rightarrow> fm \<Rightarrow> fm" (infixr "\<^bold>\<and>" 51)
  where "\<phi> \<^bold>\<and> \<psi> \<equiv> \<^bold>\<not>((\<^bold>\<not>\<phi>) \<^bold>\<or> (\<^bold>\<not>\<psi>))"

definition grounding :: "(i \<Rightarrow> bool) \<Rightarrow> bool" ("\<lfloor>_\<rfloor>")
  where "\<lfloor>\<phi>\<rfloor> \<equiv> \<forall>w. \<phi> w"

(* for testing, pretty much as usual, only with explicit r and g *)
lemma "\<lfloor>((\<lceil>(p \<^bold>\<or> \<^bold>\<not>p)\<rceil>) r g)\<rfloor>" by (simp add: grounding_def)
lemma "\<lfloor>((\<lceil>(\<^bold>\<box>(p \<^bold>\<or> \<^bold>\<not>p))\<rceil>) r g)\<rfloor>" by (simp add: grounding_def)

(* Embedding END *)
(* ########################################################################## *)

(* ########################################################################## *)
(* Reference semantics BEGIN *)

datatype kripke = Kripke (\<pi>: "id \<Rightarrow> i set") (\<R>: "i rel")

fun validity_wrt_model_world :: "kripke \<Rightarrow> i \<Rightarrow> fm \<Rightarrow> bool"
  ("_,_ \<Turnstile> _" [50,50]50) where
  "(M,w \<Turnstile> (Atom x)) = (w \<in> \<pi> M x)"
| "(M,w \<Turnstile> (Impl \<phi> \<psi>)) = ((M,w \<Turnstile> \<phi>) \<longrightarrow> (M,w \<Turnstile> \<psi>))"
| "(M,w \<Turnstile> (Neg \<phi>)) = (\<not>(M,w \<Turnstile> \<phi>))"
| "(M,w \<Turnstile> (Box \<phi>)) = (\<forall>v. ((w, v) \<in> \<R> M) \<longrightarrow> (M,v \<Turnstile> \<phi>))"
(* semantics end *)

definition validity_wrt_model :: "kripke \<Rightarrow> fm \<Rightarrow> bool"
 ("_ \<Turnstile> _" [50]50) where "(M \<Turnstile> \<phi>) \<equiv> \<forall>w. M,w \<Turnstile> \<phi>"

definition valid :: "fm \<Rightarrow> bool"
 ("\<Turnstile> _" 50) where "(\<Turnstile> \<phi>) \<equiv> \<forall>M. M \<Turnstile> \<phi>"

(* consistency *)
lemma "True" nitpick[satisfy,expect=genuine] oops

(* Reference semantics END *)
(* ########################################################################## *)

(* ########################################################################## *)
(* faithfulness BEGIN *)

(* relate predicates to sets and/or relations *)
lemma eval: "\<forall>w. (embed \<phi>) r g w = ((Kripke (\<lambda>v. pred_to_set (g v)) (pred_to_rel r)), w \<Turnstile> \<phi>) "
  unfolding pred_to_set_def pred_to_rel_def by (induct \<phi>; simp_all)

lemma eval': "\<forall>w. (embed \<phi>) (rel_to_pred r) (\<lambda>id. set_to_pred (g id)) w = ((Kripke g r), w \<Turnstile> \<phi>)"
  unfolding set_to_pred_def rel_to_pred_def by (induct \<phi>; simp_all)

(* both directions *)

lemma completeness: "\<Turnstile> \<phi>  \<Longrightarrow> (\<forall>r g. \<lfloor>(embed \<phi>) r g\<rfloor>) "
  unfolding valid_def validity_wrt_model_def grounding_def by (metis eval)

(* actual faithfulness *)
theorem "\<Turnstile> \<phi> \<longleftrightarrow> (\<forall>r g. \<lfloor>(embed \<phi>) r g\<rfloor>)" using soundness completeness by auto

(*faithfulness END *)
(* ########################################################################## *)

end

end


theory Vwalk_Cycle
  imports "../Auxiliaries/List_Auxiliaries" "../Auxiliaries/Graph_Auxiliaries"
begin

section\<open>Vwalk_Cycle\<close>

subsection\<open>Definitions\<close>

definition vwalk_cycle where
  "vwalk_cycle G p \<equiv> distinct (tl p) \<and> vwalk p G \<and> hd p = last p \<and> length p \<ge> 2"

subsection\<open>Auxiliary proofs\<close>

lemma vwalk_cycle_rev:
  assumes "symmetric G" "vwalk_cycle G p"
  shows "vwalk_cycle G (rev p)"
  using assms unfolding vwalk_cycle_def
  by(auto simp add: distinct_tl_rev_C vwalk_rev_ex hd_rev last_rev)

lemma vwalk_cycle_not_empty:
  assumes "vwalk_cycle G p"
  shows "p \<noteq> []"
  using vwalk_cycle_def assms vwalk_def by auto

lemma vwalk_cycle_vwalk_arcs:
  assumes "vwalk_cycle G p"
  shows "vwalk_arcs p \<noteq> []"
  using assms vwalk_cycle_def vwalk_arcs_empty_length_p
  by (metis add_leD2 le_antisym nat_1_add_1 nat_le_iff_add num.distinct(1) one_eq_numeral_iff)

lemma vwalk_cycle_impl_cycle:
  assumes "head G = snd" "tail G = fst" "vwalk_cycle G p"
  shows "pre_digraph.cycle G (vwalk_arcs p)"
  using assms
  unfolding pre_digraph.cycle_def vwalk_cycle_def
  using assms vwalk_cycle_vwalk_arcs distinct_awalk_verts_vwalk_arcs awalk_vwalk_length_at_least_2
  by metis

subsubsection\<open>Cycle and Vwalk_cycle are the same\<close>

lemma cycle_implies_vwalk_cycle:
  assumes "head G = snd" "tail G = fst" "pre_digraph.cycle G (vwalk_arcs c)"
    "length c \<ge> 2" "wf_digraph G"
  shows "vwalk_cycle G c"
proof -
  have "\<forall>u. pre_digraph.awalk_verts G u (vwalk_arcs c) = c"
    using assms at_least_two_nodes_vwalk_arcs_awalk_verts
    by force
  then have 1: "distinct (tl c)"
    using assms pre_digraph.cycle_def
    by metis
  have 3: "vwalk c G"
    using assms  \<open>\<forall>u. pre_digraph.awalk_verts G u (vwalk_arcs c) = c\<close>
    by (metis wf_digraph.awalk_imp_vwalk wf_digraph.cycle_conv)
  have 4: "hd c = last c"
    using hd_last_cycle assms
    by metis
  then show ?thesis
    using 1 3 4 vwalk_cycle_def assms
    by blast
qed

end


theory Incredible_Predicate imports
  Abstract_Rules_To_Incredible
  Predicate_Formulas
  Stream_Ext
begin

text \<open>Our example interpretation with predicate logic will cover implication and the
  universal quantifier.\<close>

text \<open>The rules are introduction and elimination of implication and universal quantifiers.\<close>
datatype prop_rule = allI | allE | impI | impE

definition prop_rules :: "prop_rule stream"
  where "prop_rules = cycle [allI, allE, impI, impE]"

lemma iR_prop_rules [simp]: "sset prop_rules = {allI, allE, impI, impE}"
  unfolding prop_rules_def by simp

text \<open>Just some short notation.\<close>
abbreviation X :: "form"
  where "X \<equiv> Var 10 []"
abbreviation Y :: "form"
  where "Y \<equiv> Var 11 []"
abbreviation x :: "form"
  where "x \<equiv> Var 9 []"
abbreviation t :: "form"
  where "t \<equiv> Var 13 []"
abbreviation P :: "form \<Rightarrow> form"
  where "P f \<equiv> Var 12 [f]"
abbreviation Q :: "form \<Rightarrow> form"
  where "Q f \<equiv> Op ''Q'' [f]"
abbreviation imp :: "form \<Rightarrow> form \<Rightarrow> form"
  where "imp f1 f2 \<equiv> Op ''imp'' [f1, f2]"
abbreviation ForallX :: "form \<Rightarrow> form"
  where "ForallX f \<equiv> Quant ''all'' 9 f"

text \<open>Finally the right- and left-hand sides of the rules.\<close>

fun consequent :: "prop_rule \<Rightarrow> form list"
  where "consequent allI = [ForallX (P x)]"
  | "consequent allE = [P t]"
  | "consequent impI = [imp X Y]"
  | "consequent impE = [Y]"

abbreviation allI_input where "allI_input \<equiv> Antecedent {||} (P (LC 0)) {0}"
abbreviation impI_input where "impI_input \<equiv> Antecedent {|X|} Y {}"

fun antecedent :: "prop_rule \<Rightarrow> (form, lconst) antecedent list"
  where "antecedent allI = [allI_input]"
  | "antecedent allE = [plain_ant (ForallX (P x))]"
  | "antecedent impI = [impI_input]"
  | "antecedent impE = [plain_ant (imp X Y), plain_ant X]"

interpretation predicate: Abstract_Rules
  "curry to_nat :: nat \<Rightarrow> var \<Rightarrow> var"
  map_lc
  lc
  "closed"
  subst
  lc_subst
  map_lc_subst
  "Var 0 []"
  antecedent
  consequent
  prop_rules
proof
  show "\<forall>xs\<in>sset prop_rules. consequent xs \<noteq> []"
    unfolding prop_rules_def
    using consequent.elims by blast
next
  show "\<forall>xs\<in>sset prop_rules. \<Union>(lc ` set (consequent xs)) = {}"
    by auto
next
  fix i' r i ia
  assume "r \<in> sset prop_rules"
    and "ia < length (antecedent r)"
    and "i' < length (antecedent r)"
  then show "a_fresh (antecedent r ! ia) \<inter> a_fresh (antecedent r ! i') = {} \<or> ia = i'"
    by (cases i'; auto)
next
  fix r p
  assume "r \<in> sset prop_rules"
  and "p \<in> set (antecedent r)"
  thus "lc (a_conc p) \<union> \<Union>(lc ` fset (a_hyps p)) \<subseteq> a_fresh p" by auto
qed

end


theory Saturation
  imports Main
begin

subsection \<open>Set operation closure for idempotent, associative, and commutative functions\<close>

lemma inv_to_set:
  "(\<forall> i < length ss. ss ! i \<in> S) \<longleftrightarrow> set ss \<subseteq> S"
  by (induct ss) (auto simp: nth_Cons split: nat.splits)

lemma ac_comp_fun_commute:
  assumes "\<And> x y. f x y = f y x" and "\<And> x y z. f x (f y z) = f (f x y) z"
  shows "comp_fun_commute f" using assms unfolding comp_fun_commute_def
  by (auto simp: comp_def) fastforce

lemma (in comp_fun_commute) fold_list_swap:
  "fold f xs (fold f ys y) = fold f ys (fold f xs y)"
  by (metis comp_fun_commute fold_commute fold_commute_apply)

lemma (in comp_fun_commute) foldr_list_swap:
  "foldr f xs (foldr f ys y) = foldr f ys (foldr f xs y)"
  by (simp add: fold_list_swap foldr_conv_fold)

lemma (in comp_fun_commute) foldr_to_fold:
  "foldr f xs = fold f xs"
  using comp_fun_commute foldr_fold[of _ f]
  by (auto simp: comp_def)

lemma (in comp_fun_commute) fold_commute_f:
  "f x (foldr f xs y) = foldr f xs (f x y)"
  using comp_fun_commute unfolding foldr_to_fold
  by (auto simp: comp_def intro: fold_commute_apply)

lemma closure_sound:
  assumes cl: "\<And> s t. s \<in> S \<Longrightarrow> t \<in> S \<Longrightarrow> f s t \<in> S"
    and com: "\<And> x y. f x y = f y x" and ass: "\<And> x y z. f x (f y z) = f (f x y) z"
    and fin: "set ss \<subseteq> S" "ss \<noteq> []"
  shows "fold f (tl ss) (hd ss) \<in> S" using assms(4-)
proof (induct ss)
  case (Cons s ss) note IS = this show ?case
  proof (cases ss)
    case Nil
    then show ?thesis using IS by auto
  next
    case (Cons t ts) show ?thesis
      using IS assms(1) ac_comp_fun_commute[of f, OF com ass] unfolding Cons
      by (auto simp flip: comp_fun_commute.foldr_to_fold) (metis com comp_fun_commute.fold_commute_f)
  qed
qed auto

(* Writing a fold that does not take a base element may simplify the proves *)
locale set_closure_oprator =
  fixes f
  assumes com [ac_simps]: "\<And> x y. f x y = f y x"
    and ass [ac_simps]: "\<And> x y z. f x (f y z) = f (f x y) z"
    and idem: "\<And> x. f x x = x"

sublocale set_closure_oprator \<subseteq> comp_fun_idem
  using set_closure_oprator_axioms ac_comp_fun_commute
  by (auto simp: comp_fun_idem_def comp_fun_idem_axioms_def comp_def set_closure_oprator_def)

context set_closure_oprator
begin

inductive_set closure for S where
  base [simp]: "s \<in> S \<Longrightarrow> s \<in> closure S"
| step [intro]: "s \<in> closure S \<Longrightarrow> t \<in> closure S \<Longrightarrow> f s t \<in> closure S"

lemma closure_idem [simp]:
  "closure (closure S) = closure S" (is "?LS = ?RS")
proof -
  {fix s assume "s \<in> ?LS" then have "s \<in> ?RS" by induct auto}
  moreover
  {fix s assume "s \<in> ?RS" then have "s \<in> ?LS" by induct auto}
  ultimately show ?thesis by blast
qed

lemma fold_dist:
  assumes "xs \<noteq> []"
  shows "f (fold f (tl xs) (hd xs)) t = fold f xs t" using assms
proof (induct xs)
  case (Cons a xs)
  show ?case using Cons com ass fold_commute_f
    by (auto simp: comp_def foldr_to_fold)
qed auto

lemma closure_to_cons_list:
  assumes "s \<in> closure S"
  shows "\<exists> ss \<noteq> []. fold f (tl ss) (hd ss) = s \<and> (\<forall> i < length ss. ss ! i \<in> S)" using assms
proof (induct)
  case (base s) then show ?case by (auto intro: exI[of _ "[s]"])
next
  case (step s t)
  then obtain ss ts where
    s: "fold f (tl ss) (hd ss) = s" and inv_s: "ss \<noteq> []" "\<forall> i < length ss. ss ! i \<in> S" and
    t: "fold f (tl ts) (hd ts) = t" and inv_t: "ts \<noteq> []" "\<forall> i < length ts. ts ! i \<in> S"
    by auto
  then show ?case
    by (auto simp: fold_dist nth_append intro!: exI[of _ "ss @ ts"]) (metis com fold_dist)
qed

lemma sound_fold:
  assumes "set ss \<subseteq> closure S" and "ss \<noteq> []"
  shows "fold f (tl ss) (hd ss) \<in> closure S" using assms
  using closure_sound[of "closure S" f] assms step
  by (auto simp add: com fun_left_comm)

lemma closure_empty [simp]: "closure {} = {}"
  using closure_to_cons_list by auto

lemma closure_mono:
  "S \<subseteq> T \<Longrightarrow> closure S \<subseteq> closure T"
proof
  fix s assume ass: "s \<in> closure S"
  then show "S \<subseteq> T \<Longrightarrow> s \<in> closure T"
    by (induct) (auto simp: closure_to_cons_list)
qed

lemma closure_insert:
  "closure (insert x S) = {x} \<union> closure S \<union> {f x s | s. s \<in> closure S}"
proof -
  {fix t assume ass: "t \<in> closure (insert x S)" "t \<noteq> x" "t \<notin> closure S"
    from closure_to_cons_list[OF ass(1)] obtain ss where
      t: "fold f (tl ss) (hd ss) = t" and inv_t: "ss \<noteq> []" "\<forall> i < length ss. ss ! i \<in> insert x S"
      by auto
    then have mem: "x \<in> set ss" using ass(3) sound_fold[of ss] in_set_conv_nth
      by (force simp add: inv_to_set)
    have "\<exists> s. t = f x s \<and> s \<in> closure S"
    proof (cases "set ss = {x}")
      case True then show ?thesis using ass(2) t
        by (metis com finite.emptyI fold_dist fold_empty fold_insert_idem fold_set_fold idem inv_t(1))
    next
      case False
      from False inv_t(1) mem obtain ts where split: "insert x (set ts) = set ss" "x \<notin> set ts" "ts \<noteq> []"
        by auto (metis False List.finite_set Set.set_insert empty_set finite_insert finite_list)
      then have "\<forall> i < length ts. ts ! i \<in> S" using inv_t(2) split unfolding inv_to_set by auto
      moreover have "t = f x (Finite_Set.fold f (hd ts) (set (tl ts)))"
        using split t inv_t(1)
        by (metis List.finite_set com fold_dist fold_insert_idem2 fold_set_fold fun_left_idem idem)
      ultimately show ?thesis using sound_fold[OF _ split(3)]
        by (auto simp: foldr_to_fold fold_set_fold inv_to_set) force
    qed}
  then show ?thesis
    by (auto simp: fold_set_fold in_mono[OF closure_mono[OF subset_insertI[of S x]]])
qed

lemma finite_S_finite_closure [intro]:
  "finite S \<Longrightarrow> finite (closure S)"
  by (induct rule: finite.induct) (auto simp: closure_insert)

end

locale semilattice_closure_operator =
  cl: set_closure_oprator f for f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" +
fixes less_eq e
assumes neut_fun [simp]:"\<And> x. f e x = x"
  and neut_less [simp]: "\<And> x. less_eq e x"
  and sup_l: "\<And> x y. less_eq x (f x y)"
  and sup_r: "\<And> x y. less_eq y (f x y)"
  and upper_bound: "\<And> x y z. less_eq x z \<Longrightarrow> less_eq y z \<Longrightarrow> less_eq (f x y) z"
  and trans: "\<And> x y z. less_eq x y \<Longrightarrow> less_eq y z \<Longrightarrow> less_eq x z"
  and anti_sym: "\<And> x y. less_eq x y \<Longrightarrow> less_eq y x \<Longrightarrow> x = y"
begin

lemma unique_neut_elem [simp]:
  "f x y = e \<longleftrightarrow> x = e \<and> y = e"
  using neut_fun cl.fun_left_idem
  by (metis cl.com)

abbreviation "closure S \<equiv> cl.closure S"

lemma closure_to_cons_listE:
  assumes "s \<in> closure S"
  obtains ss where "ss \<noteq> []" "fold f ss e = s" "set ss \<subseteq> S"
  using cl.closure_to_cons_list[OF assms] cl.fold_dist
  by (auto simp: inv_to_set) (metis cl.com neut_fun)

lemma sound_fold:
  assumes "set ss \<subseteq> closure S" "ss \<noteq> []"
  shows "fold f ss e \<in> closure S"
  using cl.sound_fold[OF assms] cl.fold_dist[OF assms(2)]
  by (metis cl.com neut_fun)

abbreviation "supremum S \<equiv> Finite_Set.fold f e S"
definition "smaller_subset x S \<equiv> {y. less_eq y x \<and> y \<in> S}"

lemma smaller_subset_empty [simp]:
  "smaller_subset x {} = {}"
  by (auto simp: smaller_subset_def)

lemma finite_smaller_subset [simp, intro]:
  "finite S \<Longrightarrow> finite (smaller_subset x S)"
  by (auto simp: smaller_subset_def)

lemma smaller_subset_mono:
  "smaller_subset x S \<subseteq> S"
  by (auto simp: smaller_subset_def)

lemma sound_set_fold:
  assumes "set ss \<subseteq> closure S" and "ss \<noteq> []"
  shows "supremum (set ss) \<in> closure S"
  using sound_fold[OF assms]
  by (auto simp: cl.fold_set_fold)

lemma supremum_neutral [simp]:
  assumes "finite S" and "supremum S = e"
  shows "S \<subseteq> {e}" using assms
  by (induct) auto

lemma supremum_in_closure:
  assumes "finite S" and "R \<subseteq> closure S" and "R \<noteq> {}"
  shows "supremum R \<in> closure S"
proof -
  obtain L where [simp]: "R = set L"
    using cl.finite_S_finite_closure[OF assms(1)] assms(2) finite_list
    by (metis infinite_super)
  then show ?thesis using sound_set_fold[of L S] assms
    by (cases L) auto
qed

lemma supremum_sound:
  assumes "finite S"
  shows "\<And> t. t \<in> S \<Longrightarrow> less_eq t (supremum S)"
  using assms sup_l sup_r trans
  by induct (auto, blast)

lemma supremum_sound_list:
  "\<forall> i < length ss. less_eq (ss ! i) (fold f ss e)"
  unfolding cl.fold_set_fold[symmetric]
  using supremum_sound[of "set ss"]
  by auto

lemma smaller_subset_insert [simp]:
  "less_eq y x \<Longrightarrow> smaller_subset x (insert y S) = insert y (smaller_subset x S)"
  "\<not> less_eq y x \<Longrightarrow> smaller_subset x (insert y S) = smaller_subset x S"
  by (auto simp: smaller_subset_def)

lemma supremum_smaller_subset:
  assumes "finite S"
  shows "less_eq (supremum (smaller_subset x S)) x" using assms
proof (induct)
  case (insert y F) then show ?case
    by (cases "less_eq y x") (auto simp: upper_bound)
qed simp

lemma pre_subset_eq_pos_subset [simp]:
  shows "smaller_subset x (closure S) = closure (smaller_subset x S)" (is "?LS = ?RS")
proof -
  {fix s assume "s \<in> ?RS" then have "s \<in> ?LS"
      using upper_bound by induct (auto simp: smaller_subset_def)}
  moreover
  {fix s assume ass: "s \<in> ?LS"
    then have "s \<in> closure S" using smaller_subset_mono by auto
    then obtain ss where wit: "ss \<noteq> [] \<and> fold f ss e = s \<and> (set ss \<subseteq> S)"
      using closure_to_cons_listE by blast
    then have "\<forall> i < length ss. less_eq (ss ! i) x"
      using supremum_sound[of "set ss"] supremum_smaller_subset[of "set ss" x]
      unfolding cl.fold_set_fold[symmetric]
      by auto (metis ass local.trans mem_Collect_eq nth_mem smaller_subset_def)
    then have "s \<in> ?RS" using wit sound_fold[of ss]
      by (auto simp: smaller_subset_def)
        (metis (mono_tags, lifting) cl.closure.base inv_to_set mem_Collect_eq)}
  ultimately show ?thesis by blast
qed

lemma supremum_in_smaller_closure:
  assumes "finite S"
  shows "supremum (smaller_subset x S) \<in> {e} \<union> (closure S)"
  using supremum_in_closure[OF assms, of "smaller_subset x S"]
  by (metis UnI1 UnI2 cl.closure.base fold_empty singletonI smaller_subset_mono subset_iff)

lemma supremum_subset_less_eq:
  assumes "finite S" and "R \<subseteq> S"
  shows "less_eq (supremum R) (supremum S)" using assms
proof (induct arbitrary: R)
  case (insert x F)
  from insert(1, 2, 4) insert(3)[of "R - {x}"]
  have "less_eq (supremum (R - {x})) (f x (supremum F))"
    by (metis Diff_subset_conv insert_is_Un local.trans sup_r)
  then show ?case using insert(1, 2, 4)
    by auto (metis Diff_empty Diff_insert0 cl.fold_rec finite.insertI finite_subset sup_l upper_bound)
qed (auto)

lemma supremum_smaller_closure [simp]:
  assumes "finite S"
  shows "supremum (smaller_subset x (closure S)) = supremum (smaller_subset x S)"
proof (cases "smaller_subset x S = {}")
  case [simp]: True show ?thesis by auto
next
  case False
  have "smaller_subset x S \<subseteq> smaller_subset x (closure S)"
    unfolding pre_subset_eq_pos_subset by auto
  then have l: "less_eq (supremum (smaller_subset x S)) (supremum (smaller_subset x (closure S)))"
    using assms unfolding pre_subset_eq_pos_subset
    by (intro supremum_subset_less_eq) auto
  from False have "supremum (closure (smaller_subset x S)) \<in> closure S"
    using assms cl.closure_mono[OF smaller_subset_mono]
    using \<open>smaller_subset x S \<subseteq> smaller_subset x (closure S)\<close>
    by (auto simp add: assms intro!: supremum_in_closure)
  from closure_to_cons_listE[OF this] obtain ss where
    dec : "supremum (smaller_subset x (closure S)) = Finite_Set.fold f e (set ss)"
    and inv: "ss \<noteq> []" "set ss \<subseteq> S"
    by (auto simp: cl.fold_set_fold) force
  then have "set ss \<subseteq> smaller_subset x S"
    using supremum_sound[OF assms]
    using supremum_smaller_subset[OF assms]
    by (auto simp: smaller_subset_def)
      (metis List.finite_set assms cl.finite_S_finite_closure dec trans supremum_smaller_subset supremum_sound)
  then have "less_eq (supremum (smaller_subset x (closure S))) (supremum (smaller_subset x S))"
    using inv assms unfolding dec
    by (intro supremum_subset_less_eq) auto
  then show ?thesis using l anti_sym
    by auto
qed

end

fun lift_f_total where
  "lift_f_total P f None _ = None"
| "lift_f_total P f _ None = None"
| "lift_f_total P f (Some s) (Some t) = (if P s t then Some (f s t) else None)"

fun lift_less_eq_total where
  "lift_less_eq_total f _ None = True"
| "lift_less_eq_total f None _ = False"
| "lift_less_eq_total f (Some s) (Some t) = (f s t)"

locale set_closure_partial_oprator =
  fixes P f
  assumes refl: "\<And> x. P x x"
    and sym: "\<And> x y. P x y \<Longrightarrow> P y x"
    and dist: "\<And> x y z. P y z \<Longrightarrow> P x (f y z) \<Longrightarrow> P x y"
    and assP: "\<And> x y z. P x (f y z) \<Longrightarrow> P y z \<Longrightarrow> P (f x y) z"
    and com [ac_simps]: "\<And> x y. P x y \<Longrightarrow> f x y = f y x"
    and ass [ac_simps]: "\<And> x y z. P x y \<Longrightarrow> P y z \<Longrightarrow> f x (f y z) = f (f x y) z"
    and idem: "\<And> x. f x x = x"
begin

lemma lift_f_total_com:
  "lift_f_total P f x y = lift_f_total P f y x"
  using com by (cases x; cases y) (auto simp: sym)

lemma lift_f_total_ass:
  "lift_f_total P f x (lift_f_total P f y z) = lift_f_total P f (lift_f_total P f x y) z"
proof (cases x)
  case [simp]: (Some s) show ?thesis
  proof (cases y)
    case [simp]: (Some t) show ?thesis
    proof (cases z)
      case [simp]: (Some u) show ?thesis
        by (auto simp add: ass dist[of t u s])
          (metis com dist assP sym)+
    qed auto
  qed auto
qed auto

lemma lift_f_total_idem:
  "lift_f_total P f x x = x"
  by (cases x) (auto simp: idem refl)

lemma lift_f_totalE[elim]:
  assumes "lift_f_total P f s u = Some t"
  obtains v w where "s = Some v" "u = Some w"
  using assms by (cases s; cases u) auto

lemma lift_set_closure_oprator:
  "set_closure_oprator (lift_f_total P f)"
  using lift_f_total_com lift_f_total_ass lift_f_total_idem by unfold_locales blast+

end

sublocale set_closure_partial_oprator \<subseteq> lift_fun: set_closure_oprator "lift_f_total P f"
  by (simp add: lift_set_closure_oprator)

context set_closure_partial_oprator begin

abbreviation "lift_closure S \<equiv> lift_fun.closure (Some ` S)"

inductive_set pred_closure for S where
  base [simp]: "s \<in> S \<Longrightarrow> s \<in> pred_closure S"
| step [intro]: "s \<in> pred_closure S \<Longrightarrow> t \<in> pred_closure S \<Longrightarrow> P s t \<Longrightarrow> f s t \<in> pred_closure S"

lemma pred_closure_to_some_lift_closure:
  assumes "s \<in> pred_closure S"
  shows "Some s \<in> lift_closure S" using assms
proof (induct)
  case (step s t)
  then have "lift_f_total P f (Some s) (Some t) \<in> lift_closure S"
    by (intro lift_fun.closure.step) auto
  then show ?case using step(5)
    by (auto split: if_splits)
qed auto

lemma some_lift_closure_pred_closure:
  fixes t defines "s \<equiv> Some t"
  assumes "Some t \<in> lift_closure S"
  shows "t \<in> pred_closure S" using assms(2)
  unfolding assms(1)[symmetric] using assms(1)
proof (induct arbitrary: t)
  case (step s u)
  from step(5) obtain v w where [simp]: "s = Some v" "u = Some w" by auto
  show ?case using step by (auto split: if_splits)
qed auto

lemma pred_closure_lift_closure:
  "pred_closure S = the ` (lift_closure S - {None})" (is "?LS = ?RS")
proof
  {fix s assume "s \<in> ?LS"
    from pred_closure_to_some_lift_closure[OF this] have "s \<in> ?RS"
      by (metis DiffI empty_iff image_iff insertE option.distinct(1) option.sel)}
  then show "?LS \<subseteq> ?RS" by blast
next
  {fix s assume ass: "s \<in> ?RS"
    then have "Some s \<in> lift_closure S"
      using option.collapse by fastforce
    from some_lift_closure_pred_closure[OF this] have "s \<in> ?LS"
      using option.collapse by auto}
  then show "?RS \<subseteq> ?LS" by blast
qed

lemma finite_S_finite_closure [simp, intro]:
  "finite S \<Longrightarrow> finite (pred_closure S)"
  using finite_subset[of "Some ` pred_closure S" "lift_closure S"]
  using pred_closure_to_some_lift_closure lift_fun.finite_S_finite_closure[of "Some ` S"]
  by (auto simp add: pred_closure_lift_closure set_closure_partial_oprator_axioms)

lemma closure_mono:
  assumes "S \<subseteq> T"
  shows "pred_closure S \<subseteq> pred_closure T"
proof -
  have "Some ` S \<subseteq> Some ` T" using assms by auto
  from lift_fun.closure_mono[OF this] show ?thesis
    using pred_closure_to_some_lift_closure some_lift_closure_pred_closure set_closure_partial_oprator_axioms
    by fastforce
qed

lemma pred_closure_empty [simp]:
  "pred_closure {} = {}"
  using pred_closure_lift_closure by fastforce
end

locale semilattice_closure_partial_operator =
  cl: set_closure_partial_oprator P f for P and f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" +
fixes less_eq e
assumes neut_elm :"\<And> x. f e x = x"
  and neut_pred: "\<And> x. P e x"
  and neut_less: "\<And> x. less_eq e x"
  and pred_less: "\<And> x y z. less_eq x y \<Longrightarrow> less_eq z y \<Longrightarrow> P x z"
  and sup_l: "\<And> x y. P x y \<Longrightarrow> less_eq x (f x y)"
  and sup_r: "\<And> x y. P x y \<Longrightarrow> less_eq y (f x y)"
  and upper_bound: "\<And> x y z. less_eq x z \<Longrightarrow> less_eq y z \<Longrightarrow> less_eq (f x y) z"
  and trans: "\<And> x y z. less_eq x y \<Longrightarrow> less_eq y z \<Longrightarrow> less_eq x z"
  and anti_sym: "\<And> x y. less_eq x y \<Longrightarrow> less_eq y x \<Longrightarrow> x = y"
begin

abbreviation "lifted_less_eq \<equiv> lift_less_eq_total less_eq"
abbreviation "lifted_fun \<equiv> lift_f_total P f"

lemma lift_less_eq_None [simp]:
  "lifted_less_eq None y \<longleftrightarrow> y = None"
  by (cases y) auto

lemma lift_less_eq_neut_elm [simp]:
  "lifted_fun (Some e) s = s"
  using neut_elm neut_pred by (cases s) auto

lemma lift_less_eq_neut_less [simp]:
  "lifted_less_eq (Some e) s \<longleftrightarrow> True"
  using neut_less by (cases s) auto

lemma lift_less_eq_sup_l [simp]:
  "lifted_less_eq x (lifted_fun x y) \<longleftrightarrow> True"
  using sup_l by (cases x; cases y) auto

lemma lift_less_eq_sup_r [simp]:
  "lifted_less_eq y (lifted_fun x y) \<longleftrightarrow> True"
  using sup_r by (cases x; cases y) auto

lemma lifted_less_eq_trans [trans]:
  "lifted_less_eq x y \<Longrightarrow> lifted_less_eq y z \<Longrightarrow> lifted_less_eq x z"
  using trans by (auto elim!: lift_less_eq_total.elims)

lemma lifted_less_eq_anti_sym [trans]:
  "lifted_less_eq x y \<Longrightarrow> lifted_less_eq y x \<Longrightarrow> x = y"
  using anti_sym by (auto elim!: lift_less_eq_total.elims)

lemma lifted_less_eq_upper:
  "lifted_less_eq x z \<Longrightarrow> lifted_less_eq y z \<Longrightarrow> lifted_less_eq (lifted_fun x y) z"
  using upper_bound pred_less by (auto elim!: lift_less_eq_total.elims)

lemma semilattice_closure_operator_axioms:
  "semilattice_closure_operator_axioms (lift_f_total P f) (lift_less_eq_total less_eq) (Some e)"
  using lifted_less_eq_upper lifted_less_eq_trans lifted_less_eq_anti_sym
  by unfold_locales (auto elim!: lift_f_total.cases)

end

sublocale semilattice_closure_partial_operator \<subseteq> lift_ord: semilattice_closure_operator "lift_f_total P f" "lift_less_eq_total less_eq" "Some e"
  by (simp add: cl.lift_set_closure_oprator semilattice_closure_operator.intro semilattice_closure_operator_axioms)

context semilattice_closure_partial_operator
begin

abbreviation "supremum \<equiv> lift_ord.supremum"
abbreviation "smaller_subset \<equiv> lift_ord.smaller_subset"

lemma supremum_impl:
  assumes "supremum (set (map Some ss)) = Some t"
  shows "foldr f ss e = t" using assms
proof (induct ss arbitrary: t)
  case (Cons a ss)
  then show ?case
    by auto (metis cl.lift_f_totalE lift_f_total.simps(3) option.distinct(1) option.sel)
qed auto

lemma supremum_smaller_exists_unique:
  assumes "finite S"
  shows "\<exists>! p. supremum (smaller_subset (Some t) (Some ` S)) = Some p" using assms
proof (induct)
  case (insert x F) show ?case
  proof (cases "lifted_less_eq (Some x) (Some t)")
    case True
    obtain p where wit: "supremum (smaller_subset (Some t) (Some ` F)) = Some p"
      using insert by auto
    then have pred: "less_eq p t" "less_eq x t" using True insert(1)
      using lift_ord.supremum_smaller_subset
      by auto (metis finite_imageI lift_less_eq_total.simps(3))
    show ?thesis using insert pred wit pred_less
      by auto
  next
    case False then show ?thesis
      using insert by auto
  qed
qed auto

lemma supremum_neut_or_in_closure:
  assumes "finite S"
  shows "the (supremum (smaller_subset (Some t) (Some ` S))) \<in> {e} \<union> cl.pred_closure S"
  using supremum_smaller_exists_unique[OF assms]
  using lift_ord.supremum_in_smaller_closure[of "Some ` S" "Some t"] assms
  by auto (metis cl.some_lift_closure_pred_closure option.sel)

end

(* At the moment we remove duplicates in each iteration,
   use data structure that can deal better with duplication i.e red black trees *)
fun closure_impl where
  "closure_impl f [] = []"
| "closure_impl f (x # S) = (let cS = closure_impl f S in remdups (x # cS @ map (f x) cS))"

lemma (in set_closure_oprator) closure_impl [simp]:
  "set (closure_impl f S) = closure (set S)"
  by (induct S, auto simp: closure_insert Let_def)

lemma (in set_closure_partial_oprator) closure_impl [simp]:
  "set (map the (removeAll None (closure_impl (lift_f_total P f) (map Some S)))) = pred_closure (set S)"
  using lift_set_closure_oprator set_closure_oprator.closure_impl pred_closure_lift_closure
  by auto

end


(*  Title:      HOL/Hoare/Pointer_Examples.thy
    Author:     Tobias Nipkow
    Copyright   2002 TUM

Examples of verifications of pointer programs.
*)

theory Pointer_Examples imports HeapSyntax begin

axiomatization where unproven: "PROP A"

section "Verifications"

subsection "List reversal"

text "A short but unreadable proof:"

lemma "VARS tl p q r
  {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {}}
  WHILE p \<noteq> Null
  INV {\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                 rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := p^.tl; r^.tl := q; q := r OD
  {List tl q (rev Ps @ Qs)}"
apply vcg_simp
  apply fastforce
  apply(fastforce intro:notin_List_update[THEN iffD2])
  \<comment> \<open>explicit:\<close>
  \<^cancel>\<open>apply clarify\<close>
  \<^cancel>\<open>apply(rename_tac ps b qs)\<close>
  \<^cancel>\<open>apply clarsimp\<close>
  \<^cancel>\<open>apply(rename_tac ps')\<close>
  \<^cancel>\<open>apply(fastforce intro:notin_List_update[THEN iffD2])\<close>
  apply fastforce
  done

text\<open>And now with ghost variables \<^term>\<open>ps\<close> and \<^term>\<open>qs\<close>. Even
``more automatic''.\<close>

lemma "VARS next p ps q qs r
  {List next p Ps \<and> List next q Qs \<and> set Ps \<inter> set Qs = {} \<and>
   ps = Ps \<and> qs = Qs}
  WHILE p \<noteq> Null
  INV {List next p ps \<and> List next q qs \<and> set ps \<inter> set qs = {} \<and>
       rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := p^.next; r^.next := q; q := r;
     qs := (hd ps) # qs; ps := tl ps OD
  {List next q (rev Ps @ Qs)}"
apply vcg_simp
 apply fastforce
apply fastforce
done

text "A longer readable version:"

lemma "VARS tl p q r
  {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {}}
  WHILE p \<noteq> Null
  INV {\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
               rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := p^.tl; r^.tl := q; q := r OD
  {List tl q (rev Ps @ Qs)}"
proof vcg
  fix tl p q r
  assume "List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {}"
  thus "\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                rev ps @ qs = rev Ps @ Qs" by fastforce
next
  fix tl p q r
  assume "(\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                   rev ps @ qs = rev Ps @ Qs) \<and> p \<noteq> Null"
         (is "(\<exists>ps qs. ?I ps qs) \<and> _")
  then obtain ps qs a where I: "?I ps qs \<and> p = Ref a"
    by fast
  then obtain ps' where "ps = a # ps'" by fastforce
  hence "List (tl(p \<rightarrow> q)) (p^.tl) ps' \<and>
         List (tl(p \<rightarrow> q)) p       (a#qs) \<and>
         set ps' \<inter> set (a#qs) = {} \<and>
         rev ps' @ (a#qs) = rev Ps @ Qs"
    using I by fastforce
  thus "\<exists>ps' qs'. List (tl(p \<rightarrow> q)) (p^.tl) ps' \<and>
                  List (tl(p \<rightarrow> q)) p       qs' \<and>
                  set ps' \<inter> set qs' = {} \<and>
                  rev ps' @ qs' = rev Ps @ Qs" by fast
next
  fix tl p q r
  assume "(\<exists>ps qs. List tl p ps \<and> List tl q qs \<and> set ps \<inter> set qs = {} \<and>
                   rev ps @ qs = rev Ps @ Qs) \<and> \<not> p \<noteq> Null"
  thus "List tl q (rev Ps @ Qs)" by fastforce
qed

text\<open>Finaly, the functional version. A bit more verbose, but automatic!\<close>

lemma "VARS tl p q r
  {islist tl p \<and> islist tl q \<and>
   Ps = list tl p \<and> Qs = list tl q \<and> set Ps \<inter> set Qs = {}}
  WHILE p \<noteq> Null
  INV {islist tl p \<and> islist tl q \<and>
       set(list tl p) \<inter> set(list tl q) = {} \<and>
       rev(list tl p) @ (list tl q) = rev Ps @ Qs}
  DO r := p; p := p^.tl; r^.tl := q; q := r OD
  {islist tl q \<and> list tl q = rev Ps @ Qs}"
apply vcg_simp
  apply clarsimp
 apply clarsimp
apply clarsimp
done

subsection "Searching in a list"

text\<open>What follows is a sequence of successively more intelligent proofs that
a simple loop finds an element in a linked list.

We start with a proof based on the \<^term>\<open>List\<close> predicate. This means it only
works for acyclic lists.\<close>

lemma "VARS tl p
  {List tl p Ps \<and> X \<in> set Ps}
  WHILE p \<noteq> Null \<and> p \<noteq> Ref X
  INV {\<exists>ps. List tl p ps \<and> X \<in> set ps}
  DO p := p^.tl OD
  {p = Ref X}"
apply vcg_simp
  apply blast
 apply clarsimp
apply clarsimp
done

text\<open>Using \<^term>\<open>Path\<close> instead of \<^term>\<open>List\<close> generalizes the correctness
statement to cyclic lists as well:\<close>

lemma "VARS tl p
  {Path tl p Ps X}
  WHILE p \<noteq> Null \<and> p \<noteq> X
  INV {\<exists>ps. Path tl p ps X}
  DO p := p^.tl OD
  {p = X}"
apply vcg_simp
  apply blast
 apply fastforce
apply clarsimp
done

text\<open>Now it dawns on us that we do not need the list witness at all --- it
suffices to talk about reachability, i.e.\ we can use relations directly. The
first version uses a relation on \<^typ>\<open>'a ref\<close>:\<close>

lemma "VARS tl p
  {(p,X) \<in> {(Ref x,tl x) |x. True}\<^sup>*}
  WHILE p \<noteq> Null \<and> p \<noteq> X
  INV {(p,X) \<in> {(Ref x,tl x) |x. True}\<^sup>*}
  DO p := p^.tl OD
  {p = X}"
apply vcg_simp
 apply clarsimp
 apply(erule converse_rtranclE)
  apply simp
 apply(clarsimp elim:converse_rtranclE)
apply(fast elim:converse_rtranclE)
done

text\<open>Finally, a version based on a relation on type \<^typ>\<open>'a\<close>:\<close>

lemma "VARS tl p
  {p \<noteq> Null \<and> (addr p,X) \<in> {(x,y). tl x = Ref y}\<^sup>*}
  WHILE p \<noteq> Null \<and> p \<noteq> Ref X
  INV {p \<noteq> Null \<and> (addr p,X) \<in> {(x,y). tl x = Ref y}\<^sup>*}
  DO p := p^.tl OD
  {p = Ref X}"
apply vcg_simp
 apply clarsimp
 apply(erule converse_rtranclE)
  apply simp
 apply clarsimp
apply clarsimp
done

subsection "Splicing two lists"

lemma "VARS tl p q pp qq
  {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {} \<and> size Qs \<le> size Ps}
  pp := p;
  WHILE q \<noteq> Null
  INV {\<exists>as bs qs.
    distinct as \<and> Path tl p as pp \<and> List tl pp bs \<and> List tl q qs \<and>
    set bs \<inter> set qs = {} \<and> set as \<inter> (set bs \<union> set qs) = {} \<and>
    size qs \<le> size bs \<and> splice Ps Qs = as @ splice bs qs}
  DO qq := q^.tl; q^.tl := pp^.tl; pp^.tl := q; pp := q^.tl; q := qq OD
  {List tl p (splice Ps Qs)}"
apply vcg_simp
  apply(rule_tac x = "[]" in exI)
  apply fastforce
 apply clarsimp
 apply(rename_tac y bs qqs)
 apply(case_tac bs) apply simp
 apply clarsimp
 apply(rename_tac x bbs)
 apply(rule_tac x = "as @ [x,y]" in exI)
 apply simp
 apply(rule_tac x = "bbs" in exI)
 apply simp
 apply(rule_tac x = "qqs" in exI)
 apply simp
apply (fastforce simp:List_app)
done

subsection "Merging two lists"

text"This is still a bit rough, especially the proof."

definition cor :: "bool \<Rightarrow> bool \<Rightarrow> bool"
  where "cor P Q \<longleftrightarrow> (if P then True else Q)"

definition cand :: "bool \<Rightarrow> bool \<Rightarrow> bool"
  where "cand P Q \<longleftrightarrow> (if P then Q else False)"

fun merge :: "'a list * 'a list * ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list"
where
  "merge(x#xs,y#ys,f) = (if f x y then x # merge(xs,y#ys,f)
                                  else y # merge(x#xs,ys,f))"
| "merge(x#xs,[],f) = x # merge(xs,[],f)"
| "merge([],y#ys,f) = y # merge([],ys,f)"
| "merge([],[],f) = []"

text\<open>Simplifies the proof a little:\<close>

lemma "VARS hd tl p q r s
 {List tl p Ps \<and> List tl q Qs \<and> set Ps \<inter> set Qs = {} \<and>
  (p \<noteq> Null \<or> q \<noteq> Null)}
 IF cor (q = Null) (cand (p \<noteq> Null) (p^.hd \<le> q^.hd))
 THEN r := p; p := p^.tl ELSE r := q; q := q^.tl FI;
 s := r;
 WHILE p \<noteq> Null \<or> q \<noteq> Null
 INV {\<exists>rs ps qs a. Path tl r rs s \<and> List tl p ps \<and> List tl q qs \<and>
      distinct(a # ps @ qs @ rs) \<and> s = Ref a \<and>
      merge(Ps,Qs,\<lambda>x y. hd x \<le> hd y) =
      rs @ a # merge(ps,qs,\<lambda>x y. hd x \<le> hd y) \<and>
      (tl a = p \<or> tl a = q)}
 DO IF cor (q = Null) (cand (p \<noteq> Null) (p^.hd \<le> q^.hd))
    THEN s^.tl := p; p := p^.tl ELSE s^.tl := q; q := q^.tl FI;
    s := s^.tl
 OD
 {List tl r (merge(Ps,Qs,\<lambda>x y. hd x \<le> hd y))}"
apply vcg_simp
apply (simp_all add: cand_def cor_def)

apply (fastforce)

apply clarsimp
apply(rule conjI)
apply clarsimp
apply(rule conjI)
apply (fastforce intro!:Path_snoc intro:Path_upd[THEN iffD2] notin_List_update[THEN iffD2] simp:eq_sym_conv)
apply clarsimp
apply(rule conjI)
apply (clarsimp)
apply(rule_tac x = "rs @ [a]" in exI)
apply(clarsimp simp:eq_sym_conv)
apply(rule_tac x = "bs" in exI)
apply(clarsimp simp:eq_sym_conv)
apply(rule_tac x = "ya#bsa" in exI)
apply(simp)
apply(clarsimp simp:eq_sym_conv)
apply(rule_tac x = "rs @ [a]" in exI)
apply(clarsimp simp:eq_sym_conv)
apply(rule_tac x = "y#bs" in exI)
apply(clarsimp simp:eq_sym_conv)
apply(rule_tac x = "bsa" in exI)
apply(simp)
apply (fastforce intro!:Path_snoc intro:Path_upd[THEN iffD2] notin_List_update[THEN iffD2] simp:eq_sym_conv)

apply(clarsimp simp add:List_app)
done

text\<open>And now with ghost variables:\<close>

lemma "VARS elem next p q r s ps qs rs a
 {List next p Ps \<and> List next q Qs \<and> set Ps \<inter> set Qs = {} \<and>
  (p \<noteq> Null \<or> q \<noteq> Null) \<and> ps = Ps \<and> qs = Qs}
 IF cor (q = Null) (cand (p \<noteq> Null) (p^.elem \<le> q^.elem))
 THEN r := p; p := p^.next; ps := tl ps
 ELSE r := q; q := q^.next; qs := tl qs FI;
 s := r; rs := []; a := addr s;
 WHILE p \<noteq> Null \<or> q \<noteq> Null
 INV {Path next r rs s \<and> List next p ps \<and> List next q qs \<and>
      distinct(a # ps @ qs @ rs) \<and> s = Ref a \<and>
      merge(Ps,Qs,\<lambda>x y. elem x \<le> elem y) =
      rs @ a # merge(ps,qs,\<lambda>x y. elem x \<le> elem y) \<and>
      (next a = p \<or> next a = q)}
 DO IF cor (q = Null) (cand (p \<noteq> Null) (p^.elem \<le> q^.elem))
    THEN s^.next := p; p := p^.next; ps := tl ps
    ELSE s^.next := q; q := q^.next; qs := tl qs FI;
    rs := rs @ [a]; s := s^.next; a := addr s
 OD
 {List next r (merge(Ps,Qs,\<lambda>x y. elem x \<le> elem y))}"
apply vcg_simp
apply (simp_all add: cand_def cor_def)

apply (fastforce)

apply clarsimp
apply(rule conjI)
apply(clarsimp)
apply(rule conjI)
apply(clarsimp simp:neq_commute)
apply(clarsimp simp:neq_commute)
apply(clarsimp simp:neq_commute)

apply(clarsimp simp add:List_app)
done

text\<open>The proof is a LOT simpler because it does not need
instantiations anymore, but it is still not quite automatic, probably
because of this wrong orientation business.\<close>

text\<open>More of the previous proof without ghost variables can be
automated, but the runtime goes up drastically. In general it is
usually more efficient to give the witness directly than to have it
found by proof.

Now we try a functional version of the abstraction relation \<^term>\<open>Path\<close>. Since the result is not that convincing, we do not prove any of
the lemmas.\<close>

axiomatization
  ispath :: "('a \<Rightarrow> 'a ref) \<Rightarrow> 'a ref \<Rightarrow> 'a ref \<Rightarrow> bool" and
  path :: "('a \<Rightarrow> 'a ref) \<Rightarrow> 'a ref \<Rightarrow> 'a ref \<Rightarrow> 'a list"

text"First some basic lemmas:"

lemma [simp]: "ispath f p p"
by (rule unproven)
lemma [simp]: "path f p p = []"
by (rule unproven)
lemma [simp]: "ispath f p q \<Longrightarrow> a \<notin> set(path f p q) \<Longrightarrow> ispath (f(a := r)) p q"
by (rule unproven)
lemma [simp]: "ispath f p q \<Longrightarrow> a \<notin> set(path f p q) \<Longrightarrow>
 path (f(a := r)) p q = path f p q"
by (rule unproven)

text"Some more specific lemmas needed by the example:"

lemma [simp]: "ispath (f(a := q)) p (Ref a) \<Longrightarrow> ispath (f(a := q)) p q"
by (rule unproven)
lemma [simp]: "ispath (f(a := q)) p (Ref a) \<Longrightarrow>
 path (f(a := q)) p q = path (f(a := q)) p (Ref a) @ [a]"
by (rule unproven)
lemma [simp]: "ispath f p (Ref a) \<Longrightarrow> f a = Ref b \<Longrightarrow>
 b \<notin> set (path f p (Ref a))"
by (rule unproven)
lemma [simp]: "ispath f p (Ref a) \<Longrightarrow> f a = Null \<Longrightarrow> islist f p"
by (rule unproven)
lemma [simp]: "ispath f p (Ref a) \<Longrightarrow> f a = Null \<Longrightarrow> list f p = path f p (Ref a) @ [a]"
by (rule unproven)

lemma [simp]: "islist f p \<Longrightarrow> distinct (list f p)"
by (rule unproven)

lemma "VARS hd tl p q r s
 {islist tl p \<and> Ps = list tl p \<and> islist tl q \<and> Qs = list tl q \<and>
  set Ps \<inter> set Qs = {} \<and>
  (p \<noteq> Null \<or> q \<noteq> Null)}
 IF cor (q = Null) (cand (p \<noteq> Null) (p^.hd \<le> q^.hd))
 THEN r := p; p := p^.tl ELSE r := q; q := q^.tl FI;
 s := r;
 WHILE p \<noteq> Null \<or> q \<noteq> Null
 INV {\<exists>rs ps qs a. ispath tl r s \<and> rs = path tl r s \<and>
      islist tl p \<and> ps = list tl p \<and> islist tl q \<and> qs = list tl q \<and>
      distinct(a # ps @ qs @ rs) \<and> s = Ref a \<and>
      merge(Ps,Qs,\<lambda>x y. hd x \<le> hd y) =
      rs @ a # merge(ps,qs,\<lambda>x y. hd x \<le> hd y) \<and>
      (tl a = p \<or> tl a = q)}
 DO IF cor (q = Null) (cand (p \<noteq> Null) (p^.hd \<le> q^.hd))
    THEN s^.tl := p; p := p^.tl ELSE s^.tl := q; q := q^.tl FI;
    s := s^.tl
 OD
 {islist tl r & list tl r = (merge(Ps,Qs,\<lambda>x y. hd x \<le> hd y))}"
apply vcg_simp

apply (simp_all add: cand_def cor_def)
  apply (fastforce)
 apply (fastforce simp: eq_sym_conv)
apply(clarsimp)
done

text"The proof is automatic, but requires a numbet of special lemmas."

subsection "Cyclic list reversal"

text\<open>We consider two algorithms for the reversal of circular lists.
\<close>

lemma circular_list_rev_I:
  "VARS next root p q tmp
  {root = Ref r \<and> distPath next root (r#Ps) root}
  p := root; q := root^.next;
  WHILE q \<noteq> root
  INV {\<exists> ps qs. distPath next p ps root \<and> distPath next q qs root \<and>
             root = Ref r \<and> r \<notin> set Ps  \<and> set ps \<inter> set qs = {} \<and>
             Ps = (rev ps) @ qs  }
  DO tmp := q; q := q^.next; tmp^.next := p; p:=tmp OD;
  root^.next := p
  { root = Ref r \<and> distPath next root (r#rev Ps) root}"
apply (simp only:distPath_def)
apply vcg_simp
  apply (rule_tac x="[]" in exI)
  apply auto
 apply (drule (2) neq_dP)
 apply clarsimp
 apply(rule_tac x="a # ps" in exI)
apply clarsimp
done

text\<open>In the beginning, we are able to assert \<^term>\<open>distPath next
root as root\<close>, with \<^term>\<open>as\<close> set to \<^term>\<open>[]\<close> or
\<^term>\<open>[r,a,b,c]\<close>. Note that \<^term>\<open>Path next root as root\<close> would
additionally give us an infinite number of lists with the recurring
sequence \<^term>\<open>[r,a,b,c]\<close>.

The precondition states that there exists a non-empty non-repeating
path \mbox{\<^term>\<open>r # Ps\<close>} from pointer \<^term>\<open>root\<close> to itself, given that
\<^term>\<open>root\<close> points to location \<^term>\<open>r\<close>. Pointers \<^term>\<open>p\<close> and
\<^term>\<open>q\<close> are then set to \<^term>\<open>root\<close> and the successor of \<^term>\<open>root\<close> respectively. If \<^term>\<open>q = root\<close>, we have circled the loop,
otherwise we set the \<^term>\<open>next\<close> pointer field of \<^term>\<open>q\<close> to point
to \<^term>\<open>p\<close>, and shift \<^term>\<open>p\<close> and \<^term>\<open>q\<close> one step forward. The
invariant thus states that \<^term>\<open>p\<close> and \<^term>\<open>q\<close> point to two
disjoint lists \<^term>\<open>ps\<close> and \<^term>\<open>qs\<close>, such that \<^term>\<open>Ps = rev ps
@ qs\<close>. After the loop terminates, one
extra step is needed to close the loop. As expected, the postcondition
states that the \<^term>\<open>distPath\<close> from \<^term>\<open>root\<close> to itself is now
\<^term>\<open>r # (rev Ps)\<close>.

It may come as a surprise to the reader that the simple algorithm for
acyclic list reversal, with modified annotations, works for cyclic
lists as well:\<close>

lemma circular_list_rev_II:
"VARS next p q tmp
{p = Ref r \<and> distPath next p (r#Ps) p}
q:=Null;
WHILE p \<noteq> Null
INV
{ ((q = Null) \<longrightarrow> (\<exists>ps. distPath next p (ps) (Ref r) \<and> ps = r#Ps)) \<and>
  ((q \<noteq> Null) \<longrightarrow> (\<exists>ps qs. distPath next q (qs) (Ref r) \<and> List next p ps  \<and>
                   set ps \<inter> set qs = {} \<and> rev qs @ ps = Ps@[r])) \<and>
  \<not> (p = Null \<and> q = Null) }
DO tmp := p; p := p^.next; tmp^.next := q; q:=tmp OD
{q = Ref r \<and> distPath next q (r # rev Ps) q}"
apply (simp only:distPath_def)
apply vcg_simp
  apply clarsimp
  apply clarsimp
 apply (case_tac "(q = Null)")
  apply (fastforce intro: Path_is_List)
 apply clarsimp
 apply (rule_tac x= "bs" in exI)
 apply (rule_tac x= "y # qs" in exI)
 apply clarsimp
apply (auto simp:fun_upd_apply)
done

subsection "Storage allocation"

definition new :: "'a set \<Rightarrow> 'a"
  where "new A = (SOME a. a \<notin> A)"

lemma new_notin:
 "\<lbrakk> ~finite(UNIV::'a set); finite(A::'a set); B \<subseteq> A \<rbrakk> \<Longrightarrow> new (A) \<notin> B"
apply(unfold new_def)
apply(rule someI2_ex)
 apply (fast intro:ex_new_if_finite)
apply (fast)
done

lemma "~finite(UNIV::'a set) \<Longrightarrow>
  VARS xs elem next alloc p q
  {Xs = xs \<and> p = (Null::'a ref)}
  WHILE xs \<noteq> []
  INV {islist next p \<and> set(list next p) \<subseteq> set alloc \<and>
       map elem (rev(list next p)) @ xs = Xs}
  DO q := Ref(new(set alloc)); alloc := (addr q)#alloc;
     q^.next := p; q^.elem := hd xs; xs := tl xs; p := q
  OD
  {islist next p \<and> map elem (rev(list next p)) = Xs}"
apply vcg_simp
 apply (clarsimp simp: subset_insert_iff neq_Nil_conv fun_upd_apply new_notin)
apply fastforce
done

end


(*  Title:      HOL/Datatype_Examples/Stream_Processor.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2014

Stream processors---a syntactic representation of continuous functions on streams.
*)

section {* Stream Processors---A Syntactic Representation of Continuous Functions on Streams *}

theory Stream_Processor
imports "~~/src/HOL/Library/Stream" "~~/src/HOL/Library/BNF_Axiomatization"
begin

section {* Continuous Functions on Streams *}

datatype ('a, 'b, 'c) sp\<^sub>\<mu> = Get "'a \<Rightarrow> ('a, 'b, 'c) sp\<^sub>\<mu>" | Put "'b" "'c"
codatatype ('a, 'b) sp\<^sub>\<nu> = In (out: "('a, 'b, ('a, 'b) sp\<^sub>\<nu>) sp\<^sub>\<mu>")

primrec run\<^sub>\<mu> :: "('a, 'b, 'c) sp\<^sub>\<mu> \<Rightarrow> 'a stream \<Rightarrow> ('b \<times> 'c) \<times> 'a stream" where
  "run\<^sub>\<mu> (Get f) s = run\<^sub>\<mu> (f (shd s)) (stl s)"
| "run\<^sub>\<mu> (Put b sp) s = ((b, sp), s)"

primcorec run\<^sub>\<nu> :: "('a, 'b) sp\<^sub>\<nu> \<Rightarrow> 'a stream \<Rightarrow> 'b stream" where
  "run\<^sub>\<nu> sp s = (let ((h, sp), s) = run\<^sub>\<mu> (out sp) s in h ## run\<^sub>\<nu> sp s)"

primcorec copy :: "('a, 'a) sp\<^sub>\<nu>" where
  "copy = In (Get (\<lambda>a. Put a copy))"

lemma run\<^sub>\<nu>_copy: "run\<^sub>\<nu> copy s = s"
  by (coinduction arbitrary: s) simp

text {*
To use the function package for the definition of composition the
wellfoundedness of the subtree relation needs to be proved first.
*}

definition "sub \<equiv> {(f a, Get f) | a f. True}"

lemma subI[intro]: "(f a, Get f) \<in> sub"
  unfolding sub_def by blast

lemma wf_sub[simp, intro]: "wf sub"
proof (rule wfUNIVI)
  fix P  :: "('a, 'b, 'c) sp\<^sub>\<mu> \<Rightarrow> bool" and x
  assume "\<forall>x. (\<forall>y. (y, x) \<in> sub \<longrightarrow> P y) \<longrightarrow> P x"
  hence I: "\<And>x. (\<forall>y. (\<exists>a f. y = f a \<and> x = Get f) \<longrightarrow> P y) \<Longrightarrow> P x" unfolding sub_def by blast
  show "P x" by (induct x) (auto intro: I)
qed

function
  sp\<^sub>\<mu>_comp :: "('a, 'b, 'c) sp\<^sub>\<mu> \<Rightarrow> ('d, 'a, ('d, 'a) sp\<^sub>\<nu>) sp\<^sub>\<mu> \<Rightarrow> ('d, 'b, 'c \<times> ('d, 'a) sp\<^sub>\<nu>) sp\<^sub>\<mu>"
  (infixl "o\<^sub>\<mu>" 65)
where
  "Put b sp o\<^sub>\<mu> fsp = Put b (sp, In fsp)"
| "Get f o\<^sub>\<mu> Put b sp = f b o\<^sub>\<mu> out sp"
| "Get f o\<^sub>\<mu> Get g = Get (\<lambda>a. Get f o\<^sub>\<mu> g a)"
by pat_completeness auto
termination by (relation "lex_prod sub sub") auto

primcorec sp\<^sub>\<nu>_comp (infixl "o\<^sub>\<nu>" 65) where
  "out (sp o\<^sub>\<nu> sp') = map_sp\<^sub>\<mu> id (\<lambda>(sp, sp'). sp o\<^sub>\<nu> sp') (out sp o\<^sub>\<mu> out sp')"

lemma run\<^sub>\<nu>_sp\<^sub>\<nu>_comp: "run\<^sub>\<nu> (sp o\<^sub>\<nu> sp') = run\<^sub>\<nu> sp o run\<^sub>\<nu> sp'"
proof (rule ext, unfold comp_apply)
  fix s
  show "run\<^sub>\<nu> (sp o\<^sub>\<nu> sp') s = run\<^sub>\<nu> sp (run\<^sub>\<nu> sp' s)"
  proof (coinduction arbitrary: sp sp' s)
    case Eq_stream
    show ?case
    proof (induct "out sp" "out sp'" arbitrary: sp sp' s rule: sp\<^sub>\<mu>_comp.induct)
      case (1 b sp'')
      show ?case by (auto simp add: 1[symmetric])
    next
      case (2 f b sp'')
      from 2(1)[of "In (f b)" sp''] show ?case by (simp add: 2(2,3)[symmetric])
    next
      case (3 f h)
      from 3(1)[of _ "shd s" "In (h (shd s))", OF 3(2)] show ?case by (simp add: 3(2,3)[symmetric])
    qed
  qed
qed

text {* Alternative definition of composition using primrec instead of function *}

primrec sp\<^sub>\<mu>_comp2R  where
  "sp\<^sub>\<mu>_comp2R f (Put b sp) = f b (out sp)"
| "sp\<^sub>\<mu>_comp2R f (Get h) = Get (sp\<^sub>\<mu>_comp2R f o h)"

primrec sp\<^sub>\<mu>_comp2 (infixl "o\<^sup>*\<^sub>\<mu>" 65) where
  "Put b sp o\<^sup>*\<^sub>\<mu> fsp = Put b (sp, In fsp)"
| "Get f o\<^sup>*\<^sub>\<mu> fsp = sp\<^sub>\<mu>_comp2R (op o\<^sup>*\<^sub>\<mu> o f) fsp"

primcorec sp\<^sub>\<nu>_comp2 (infixl "o\<^sup>*\<^sub>\<nu>" 65) where
  "out (sp o\<^sup>*\<^sub>\<nu> sp') = map_sp\<^sub>\<mu> id (\<lambda>(sp, sp'). sp o\<^sup>*\<^sub>\<nu> sp') (out sp o\<^sup>*\<^sub>\<mu> out sp')"

lemma run\<^sub>\<nu>_sp\<^sub>\<nu>_comp2: "run\<^sub>\<nu> (sp o\<^sup>*\<^sub>\<nu> sp') = run\<^sub>\<nu> sp o run\<^sub>\<nu> sp'"
proof (rule ext, unfold comp_apply)
  fix s
  show "run\<^sub>\<nu> (sp o\<^sup>*\<^sub>\<nu> sp') s = run\<^sub>\<nu> sp (run\<^sub>\<nu> sp' s)"
  proof (coinduction arbitrary: sp sp' s)
    case Eq_stream
    show ?case
    proof (induct "out sp" arbitrary: sp sp' s)
      case (Put b sp'')
      show ?case by (auto simp add: Put[symmetric])
    next
      case (Get f)
      then show ?case
      proof (induct "out sp'" arbitrary: sp sp' s)
        case (Put b sp'')
        from Put(2)[of "In (f b)" sp''] show ?case by (simp add: Put(1,3)[symmetric])
      next
        case (Get h)
        from Get(1)[OF _ Get(3,4), of "In (h (shd s))"] show ?case by (simp add: Get(2,4)[symmetric])
      qed
    qed
  qed
qed

text {* The two definitions are equivalent *}

lemma sp\<^sub>\<mu>_comp_sp\<^sub>\<mu>_comp2[simp]: "sp o\<^sub>\<mu> sp' = sp o\<^sup>*\<^sub>\<mu> sp'"
  by (induct sp sp' rule: sp\<^sub>\<mu>_comp.induct) auto

(*will be provided by the package*)
lemma sp\<^sub>\<mu>_rel_map_map[unfolded vimage2p_def, simp]:
  "rel_sp\<^sub>\<mu> R1 R2 (map_sp\<^sub>\<mu> f1 f2 sp) (map_sp\<^sub>\<mu> g1 g2 sp') =
  rel_sp\<^sub>\<mu> (BNF_Def.vimage2p f1 g1 R1) (BNF_Def.vimage2p f2 g2 R2) sp sp'"
by (tactic {*
  let val ks = 1 upto 2;
  in
    BNF_Tactics.unfold_thms_tac @{context}
      @{thms sp\<^sub>\<mu>.rel_compp sp\<^sub>\<mu>.rel_conversep sp\<^sub>\<mu>.rel_Grp vimage2p_Grp} THEN
    HEADGOAL (EVERY' [rtac iffI, rtac @{thm relcomppI}, rtac @{thm GrpI}, rtac refl, rtac CollectI,
      BNF_Util.CONJ_WRAP' (K (rtac @{thm subset_UNIV})) ks, rtac @{thm relcomppI}, atac,
      rtac @{thm conversepI}, rtac @{thm GrpI}, rtac refl, rtac CollectI,
      BNF_Util.CONJ_WRAP' (K (rtac @{thm subset_UNIV})) ks,
      REPEAT_DETERM o eresolve_tac @{thms relcomppE conversepE GrpE},
      hyp_subst_tac @{context}, atac])
  end
*})

lemma sp\<^sub>\<mu>_rel_self: "\<lbrakk>op = \<le> R1; op = \<le> R2\<rbrakk> \<Longrightarrow> rel_sp\<^sub>\<mu> R1 R2 x x"
  by (erule (1) predicate2D[OF sp\<^sub>\<mu>.rel_mono]) (simp only: sp\<^sub>\<mu>.rel_eq)

lemma sp\<^sub>\<nu>_comp_sp\<^sub>\<nu>_comp2: "sp o\<^sub>\<nu> sp' = sp o\<^sup>*\<^sub>\<nu> sp'"
  by (coinduction arbitrary: sp sp') (auto intro!: sp\<^sub>\<mu>_rel_self)

section {* Generalization to an Arbitrary BNF as Codomain *}

bnf_axiomatization ('a, 'b) F for map: F

notation BNF_Def.convol ("\<langle>(_,/ _)\<rangle>")

definition \<theta> :: "('p,'a) F * 'b \<Rightarrow> ('p,'a * 'b) F" where
  "\<theta> xb = F id \<langle>id, \<lambda> a. (snd xb)\<rangle> (fst xb)"

(* The strength laws for \<theta>: *)
lemma \<theta>_natural: "F id (map_prod f g) o \<theta> = \<theta> o map_prod (F id f) g"
  unfolding \<theta>_def F.map_comp comp_def id_apply convol_def map_prod_def split_beta fst_conv snd_conv ..

definition assl :: "'a * ('b * 'c) \<Rightarrow> ('a * 'b) * 'c" where
  "assl abc = ((fst abc, fst (snd abc)), snd (snd abc))"

lemma \<theta>_rid: "F id fst o \<theta> = fst"
  unfolding \<theta>_def F.map_comp F.map_id comp_def id_apply convol_def fst_conv sym[OF id_def] ..

lemma \<theta>_assl: "F id assl o \<theta> = \<theta> o map_prod \<theta> id o assl"
  unfolding assl_def \<theta>_def F.map_comp comp_def id_apply convol_def map_prod_def split fst_conv snd_conv ..

datatype ('a, 'b, 'c) spF\<^sub>\<mu> = GetF "'a \<Rightarrow> ('a, 'b, 'c) spF\<^sub>\<mu>" | PutF "('b,'c) F"
codatatype ('a, 'b) spF\<^sub>\<nu> = InF (outF: "('a, 'b, ('a, 'b) spF\<^sub>\<nu>) spF\<^sub>\<mu>")

codatatype 'b JF = Ctor (dtor: "('b, 'b JF) F")

(* Definition of run for an arbitrary final coalgebra as codomain: *)

primrec
  runF\<^sub>\<mu> :: "('a, 'b, ('a, 'b) spF\<^sub>\<nu>) spF\<^sub>\<mu> \<Rightarrow> 'a stream \<Rightarrow> (('b, ('a, 'b) spF\<^sub>\<nu>) F) \<times> 'a stream"
where
  "runF\<^sub>\<mu> (GetF f) s = (runF\<^sub>\<mu> o f) (shd s) (stl s)"
| "runF\<^sub>\<mu> (PutF x) s = (x, s)"

primcorec runF\<^sub>\<nu> :: "('a, 'b) spF\<^sub>\<nu> \<Rightarrow> 'a stream \<Rightarrow> 'b JF" where
  "runF\<^sub>\<nu> sp s = (let (x, s) = runF\<^sub>\<mu> (outF sp) s in Ctor (F id (\<lambda> sp. runF\<^sub>\<nu> sp s) x))"

end


(*  Title:      Prefix_Match.thy
    Authors:    Julius Michaelis, Cornelius Diekmann
*)
theory Prefix_Match
imports IP_Address
begin

section\<open>Prefix Match\<close>
text\<open>
  The main difference between the prefix match defined here and CIDR notation is a validity
  constraint imposed on prefix matches.

  For example, 192.168.42.42/16 is valid CIDR notation whereas for a prefix match,
  it must be 192.168.0.0/16.

  I.e. the last bits of the prefix must be set to zero.
\<close>

context
  notes [[typedef_overloaded]]
begin
  datatype 'a prefix_match = PrefixMatch (pfxm_prefix: "'a::len word") (pfxm_length: nat)
end

definition pfxm_mask :: "'a prefix_match \<Rightarrow> 'a::len word" where
  "pfxm_mask x \<equiv> mask (len_of (TYPE('a)) - pfxm_length x)"

context
  includes bit_operations_syntax
begin

definition valid_prefix :: "('a::len) prefix_match \<Rightarrow> bool" where
  "valid_prefix pf = ((pfxm_mask pf) AND pfxm_prefix pf = 0)"
text\<open>Note that @{const valid_prefix} looks very elegant as a definition. However, it hides something nasty:\<close>
lemma "valid_prefix (PrefixMatch (0::32 word) 42)" by eval

text\<open>When zeroing all least significant bits which exceed the @{const pfxm_length},
     you get a @{const valid_prefix}\<close>
lemma mk_valid_prefix:
  fixes base::"'a::len word"
  shows "valid_prefix (PrefixMatch (base AND NOT (mask (len_of TYPE ('a) - len))) len)"
proof -
  have "mask (len - m) AND base AND NOT (mask (len - m)) = 0"
    for m len and base::"'a::len word" by(simp add: word_bw_lcs)
  thus ?thesis
  by(simp add: valid_prefix_def pfxm_mask_def pfxm_length_def pfxm_prefix_def)
qed

end

text\<open>The type @{typ "'a prefix_match"} usually requires @{const valid_prefix}.
      When we allow working on arbitrary IPs in CIDR notation,
      we will use the type @{typ "('i::len word \<times> nat)"} directly.\<close>

lemma valid_prefix_00: "valid_prefix (PrefixMatch 0 0)" by (simp add: valid_prefix_def)

definition prefix_match_to_CIDR :: "('i::len) prefix_match \<Rightarrow> ('i word \<times> nat)" where
  "prefix_match_to_CIDR pfx \<equiv> (pfxm_prefix pfx, pfxm_length pfx)"

lemma prefix_match_to_CIDR_def2: "prefix_match_to_CIDR = (\<lambda>pfx. (pfxm_prefix pfx, pfxm_length pfx))"
  unfolding prefix_match_to_CIDR_def fun_eq_iff by simp

definition "prefix_match_dtor m \<equiv> (case m of PrefixMatch p l \<Rightarrow> (p,l))"

text\<open>Some more or less random linear order on prefixes.
     Only used for serialization at the time of this writing.\<close>
instantiation prefix_match :: (len) linorder
begin
	definition "a \<le> b \<longleftrightarrow> (if pfxm_length a = pfxm_length b
                         then pfxm_prefix a \<le> pfxm_prefix b
                         else pfxm_length a > pfxm_length b)"
	definition "a < b \<longleftrightarrow> (a \<noteq> b \<and>
	                       (if pfxm_length a = pfxm_length b
	                        then pfxm_prefix a \<le> pfxm_prefix b
	                        else pfxm_length a > pfxm_length b))"
instance
by standard (auto simp: less_eq_prefix_match_def less_prefix_match_def prefix_match.expand
                  split: if_splits)
end

lemma "sorted_list_of_set
 {PrefixMatch 0 32 :: 32 prefix_match,
  PrefixMatch 42 32,
  PrefixMatch 0 0,
  PrefixMatch 0 1,
  PrefixMatch 12 31} =
    [PrefixMatch 0 32, PrefixMatch 0x2A 32, PrefixMatch 0xC 31, PrefixMatch 0 1, PrefixMatch 0 0]"
  by eval

context
  includes bit_operations_syntax
begin

private lemma valid_prefix_E: "valid_prefix pf \<Longrightarrow> ((pfxm_mask pf) AND pfxm_prefix pf = 0)"
  unfolding valid_prefix_def .
private lemma valid_prefix_alt: fixes p::"'a::len prefix_match"
  shows "valid_prefix p = (pfxm_prefix p AND (2 ^ ((len_of TYPE ('a)) - pfxm_length p) - 1) = 0)"
  unfolding valid_prefix_def
  unfolding mask_eq
  using word_bw_comms(1)
   arg_cong[where f = "\<lambda>x. (pfxm_prefix p AND x - 1 = 0)"]
   shiftl_1
  unfolding pfxm_prefix_def pfxm_mask_def mask_eq
  apply (cases p)
  apply (simp add: ac_simps push_bit_of_1)
  done

subsection\<open>Address Semantics\<close>
  text\<open>Matching on a @{typ "'a::len prefix_match"}. Think of routing tables.\<close>
  definition prefix_match_semantics where
    "prefix_match_semantics m a \<equiv> pfxm_prefix m = NOT (pfxm_mask m) AND a"

lemma same_length_prefixes_distinct: "valid_prefix pfx1 \<Longrightarrow> valid_prefix pfx2 \<Longrightarrow> pfx1 \<noteq> pfx2 \<Longrightarrow> pfxm_length pfx1 = pfxm_length pfx2 \<Longrightarrow> prefix_match_semantics pfx1 w \<Longrightarrow> prefix_match_semantics pfx2 w \<Longrightarrow> False"
  by (simp add: pfxm_mask_def prefix_match.expand prefix_match_semantics_def)

subsection\<open>Relation between prefix and set\<close>

  definition prefix_to_wordset :: "'a::len prefix_match \<Rightarrow> 'a word set" where
    "prefix_to_wordset pfx = {pfxm_prefix pfx .. pfxm_prefix pfx OR pfxm_mask pfx}"

  private lemma pfx_not_empty: "valid_prefix pfx \<Longrightarrow> prefix_to_wordset pfx \<noteq> {}"
    unfolding valid_prefix_def prefix_to_wordset_def by(simp add: le_word_or2)

  lemma zero_prefix_match_all:
    "valid_prefix m \<Longrightarrow> pfxm_length m = 0 \<Longrightarrow> prefix_match_semantics m ip"
    by(simp add: pfxm_mask_def mask_2pm1 valid_prefix_alt prefix_match_semantics_def)

  lemma prefix_to_wordset_subset_ipset_from_cidr:
      "prefix_to_wordset pfx \<subseteq> ipset_from_cidr (pfxm_prefix pfx) (pfxm_length pfx)"
    apply(rule subsetI)
    apply(simp add: prefix_to_wordset_def addr_in_ipset_from_cidr_code)

    apply(intro impI conjI)
     apply (metis (erased, opaque_lifting) order_trans word_and_le2)
    apply(simp add: pfxm_mask_def)
    done

subsection\<open>Equivalence Proofs\<close>
  theorem prefix_match_semantics_wordset:
    assumes "valid_prefix pfx"
    shows "prefix_match_semantics pfx a \<longleftrightarrow> a \<in> prefix_to_wordset pfx"
    using assms
    unfolding valid_prefix_def pfxm_mask_def prefix_match_semantics_def prefix_to_wordset_def
    apply(cases pfx, rename_tac base len)
    apply(simp)
    apply(drule_tac base=base and len=len and a=a in zero_base_lsb_imp_set_eq_as_bit_operation)
    by (simp)

  private lemma valid_prefix_ipset_from_netmask_ipset_from_cidr:
    shows "ipset_from_netmask (pfxm_prefix pfx) (NOT (pfxm_mask pfx)) =
            ipset_from_cidr (pfxm_prefix pfx) (pfxm_length pfx)"
    apply(cases pfx)
    apply(simp add: ipset_from_cidr_alt2 pfxm_mask_def)
   done

  lemma prefix_match_semantics_ipset_from_netmask:
    assumes "valid_prefix pfx"
    shows "prefix_match_semantics pfx a \<longleftrightarrow>
            a \<in> ipset_from_netmask (pfxm_prefix pfx) (NOT (pfxm_mask pfx))"
    unfolding prefix_match_semantics_wordset[OF assms]
    unfolding valid_prefix_ipset_from_netmask_ipset_from_cidr
    unfolding prefix_to_wordset_def
    apply(subst ipset_from_cidr_base_wellforemd)
     subgoal using assms by(simp add: valid_prefix_def pfxm_mask_def)
    by(simp add: pfxm_mask_def)

  lemma prefix_match_semantics_ipset_from_netmask2:
    assumes "valid_prefix pfx"
    shows "prefix_match_semantics pfx (a :: 'i::len word) \<longleftrightarrow>
            a \<in> ipset_from_cidr (pfxm_prefix pfx) (pfxm_length pfx)"
   unfolding prefix_match_semantics_ipset_from_netmask[OF assms] pfxm_mask_def ipset_from_cidr_def
   by (metis (full_types) NOT_mask_shifted_lenword word_not_not)

  lemma prefix_to_wordset_ipset_from_cidr:
    assumes "valid_prefix (pfx::'a::len prefix_match)"
    shows "prefix_to_wordset pfx = ipset_from_cidr (pfxm_prefix pfx) (pfxm_length pfx)"
  proof -
    have helper3: "(x::'a::len word) OR y = x OR y AND NOT x" for x y by (simp add: word_oa_dist2)
    have prefix_match_semantics_ipset_from_netmask:
           "(prefix_to_wordset pfx) = ipset_from_netmask (pfxm_prefix pfx) (NOT (pfxm_mask pfx))"
      unfolding prefix_to_wordset_def ipset_from_netmask_def Let_def
      using assms
        by (clarsimp dest!: valid_prefix_E) (metis bit.conj_commute mask_eq_0_eq_x)
      have "((mask len)::'a::len word) << LENGTH('a) - len = ~~ (mask (LENGTH('a) - len))"
        for len using NOT_mask_shifted_lenword by (metis word_not_not)
      from this[of "(pfxm_length pfx)"] have mask_def2_symmetric:
        "((mask (pfxm_length pfx)::'a::len word) << LENGTH('a) - pfxm_length pfx) =
          NOT (pfxm_mask pfx)"
        unfolding pfxm_mask_def by simp

      have ipset_from_netmask_prefix:
        "ipset_from_netmask (pfxm_prefix pfx) (NOT (pfxm_mask pfx)) =
          ipset_from_cidr (pfxm_prefix pfx) (pfxm_length pfx)"
       unfolding ipset_from_netmask_def ipset_from_cidr_alt
       unfolding pfxm_mask_def[symmetric]
       unfolding mask_def2_symmetric
       apply(simp)
       unfolding Let_def
       using assms[unfolded valid_prefix_def]
       by (metis helper3 word_bw_comms(2))

      show ?thesis by (metis ipset_from_netmask_prefix local.prefix_match_semantics_ipset_from_netmask)
  qed

  definition prefix_to_wordinterval :: "'a::len prefix_match \<Rightarrow> 'a wordinterval" where
    "prefix_to_wordinterval pfx \<equiv> WordInterval (pfxm_prefix pfx) (pfxm_prefix pfx OR pfxm_mask pfx)"

  lemma prefix_to_wordinterval_set_eq[simp]:
    "wordinterval_to_set (prefix_to_wordinterval pfx) = prefix_to_wordset pfx"
    unfolding prefix_to_wordinterval_def prefix_to_wordset_def by simp

  lemma prefix_to_wordinterval_def2:
    "prefix_to_wordinterval pfx =
      iprange_interval ((pfxm_prefix pfx), (pfxm_prefix pfx OR pfxm_mask pfx))"
    unfolding iprange_interval.simps prefix_to_wordinterval_def by simp
  corollary prefix_to_wordinterval_ipset_from_cidr: "valid_prefix pfx \<Longrightarrow>
    wordinterval_to_set (prefix_to_wordinterval pfx) =
      ipset_from_cidr (pfxm_prefix pfx) (pfxm_length pfx)"
  using prefix_to_wordset_ipset_from_cidr prefix_to_wordinterval_set_eq by auto
end

lemma prefix_never_empty:
  fixes d:: "'a::len prefix_match"
  shows"\<not> wordinterval_empty (prefix_to_wordinterval d)"
by (simp add: le_word_or2 prefix_to_wordinterval_def)

text\<open>Getting a lowest element\<close>
  lemma ipset_from_cidr_lowest: "a \<in> ipset_from_cidr a n"
    using ip_cidr_set_def ipset_from_cidr_eq_ip_cidr_set by blast

  (*this is why I call the previous lemma 'lowest'*)
  lemma "valid_prefix (PrefixMatch a n) \<Longrightarrow> is_lowest_element a (ipset_from_cidr a n)"
    apply(simp add: is_lowest_element_def ipset_from_cidr_lowest)
    apply(simp add: ipset_from_cidr_eq_ip_cidr_set ip_cidr_set_def)
    apply(simp add: valid_prefix_def pfxm_mask_def)
    by (metis diff_zero eq_iff mask_out_sub_mask word_and_le2 word_bw_comms(1))

end


(*  Title:      HOL/Multivariate_Analysis/Norm_Arith.thy
    Author:     Amine Chaieb, University of Cambridge
*)

section {* General linear decision procedure for normed spaces *}

theory Norm_Arith
imports "~~/src/HOL/Library/Sum_of_Squares"
begin

lemma norm_cmul_rule_thm:
  fixes x :: "'a::real_normed_vector"
  shows "b \<ge> norm x \<Longrightarrow> \<bar>c\<bar> * b \<ge> norm (scaleR c x)"
  unfolding norm_scaleR
  apply (erule mult_left_mono)
  apply simp
  done

(* FIXME: Move all these theorems into the ML code using lemma antiquotation *)
lemma norm_add_rule_thm:
  fixes x1 x2 :: "'a::real_normed_vector"
  shows "norm x1 \<le> b1 \<Longrightarrow> norm x2 \<le> b2 \<Longrightarrow> norm (x1 + x2) \<le> b1 + b2"
  by (rule order_trans [OF norm_triangle_ineq add_mono])

lemma ge_iff_diff_ge_0:
  fixes a :: "'a::linordered_ring"
  shows "a \<ge> b \<equiv> a - b \<ge> 0"
  by (simp add: field_simps)

lemma pth_1:
  fixes x :: "'a::real_normed_vector"
  shows "x \<equiv> scaleR 1 x" by simp

lemma pth_2:
  fixes x :: "'a::real_normed_vector"
  shows "x - y \<equiv> x + -y"
  by (atomize (full)) simp

lemma pth_3:
  fixes x :: "'a::real_normed_vector"
  shows "- x \<equiv> scaleR (-1) x"
  by simp

lemma pth_4:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR 0 x \<equiv> 0"
    and "scaleR c 0 = (0::'a)"
  by simp_all

lemma pth_5:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR c (scaleR d x) \<equiv> scaleR (c * d) x"
  by simp

lemma pth_6:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR c (x + y) \<equiv> scaleR c x + scaleR c y"
  by (simp add: scaleR_right_distrib)

lemma pth_7:
  fixes x :: "'a::real_normed_vector"
  shows "0 + x \<equiv> x"
    and "x + 0 \<equiv> x"
  by simp_all

lemma pth_8:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR c x + scaleR d x \<equiv> scaleR (c + d) x"
  by (simp add: scaleR_left_distrib)

lemma pth_9:
  fixes x :: "'a::real_normed_vector"
  shows "(scaleR c x + z) + scaleR d x \<equiv> scaleR (c + d) x + z"
    and "scaleR c x + (scaleR d x + z) \<equiv> scaleR (c + d) x + z"
    and "(scaleR c x + w) + (scaleR d x + z) \<equiv> scaleR (c + d) x + (w + z)"
  by (simp_all add: algebra_simps)

lemma pth_a:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR 0 x + y \<equiv> y"
  by simp

lemma pth_b:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR c x + scaleR d y \<equiv> scaleR c x + scaleR d y"
    and "(scaleR c x + z) + scaleR d y \<equiv> scaleR c x + (z + scaleR d y)"
    and "scaleR c x + (scaleR d y + z) \<equiv> scaleR c x + (scaleR d y + z)"
    and "(scaleR c x + w) + (scaleR d y + z) \<equiv> scaleR c x + (w + (scaleR d y + z))"
  by (simp_all add: algebra_simps)

lemma pth_c:
  fixes x :: "'a::real_normed_vector"
  shows "scaleR c x + scaleR d y \<equiv> scaleR d y + scaleR c x"
    and "(scaleR c x + z) + scaleR d y \<equiv> scaleR d y + (scaleR c x + z)"
    and "scaleR c x + (scaleR d y + z) \<equiv> scaleR d y + (scaleR c x + z)"
    and "(scaleR c x + w) + (scaleR d y + z) \<equiv> scaleR d y + ((scaleR c x + w) + z)"
  by (simp_all add: algebra_simps)

lemma pth_d:
  fixes x :: "'a::real_normed_vector"
  shows "x + 0 \<equiv> x"
  by simp

lemma norm_imp_pos_and_ge:
  fixes x :: "'a::real_normed_vector"
  shows "norm x \<equiv> n \<Longrightarrow> norm x \<ge> 0 \<and> n \<ge> norm x"
  by atomize auto

lemma real_eq_0_iff_le_ge_0:
  fixes x :: real
  shows "x = 0 \<equiv> x \<ge> 0 \<and> - x \<ge> 0"
  by arith

lemma norm_pths:
  fixes x :: "'a::real_normed_vector"
  shows "x = y \<longleftrightarrow> norm (x - y) \<le> 0"
    and "x \<noteq> y \<longleftrightarrow> \<not> (norm (x - y) \<le> 0)"
  using norm_ge_zero[of "x - y"] by auto

lemmas arithmetic_simps =
  arith_simps
  add_numeral_special
  add_neg_numeral_special
  mult_1_left
  mult_1_right

ML_file "normarith.ML"

method_setup norm = {*
  Scan.succeed (SIMPLE_METHOD' o NormArith.norm_arith_tac)
*} "prove simple linear statements about vector norms"

text {* Hence more metric properties. *}

lemma dist_triangle_add:
  fixes x y x' y' :: "'a::real_normed_vector"
  shows "dist (x + y) (x' + y') \<le> dist x x' + dist y y'"
  by norm

lemma dist_triangle_add_half:
  fixes x x' y y' :: "'a::real_normed_vector"
  shows "dist x x' < e / 2 \<Longrightarrow> dist y y' < e / 2 \<Longrightarrow> dist(x + y) (x' + y') < e"
  by norm

end


(* Title: thys/Turing.thy
   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
   Modifications: Sebastiaan Joosten
   Modifications, comments by Franz Regensburger (FABR) 02/2022
 *)

chapter \<open>Turing Machines\<close>

theory Turing
  imports Main
begin

section \<open>Some lemmas about natural numbers used for rewriting\<close>

(* ------ Important properties used in subsequent theories ------ *)

(*
  Num.numeral_1_eq_Suc_0: Numeral1 = Suc 0
  Num.numeral_2_eq_2: 2 = Suc (Suc 0)
  Num.numeral_3_eq_3: 3 = Suc (Suc (Suc 0))
*)

lemma numeral_4_eq_4: "4 = Suc 3"
  by auto

lemma numeral_eqs_upto_12:
  shows "2 = Suc 1"
    and "3 = Suc 2"
    and "4 = Suc 3"
    and "5 = Suc 4"
    and "6 = Suc 5"
    and "7 = Suc 6"
    and "8 = Suc 7"
    and "9 = Suc 8"
    and "10 = Suc 9"
    and "11 = Suc 10"
    and "12 = Suc 11"
  by simp_all

section \<open>Basic Definitions for Turing Machines\<close>

datatype action = WB | WO | L | R | Nop

datatype cell = Bk | Oc

text\<open>Remark: the constructors @{term W0} and @{term W1} were renamed into @{term WB} and @{term WO}
respectively because this makes a better match with the constructors @{term Bk} and @{term Oc} of
type @{typ cell}.\<close>

type_synonym tape = "cell list \<times> cell list"

type_synonym state = nat

type_synonym instr = "action \<times> state"

type_synonym tprog = "instr list \<times> nat"

(* The type tprog0 is the type of un-shifted Turing machines (offset = 0).
 *
 * FABR note:
 * Every (tm:: instr list) is a proper Turing machine.
 *
 * However, tm may not be composable with other Turing machines.
 * For the sequential composition tm |+| tm' the machine tm must be 'well-formed'.
 * See theory ComposableTMs.thy for more details.
 *
 * We will prove in theory ComposableTMs.thy that for every
 * Turing machine tm, which is not well-formed, there is a machine
 *    (mk_composable0 tm)
 * that is well-formed and has the same behaviour as tm.
 *
 * Thus, all Turing machines can be made composable :-)
 *)

type_synonym tprog0 = "instr list"

type_synonym config = "state \<times> tape"

fun nth_of where
  "nth_of xs i = (if i \<ge> length xs then None else Some (xs ! i))"

lemma nth_of_map (* [simp]*): (* this lemma is used nowhere *)
  shows "nth_of (map f p) n = (case (nth_of p n) of None \<Rightarrow> None | Some x \<Rightarrow> Some (f x))"
  by simp

fun
  fetch :: "instr list \<Rightarrow> state \<Rightarrow> cell \<Rightarrow> instr"
  where
    "fetch p 0 b = (Nop, 0)"
  | "fetch p (Suc s) Bk =
     (case nth_of p (2 * s) of
        Some i \<Rightarrow> i
      | None \<Rightarrow> (Nop, 0))"
  |"fetch p (Suc s) Oc =
     (case nth_of p ((2 * s) + 1) of
         Some i \<Rightarrow> i
       | None \<Rightarrow> (Nop, 0))"

lemma fetch_Nil [simp]:
  shows "fetch [] s b = (Nop, 0)"
  by (cases s,force) (cases b;force)

(* Simpler code without usage of function nth_of *)
lemma fetch_imp [code]: "fetch p n b = (
    let len = length p
    in
    if n = 0
    then (Nop, 0)
    else if b = Bk
         then if len \<le> 2*n -2
              then (Nop,0)
              else (p ! (2*n-2))
         else if len \<le> 2*n-1
              then (Nop,0)
              else (p ! (2*n-1))
  )"
  by (cases n; cases b)(auto)

(* ------------------------------------ *)
(* Some arithmetic properties           *)
(* ------------------------------------ *)

lemma even_le_div2_imp_le_times_2: "m     div 2 < (Suc n) \<and> ((m::nat) mod 2 = 0) \<Longrightarrow> m \<le> 2*n" by arith

lemma odd_le_div2_imp_le_times_2: "(m+1) div 2 < (Suc n) \<and> ((m::nat) mod 2 \<noteq> 0) \<Longrightarrow> m \<le> 2*n" by arith

lemma odd_div2_plus_1_eq: "(n::nat) mod 2 \<noteq> 0 \<Longrightarrow> (n div 2) + 1 = (n+1) div 2"
proof (induct n)
  case 0
  then show ?case by auto
next
  case (Suc n)
  then show ?case by arith
qed

(* ---------------------------------- *)
(* A lemma about the list function tl *)
(* ---------------------------------- *)

lemma list_length_tl_neq_Nil: "1 < length (nl::nat list) \<Longrightarrow> tl nl \<noteq> []"
proof
  assume "1 < length nl" and "tl nl = []"
  then have "length (tl nl) = 0" by auto
  with \<open>1 < length nl\<close> and length_tl
  show False by auto
qed

(* --- A function for executing actions on the tape --- *)

fun
  update :: "action \<Rightarrow> tape \<Rightarrow> tape"
  where
    "update WB (l, r) = (l, Bk # (tl r))"
  | "update WO (l, r) = (l, Oc # (tl r))"
  | "update L (l, r) = (if l = [] then ([], Bk # r) else (tl l, (hd l) # r))"
  | "update R (l, r) = (if r = [] then (Bk # l, []) else ((hd r) # l, tl r))"
  | "update Nop (l, r) = (l, r)"

abbreviation
  "read r == if (r = []) then Bk else hd r"

fun step :: "config \<Rightarrow> tprog \<Rightarrow> config"
  where
    "step (s, l, r) (p, off) =
     (let (a, s') = fetch p (s - off) (read r) in (s', update a (l, r)))"

abbreviation
  "step0 c p \<equiv> step c (p, 0)"

fun steps :: "config \<Rightarrow> tprog \<Rightarrow> nat \<Rightarrow> config"
  where
    "steps c p 0 = c" |
    "steps c p (Suc n) = steps (step c p) p n"

abbreviation
  "steps0 c p n \<equiv> steps c (p, 0) n"

lemma steps_add [simp]:
  shows "steps c p (m + n) = steps (steps c p m) p n"
  by (induct m arbitrary: c) (auto)

lemma step_0 [simp]:
  shows "step (0, (l, r)) p = (0, (l, r))"
  by (cases p, simp)

lemma step_0': "step (0, tap) p = (0, tap)" by (cases tap) auto

lemma steps_0 [simp]:
  shows "steps (0, (l, r)) p n = (0, (l, r))"
  by (induct n) (simp_all)

fun
  is_final :: "config \<Rightarrow> bool"
  where
    "is_final (s, l, r) = (s = 0)"

lemma is_final_eq:
  shows "is_final (s, tap) = (s = 0)"
  by (cases tap) (auto)

lemma is_finalI [intro]:
  shows "is_final (0, tap)"
  by (simp add: is_final_eq)

lemma after_is_final:
  assumes "is_final c"
  shows "is_final (steps c p n)"
  using assms
  by(induct n;cases c;auto)

lemma is_final:
  assumes a: "is_final (steps c p n1)"
    and b: "n1 \<le> n2"
  shows "is_final (steps c p n2)"
proof -
  obtain n3 where eq: "n2 = n1 + n3" using b by (metis le_iff_add)
  from a show "is_final (steps c p n2)" unfolding eq
    by (simp add: after_is_final)
qed

(* steps add *)
lemma stable_config_after_final_add:
  assumes "steps (1, l, r) p n1      = (0, l', r')"
  shows   "steps (1, l, r) p (n1+n2) = (0, l', r')"
proof -
  from assms have "is_final (steps (1, l, r) p n1)" by  (auto simp add: is_final_eq)
  moreover have "n1 \<le> (n1+n2)" by auto
  ultimately have "is_final (steps (1, l, r) p (n1+n2))" by (rule  is_final)
  with assms show ?thesis by (auto simp add: is_final_eq)
qed

lemma stable_config_after_final_add_2:
  assumes "steps (s, l, r) p n1      = (0, l', r')"
  shows   "steps (s, l, r) p (n1+n2) = (0, l', r')"
proof -
  from assms have "is_final (steps (s, l, r) p n1)" by  (auto simp add: is_final_eq)
  moreover have "n1 \<le> (n1+n2)" by auto
  ultimately have "is_final (steps (s, l, r) p (n1+n2))" by (rule  is_final)
  with assms show ?thesis by (auto simp add: is_final_eq)
qed

(* steps \<le> *)

lemma stable_config_after_final_ge:
  assumes a: "steps (1, l, r) p n1 = (0, l', r')" and b: "n1 \<le> n2"
  shows   "steps (1, l, r) p n2 = (0, l', r')"
proof -
  from b have "\<exists>k. n2 = n1 + k" by arith
  then obtain k where w: "n2 = n1 + k" by blast
  with a have "steps (1, l, r) p ( n1 + k) = (0, l', r')"
    by (auto simp add: stable_config_after_final_add)
  with w show ?thesis by auto
qed

lemma stable_config_after_final_ge_2:
  assumes a: "steps (s, l, r) p n1 = (0, l', r')" and b: "n1 \<le> n2"
  shows   "steps (s, l, r) p n2 = (0, l', r')"
proof -
  from b have "\<exists>k. n2 = n1 + k" by arith
  then obtain k where w: "n2 = n1 + k" by blast
  with a have "steps (s, l, r) p ( n1 + k) = (0, l', r')"
    by (auto simp add: stable_config_after_final_add)
  with w show ?thesis by auto
qed

(* steps0 \<le> *)

lemma stable_config_after_final_ge':
  assumes "steps0 (1, l, r) p n1 = (0, l', r')" and b: "n1 \<le> n2"
  shows   "steps0 (1, l, r) p n2 = (0, l', r')"
proof -
  from assms have "steps (1, l, r) (p, 0) n1 = (0, l', r')" by auto
  from this and  assms(2) show "steps (1, l, r) (p,0) n2 = (0, l', r')"
    by (rule stable_config_after_final_ge)
qed

lemma stable_config_after_final_ge_2':
  assumes "steps0 (s, l, r) p n1 = (0, l', r')" and b: "n1 \<le> n2"
  shows   "steps0 (s, l, r) p n2 = (0, l', r')"
proof -
  from assms have "steps (s, l, r) (p, 0) n1 = (0, l', r')" by auto
  from this and  assms(2) show "steps (s, l, r) (p,0) n2 = (0, l', r')"
    by (rule stable_config_after_final_ge_2)
qed

lemma not_is_final:
  assumes a: "\<not> is_final (steps c p n1)"
    and b: "n2 \<le> n1"
  shows "\<not> is_final (steps c p n2)"
proof (rule notI)
  obtain n3 where eq: "n1 = n2 + n3" using b by (metis le_iff_add)
  assume "is_final (steps c p n2)"
  then have "is_final (steps c p n1)" unfolding eq
    by (simp add: after_is_final)
  with a show "False" by simp
qed

(* if the machine is in the halting state, there must have
   been a state just before the halting state *)

lemma before_final:
  assumes "steps0 (1, tap) A n = (0, tap')"
  shows "\<exists> n'. \<not> is_final (steps0 (1, tap) A n') \<and> steps0 (1, tap) A (Suc n') = (0, tap')"
  using assms
proof(induct n arbitrary: tap')
  case (0 tap')
  have asm: "steps0 (1, tap) A 0 = (0, tap')" by fact
  then show "\<exists>n'. \<not> is_final (steps0 (1, tap) A n') \<and> steps0 (1, tap) A (Suc n') = (0, tap')"
    by simp
next
  case (Suc n tap')
  have ih: "\<And>tap'. steps0 (1, tap) A n = (0, tap') \<Longrightarrow>
    \<exists>n'. \<not> is_final (steps0 (1, tap) A n') \<and> steps0 (1, tap) A (Suc n') = (0, tap')" by fact
  have asm: "steps0 (1, tap) A (Suc n) = (0, tap')" by fact
  obtain s l r where cases: "steps0 (1, tap) A n = (s, l, r)"
    by (auto intro: is_final.cases)
  then show "\<exists>n'. \<not> is_final (steps0 (1, tap) A n') \<and> steps0 (1, tap) A (Suc n') = (0, tap')"
  proof (cases "s = 0")
    case True (* in halting state *)
    then have "steps0 (1, tap) A n = (0, tap')"
      using asm cases by (simp del: steps.simps)
    then show ?thesis using ih by simp
  next
    case False (* not in halting state *)
    then have "\<not> is_final (steps0 (1, tap) A n) \<and> steps0 (1, tap) A (Suc n) = (0, tap')"
      using asm cases by simp
    then show ?thesis by auto
  qed
qed

lemma least_steps:
  assumes "steps0 (1, tap) A n = (0, tap')"
  shows "\<exists> n'. (\<forall>n'' < n'. \<not> is_final (steps0 (1, tap) A n'')) \<and>
               (\<forall>n'' \<ge> n'. is_final (steps0 (1, tap) A n''))"
proof -
  from before_final[OF assms]
  obtain n' where
    before: "\<not> is_final (steps0 (1, tap) A n')" and
    final: "steps0 (1, tap) A (Suc n') = (0, tap')" by auto
  from before
  have "\<forall>n'' < Suc n'. \<not> is_final (steps0 (1, tap) A n'')"
    using not_is_final by auto
  moreover
  from final
  have "\<forall>n'' \<ge> Suc n'. is_final (steps0 (1, tap) A n'')"
    using is_final[of _ _ "Suc n'"] by (auto simp add: is_final_eq)
  ultimately
  show "\<exists> n'. (\<forall>n'' < n'. \<not> is_final (steps0 (1, tap) A n'')) \<and> (\<forall>n'' \<ge> n'. is_final (steps0 (1, tap) A n''))"
    by blast
qed

lemma at_least_one_step:"steps0 (1, [], r) tm n = (0,tap) \<Longrightarrow> 0 < n"
  by (cases n)(auto)

end


section \<open>Mixed Integer Solutions\<close>

text \<open>We prove that if an integral system of linear inequalities
$Ax \leq b \wedge A'x < b'$ has a (mixed)integer solution, there there is also
a small (mixed)integer solution, where the numbers are bounded by
$(n+1)! \cdot m^n$ where $n$ is the number of variables and $m$ is a bound on
the absolute values of numbers occurring in $A,A',b,b'$.\<close>

theory Mixed_Integer_Solutions
  imports Decomposition_Theorem
begin

definition less_vec :: "'a vec \<Rightarrow> ('a :: ord) vec \<Rightarrow> bool" (infix "<\<^sub>v" 50) where
  "v <\<^sub>v w = (dim_vec v = dim_vec w \<and> (\<forall> i < dim_vec w. v $ i < w $ i))"

lemma less_vecD: assumes "v <\<^sub>v w" and "w \<in> carrier_vec n"
  shows "i < n \<Longrightarrow> v $ i < w $ i"
  using assms unfolding less_vec_def by auto

lemma less_vecI: assumes "v \<in> carrier_vec n" "w \<in> carrier_vec n"
  "\<And> i. i < n \<Longrightarrow> v $ i < w $ i"
shows "v <\<^sub>v w"
  using assms unfolding less_vec_def by auto

lemma less_vec_lesseq_vec: "v <\<^sub>v (w :: 'a :: preorder vec) \<Longrightarrow> v \<le> w"
  unfolding less_vec_def less_eq_vec_def
  by (auto simp: less_le_not_le)

lemma floor_of_int_eq[simp]: "x \<in> \<int> \<Longrightarrow> of_int \<lfloor>x\<rfloor> = x"
  by (metis Ints_cases of_int_floor_cancel)

locale gram_schmidt_floor = gram_schmidt n f_ty
  for n :: nat and f_ty :: "'a :: {floor_ceiling,
    trivial_conjugatable_linordered_field} itself"
begin

text \<open>We get rid of the max-1 operation, by showing that a smaller value of Bnd
  can only occur in very special cases where the theorem is trivially satisfied.\<close>

lemma small_mixed_integer_solution: fixes A\<^sub>1 :: "'a mat"
  assumes A1: "A\<^sub>1 \<in> carrier_mat nr\<^sub>1 n"
    and A2: "A\<^sub>2 \<in> carrier_mat nr\<^sub>2 n"
    and b1: "b\<^sub>1 \<in> carrier_vec nr\<^sub>1"
    and b2: "b\<^sub>2 \<in> carrier_vec nr\<^sub>2"
    and A1Bnd: "A\<^sub>1 \<in> \<int>\<^sub>m \<inter> Bounded_mat Bnd"
    and b1Bnd: "b\<^sub>1 \<in> \<int>\<^sub>v \<inter> Bounded_vec Bnd"
    and A2Bnd: "A\<^sub>2 \<in> \<int>\<^sub>m \<inter> Bounded_mat Bnd"
    and b2Bnd: "b\<^sub>2 \<in> \<int>\<^sub>v \<inter> Bounded_vec Bnd"
    and x: "x \<in> carrier_vec n"
    and xI: "x \<in> indexed_Ints_vec I"
    and sol_nonstrict: "A\<^sub>1 *\<^sub>v x \<le> b\<^sub>1"
    and sol_strict: "A\<^sub>2 *\<^sub>v x <\<^sub>v b\<^sub>2"
    and non_degenerate: "nr\<^sub>1 \<noteq> 0 \<or> nr\<^sub>2 \<noteq> 0 \<or> Bnd \<ge> 0"
  shows "\<exists> x.
  x \<in> carrier_vec n \<and>
  x \<in> indexed_Ints_vec I \<and>
  A\<^sub>1 *\<^sub>v x \<le> b\<^sub>1 \<and>
  A\<^sub>2 *\<^sub>v x <\<^sub>v b\<^sub>2 \<and>
  x \<in> Bounded_vec (fact (n+1) * Bnd^n)"
proof (cases "Bnd \<ge> 1")
  case True
  hence "max 1 Bnd = Bnd" by auto
  with small_mixed_integer_solution_main[OF assms(1-12)] True show ?thesis by auto
next
  case trivial: False
  show ?thesis
  proof (cases "n = 0")
    case True
    with x have "x \<in> Bounded_vec (fact (n+1) * Bnd^n)" unfolding Bounded_vec_def by auto
    with xI x sol_nonstrict sol_strict show ?thesis by blast
  next
    case n: False
    {
      fix A nr
      assume A: "A \<in> carrier_mat nr n" and Bnd: "A \<in> \<int>\<^sub>m \<inter> Bounded_mat Bnd"
      {
        fix i j
        assume "i < nr" "j < n"
        with Bnd A have *: "A $$ (i,j) \<in> \<int>" "abs (A $$ (i,j)) \<le> Bnd"
          unfolding Bounded_mat_def Ints_mat_def by auto
        with trivial have "Bnd \<ge> 0" "A $$ (i,j) = 0" by (auto simp: Ints_nonzero_abs_less1)
      } note main = this
      have A0: "A = 0\<^sub>m nr n"
        by (intro eq_matI, insert main A, auto)
      have "nr \<noteq> 0 \<Longrightarrow> Bnd \<ge> 0" using main[of 0 0] n by auto
      note A0 this
    } note main = this
    from main[OF A1 A1Bnd] have A1: "A\<^sub>1 = 0\<^sub>m nr\<^sub>1 n" and nr1: "nr\<^sub>1 \<noteq> 0 \<Longrightarrow> Bnd \<ge> 0"
      by auto
    from main[OF A2 A2Bnd] have A2: "A\<^sub>2 = 0\<^sub>m nr\<^sub>2 n" and nr2: "nr\<^sub>2 \<noteq> 0 \<Longrightarrow> Bnd \<ge> 0"
      by auto
    let ?x = "0\<^sub>v n"
    show ?thesis
    proof (intro exI[of _ ?x] conjI)
      show "A\<^sub>1 *\<^sub>v ?x \<le> b\<^sub>1" using sol_nonstrict x unfolding A1 by auto
      show "A\<^sub>2 *\<^sub>v ?x <\<^sub>v b\<^sub>2" using sol_strict x unfolding A2 by auto
      show "?x \<in> carrier_vec n" by auto
      show "?x \<in> indexed_Ints_vec I" unfolding indexed_Ints_vec_def by auto
      from nr1 nr2 non_degenerate have Bnd: "Bnd \<ge> 0" by auto
      hence "fact (n + 1) * Bnd ^ n \<ge> 0" by simp
      thus "?x \<in> Bounded_vec (fact (n + 1) * Bnd ^ n)" by (auto simp: Bounded_vec_def)
    qed
  qed
qed

corollary small_integer_solution_nonstrict: fixes A :: "'a mat"
  assumes A: "A \<in> carrier_mat nr n"
    and b: "b \<in> carrier_vec nr"
    and ABnd: "A \<in> \<int>\<^sub>m \<inter> Bounded_mat Bnd"
    and bBnd: "b \<in> \<int>\<^sub>v \<inter> Bounded_vec Bnd"
    and x: "x \<in> carrier_vec n"
    and xI: "x \<in> \<int>\<^sub>v"
    and sol: "A *\<^sub>v x \<le> b"
    and non_degenerate: "nr \<noteq> 0 \<or> Bnd \<ge> 0"
  shows "\<exists> y.
  y \<in> carrier_vec n \<and>
  y \<in> \<int>\<^sub>v \<and>
  A *\<^sub>v y \<le> b \<and>
  y \<in> Bounded_vec (fact (n+1) * Bnd^n)"
proof -
  let ?A2 = "0\<^sub>m 0 n :: 'a mat"
  let ?b2 = "0\<^sub>v 0 :: 'a vec"
  from non_degenerate have degen: "nr \<noteq> 0 \<or> (0 :: nat) \<noteq> 0 \<or> Bnd \<ge> 0" by auto
  have "\<exists>y. y \<in> carrier_vec n \<and> y \<in> \<int>\<^sub>v \<and> A *\<^sub>v y \<le> b \<and> ?A2 *\<^sub>v y <\<^sub>v ?b2
  \<and> y \<in> Bounded_vec (fact (n + 1) * Bnd ^ n)"
    by (rule small_mixed_integer_solution[OF A _ b _ ABnd bBnd _ _ x _ sol, of ?A2 0 ?b2 UNIV,
          folded indexed_Ints_vec_UNIV], insert xI degen,
        auto simp: Ints_vec_def Ints_mat_def Bounded_mat_def Bounded_vec_def less_vec_def)
  thus ?thesis by blast
qed

end
end