(* Author: Dmitriy Traytel *)

section \<open>Deciding Equivalence of M2L Formulas\<close>

(*<*)
theory M2L_Equivalence_Checking
imports
  Pi_Equivalence_Checking
  PNormalization
  Init_Normalization
  M2L_Normalization
  Pi_Regular_Exp_Dual
begin
(*>*)

global_interpretation embed "set o \<sigma> \<Sigma>" "wf_atom \<Sigma>" \<pi> lookup "\<epsilon> \<Sigma>"
  for \<Sigma> :: "'a :: linorder list"
  defines
      \<DD> = "embed.lderiv lookup (\<epsilon> \<Sigma>)"
  and Co\<DD> = "embed.lderiv_dual lookup (\<epsilon> \<Sigma>)"
  by unfold_locales (auto simp: \<sigma>_def \<pi>_def \<epsilon>_def set_n_lists)

lemma enum_not_empty[simp]: "Enum.enum \<noteq> []" (is "?enum \<noteq> []")
proof (rule notI)
  assume "?enum = []"
  hence "set ?enum = {}" by simp
  thus False unfolding UNIV_enum[symmetric] by simp
qed

global_interpretation \<Phi>: formula "Enum.enum :: 'a :: {enum, linorder} list"
  defines
      pre_wf_formula = \<Phi>.pre_wf_formula
  and wf_formula = \<Phi>.wf_formula
  and rexp_of = \<Phi>.rexp_of
  and rexp_of_alt = \<Phi>.rexp_of_alt
  and rexp_of_alt' = \<Phi>.rexp_of_alt'
  and rexp_of' = \<Phi>.rexp_of'
  and rexp_of'' = \<Phi>.rexp_of''
  and valid_ENC = \<Phi>.valid_ENC
  and ENC = \<Phi>.ENC
  and dec_interp = \<Phi>.dec_interp
  by unfold_locales (auto simp: \<sigma>_def \<pi>_def set_n_lists)

lemma lang_Plus_Zero: "lang \<Sigma> n (Plus r One) = lang \<Sigma> n (Plus s One) \<longleftrightarrow> lang \<Sigma> n r - {[]} = lang \<Sigma> n s - {[]}"
  by auto

lemmas lang\<^sub>M\<^sub>2\<^sub>L_rexp_of_norm = trans[OF sym[OF \<Phi>.lang\<^sub>M\<^sub>2\<^sub>L_norm] \<Phi>.lang\<^sub>M\<^sub>2\<^sub>L_rexp_of]
lemmas lang\<^sub>M\<^sub>2\<^sub>L_rexp_of'_norm = trans[OF sym[OF \<Phi>.lang\<^sub>M\<^sub>2\<^sub>L_norm] \<Phi>.lang\<^sub>M\<^sub>2\<^sub>L_rexp_of']
lemmas lang\<^sub>M\<^sub>2\<^sub>L_rexp_of''_norm = trans[OF sym[OF \<Phi>.lang\<^sub>M\<^sub>2\<^sub>L_norm] \<Phi>.lang\<^sub>M\<^sub>2\<^sub>L_rexp_of'']

setup \<open>Sign.map_naming (Name_Space.mandatory_path "slow")\<close>

global_interpretation D: rexp_DFA "\<sigma> \<Sigma>" "wf_atom \<Sigma>" \<pi> lookup "\<lambda>x. \<guillemotleft>pnorm (inorm x)\<guillemotright>"
  "\<lambda>a r. \<guillemotleft>\<DD> \<Sigma> a r\<guillemotright>" final "alphabet.wf (wf_atom \<Sigma>) n" pnorm "lang \<Sigma> n" n
  for \<Sigma> :: "'a :: linorder list" and n :: nat
  defines
      test = "rexp_DA.test (final :: 'a atom rexp \<Rightarrow> bool)"
  and step = "rexp_DA.step (\<sigma> \<Sigma>) (\<lambda>a r. \<guillemotleft>\<DD> \<Sigma> a r\<guillemotright>) pnorm n"
  and closure = "rexp_DA.closure (\<sigma> \<Sigma>) (\<lambda>a r. \<guillemotleft>\<DD> \<Sigma> a r\<guillemotright>) final pnorm n"
  and check_eqvRE = "rexp_DA.check_eqv (\<sigma> \<Sigma>) (\<lambda>x. \<guillemotleft>pnorm (inorm x)\<guillemotright>) (\<lambda>a r. \<guillemotleft>\<DD> \<Sigma> a r\<guillemotright>) final pnorm n"
  and test_invariant = "rexp_DA.test_invariant (final :: 'a atom rexp \<Rightarrow> bool) ::
    (('a \<times> bool list) list \<times> _) list \<times> _ \<Rightarrow> bool"
  and step_invariant = "rexp_DA.step_invariant (\<sigma> \<Sigma>) (\<lambda>a r. \<guillemotleft>\<DD> \<Sigma> a r\<guillemotright>) pnorm n"
  and closure_invariant = "rexp_DA.closure_invariant (\<sigma> \<Sigma>) (\<lambda>a r. \<guillemotleft>\<DD> \<Sigma> a r\<guillemotright>) final pnorm n"
  and counterexampleRE = "rexp_DA.counterexample (\<sigma> \<Sigma>) (\<lambda>x. \<guillemotleft>pnorm (inorm x)\<guillemotright>) (\<lambda>a r. \<guillemotleft>\<DD> \<Sigma> a r\<guillemotright>) final pnorm n"
  and reachable = "rexp_DA.reachable (\<sigma> \<Sigma>) (\<lambda>x. \<guillemotleft>pnorm (inorm x)\<guillemotright>) (\<lambda>a r. \<guillemotleft>\<DD> \<Sigma> a r\<guillemotright>) pnorm n"
  and automaton = "rexp_DA.automaton (\<sigma> \<Sigma>) (\<lambda>x. \<guillemotleft>pnorm (inorm x)\<guillemotright>) (\<lambda>a r. \<guillemotleft>\<DD> \<Sigma> a r\<guillemotright>) pnorm n"
  by unfold_locales (auto simp only: comp_apply
    ACI_norm_wf ACI_norm_lang wf_inorm lang_inorm wf_pnorm lang_pnorm wf_lderiv lang_lderiv
    lang_final finite_fold_lderiv dest!: lang_subset_lists)

definition check_eqv where
"check_eqv n \<phi> \<psi> \<longleftrightarrow> wf_formula n (FOr \<phi> \<psi>) \<and>
   slow.check_eqvRE Enum.enum n (Plus (rexp_of'' n (norm \<phi>)) One) (Plus (rexp_of'' n (norm \<psi>)) One)"

definition counterexample where
"counterexample n \<phi> \<psi> =
   map_option (\<lambda>w. dec_interp n (FOV (FOr \<phi> \<psi>)) w)
   (slow.counterexampleRE Enum.enum n (Plus (rexp_of'' n (norm \<phi>)) One) (Plus (rexp_of'' n (norm \<psi>)) One))"

lemma completeness:
  assumes "\<Phi>.lang\<^sub>M\<^sub>2\<^sub>L n \<phi> = \<Phi>.lang\<^sub>M\<^sub>2\<^sub>L n \<psi>" "wf_formula n (FOr \<phi> \<psi>)"
  shows "slow.check_eqv n \<phi> \<psi>"
  using assms(2) unfolding slow.check_eqv_def
  by (intro conjI[OF assms(2) slow.D.check_eqv_complete[OF iffD2[OF lang_Plus_Zero]],
                OF box_equals[OF assms(1) lang\<^sub>M\<^sub>2\<^sub>L_rexp_of''_norm lang\<^sub>M\<^sub>2\<^sub>L_rexp_of''_norm]])
   (auto intro!: \<Phi>.wf_rexp_of'')

setup \<open>Sign.map_naming Name_Space.parent_path\<close>

setup \<open>Sign.map_naming (Name_Space.mandatory_path "fast")\<close>

global_interpretation D: rexp_DA_no_post "\<sigma> \<Sigma>" "wf_atom \<Sigma>" \<pi> lookup "\<lambda>x. pnorm (inorm x)"
  "\<lambda>a r. pnorm (\<DD> \<Sigma> a r)" final "alphabet.wf (wf_atom \<Sigma>) n" "lang \<Sigma> n" n
  for \<Sigma> :: "'a :: linorder list" and n :: nat
  defines
      test = "rexp_DA.test (final :: 'a atom rexp \<Rightarrow> bool)"
  and step = "rexp_DA.step (\<sigma> \<Sigma>) (\<lambda>a r. pnorm (\<DD> \<Sigma> a r)) id n"
  and closure = "rexp_DA.closure (\<sigma> \<Sigma>) (\<lambda>a r. pnorm (\<DD> \<Sigma> a r)) final id n"
  and check_eqvRE = "rexp_DA.check_eqv (\<sigma> \<Sigma>) (\<lambda>x. pnorm (inorm x)) (\<lambda>a r. pnorm (\<DD> \<Sigma> a r)) final id n"
  and test_invariant = "rexp_DA.test_invariant (final :: 'a atom rexp \<Rightarrow> bool) ::
    (('a \<times> bool list) list \<times> _) list \<times> _ \<Rightarrow> bool"
  and step_invariant = "rexp_DA.step_invariant (\<sigma> \<Sigma>) (\<lambda>a r. pnorm (\<DD> \<Sigma> a r)) id n"
  and closure_invariant = "rexp_DA.closure_invariant (\<sigma> \<Sigma>) (\<lambda>a r. pnorm (\<DD> \<Sigma> a r)) final id n"
  and counterexampleRE = "rexp_DA.counterexample (\<sigma> \<Sigma>) (\<lambda>x. pnorm (inorm x)) (\<lambda>a r. pnorm (\<DD> \<Sigma> a r)) final id n"
  and reachable = "rexp_DA.reachable (\<sigma> \<Sigma>) (\<lambda>x. pnorm (inorm x)) (\<lambda>a r. pnorm (\<DD> \<Sigma> a r)) id n"
  and automaton = "rexp_DA.automaton (\<sigma> \<Sigma>) (\<lambda>x. pnorm (inorm x)) (\<lambda>a r. pnorm (\<DD> \<Sigma> a r)) id n"
  by unfold_locales (auto simp only: comp_apply
    ACI_norm_wf ACI_norm_lang wf_inorm lang_inorm wf_pnorm lang_pnorm wf_lderiv lang_lderiv id_apply
    lang_final dest!: lang_subset_lists)

definition check_eqv where
"check_eqv n \<phi> \<psi> \<longleftrightarrow> wf_formula n (FOr \<phi> \<psi>) \<and>
   fast.check_eqvRE Enum.enum n (Plus (rexp_of'' n (norm \<phi>)) One) (Plus (rexp_of'' n (norm \<psi>)) One)"

definition counterexample where
"counterexample n \<phi> \<psi> =
   map_option (\<lambda>w. dec_interp n (FOV (FOr \<phi> \<psi>)) w)
   (fast.counterexampleRE Enum.enum n (Plus (rexp_of'' n (norm \<phi>)) One) (Plus (rexp_of'' n (norm \<psi>)) One))"

lemma soundness: "fast.check_eqv n \<phi> \<psi> \<Longrightarrow> \<Phi>.lang\<^sub>M\<^sub>2\<^sub>L n \<phi> = \<Phi>.lang\<^sub>M\<^sub>2\<^sub>L n \<psi>"
  by (rule box_equals[OF iffD1[OF lang_Plus_Zero, OF fast.D.check_eqv_sound]
  sym[OF trans[OF lang\<^sub>M\<^sub>2\<^sub>L_rexp_of''_norm]] sym[OF trans[OF lang\<^sub>M\<^sub>2\<^sub>L_rexp_of''_norm]]])
   (auto simp: fast.check_eqv_def intro!: \<Phi>.wf_rexp_of'')

setup \<open>Sign.map_naming Name_Space.parent_path\<close>

setup \<open>Sign.map_naming (Name_Space.mandatory_path "dual")\<close>

global_interpretation D: rexp_DA_no_post "\<sigma> \<Sigma>" "wf_atom \<Sigma>" \<pi> lookup
  "\<lambda>x. pnorm_dual (rexp_dual_of (inorm x))" "\<lambda>a r. pnorm_dual (Co\<DD> \<Sigma> a r)" final_dual
  "alphabet.wf_dual (wf_atom \<Sigma>) n" "lang_dual \<Sigma> n" n
  for \<Sigma> :: "'a :: linorder list" and n :: nat
  defines
      test = "rexp_DA.test (final_dual :: 'a atom rexp_dual \<Rightarrow> bool)"
  and step = "rexp_DA.step (\<sigma> \<Sigma>) (\<lambda>a r. pnorm_dual (Co\<DD> \<Sigma> a r)) id n"
  and closure = "rexp_DA.closure (\<sigma> \<Sigma>) (\<lambda>a r. pnorm_dual (Co\<DD> \<Sigma> a r)) final_dual id n"
  and check_eqvRE = "rexp_DA.check_eqv (\<sigma> \<Sigma>) (\<lambda>x. pnorm_dual (rexp_dual_of (inorm x))) (\<lambda>a r. pnorm_dual (Co\<DD> \<Sigma> a r)) final_dual id n"
  and test_invariant = "rexp_DA.test_invariant (final_dual :: 'a atom rexp_dual \<Rightarrow> bool) ::
    (('a \<times> bool list) list \<times> _) list \<times> _ \<Rightarrow> bool"
  and step_invariant = "rexp_DA.step_invariant (\<sigma> \<Sigma>) (\<lambda>a r. pnorm_dual (Co\<DD> \<Sigma> a r)) id n"
  and closure_invariant = "rexp_DA.closure_invariant (\<sigma> \<Sigma>) (\<lambda>a r. pnorm_dual (Co\<DD> \<Sigma> a r)) final_dual id n"
  and counterexampleRE = "rexp_DA.counterexample (\<sigma> \<Sigma>) (\<lambda>x. pnorm_dual (rexp_dual_of (inorm x))) (\<lambda>a r. pnorm_dual (Co\<DD> \<Sigma> a r)) final_dual id n"
  and reachable = "rexp_DA.reachable (\<sigma> \<Sigma>) (\<lambda>x. pnorm_dual (rexp_dual_of (inorm x))) (\<lambda>a r. pnorm_dual (Co\<DD> \<Sigma> a r)) id n"
  and automaton = "rexp_DA.automaton (\<sigma> \<Sigma>) (\<lambda>x. pnorm_dual (rexp_dual_of (inorm x))) (\<lambda>a r. pnorm_dual (Co\<DD> \<Sigma> a r)) id n"
  by unfold_locales (auto simp only: comp_apply id_apply
    wf_inorm lang_inorm
    wf_dual_pnorm_dual lang_dual_pnorm_dual
    wf_dual_rexp_dual_of lang_dual_rexp_dual_of
    wf_dual_lderiv_dual lang_dual_lderiv_dual
    lang_dual_final_dual dest!: lang_dual_subset_lists)

definition check_eqv where
"check_eqv n \<phi> \<psi> \<longleftrightarrow> wf_formula n (FOr \<phi> \<psi>) \<and>
   dual.check_eqvRE Enum.enum n (Plus (rexp_of'' n (norm \<phi>)) One) (Plus (rexp_of'' n (norm \<psi>)) One)"

definition counterexample where
"counterexample n \<phi> \<psi> =
   map_option (\<lambda>w. dec_interp n (FOV (FOr \<phi> \<psi>)) w)
   (dual.counterexampleRE Enum.enum n (Plus (rexp_of'' n (norm \<phi>)) One) (Plus (rexp_of'' n (norm \<psi>)) One))"

lemma soundness: "dual.check_eqv n \<phi> \<psi> \<Longrightarrow> \<Phi>.lang\<^sub>M\<^sub>2\<^sub>L n \<phi> = \<Phi>.lang\<^sub>M\<^sub>2\<^sub>L n \<psi>"
  by (rule box_equals[OF iffD1[OF lang_Plus_Zero, OF dual.D.check_eqv_sound]
  sym[OF trans[OF lang\<^sub>M\<^sub>2\<^sub>L_rexp_of''_norm]] sym[OF trans[OF lang\<^sub>M\<^sub>2\<^sub>L_rexp_of''_norm]]])
   (auto simp: dual.check_eqv_def intro!: \<Phi>.wf_rexp_of'')

setup \<open>Sign.map_naming Name_Space.parent_path\<close>

(*<*)
end
(*>*)


(*  Title:       A Definitional Encoding of TLA in Isabelle/HOL
    Authors:     Gudmund Grov <ggrov at inf.ed.ac.uk>
                 Stephan Merz <Stephan.Merz at loria.fr>
    Year:        2011
    Maintainer:  Gudmund Grov <ggrov at inf.ed.ac.uk>
*)

section \<open>Representing state in TLA*\<close>

theory State
imports Liveness
begin

text\<open>
  We adopt the hidden state appraoch, as used in the existing
  Isabelle/HOL TLA embedding \cite{Merz98}. This approach is also used
  in \cite{Ehmety01}.
  Here, a state space is defined by its projections, and everything else is
  unknown. Thus, a variable is a projection of the state space, and has the same
  type as a state function. Moreover, strong typing is achieved, since the projection
  function may have any result type. To achieve this, the state space is represented
  by an undefined type, which is an instance of the \<open>world\<close> class to enable
  use with the \<open>Intensional\<close> theory.
\<close>

typedecl state

instance state :: world ..

type_synonym 'a statefun = "(state,'a) stfun"
type_synonym statepred  = "bool statefun"
type_synonym 'a tempfun = "(state,'a) formfun"
type_synonym temporal = "state formula"

text \<open>
  Formalizing type state would require formulas to be tagged with
  their underlying state space and would result in a system that is
  much harder to use. (Unlike Hoare logic or Unity, TLA has quantification
  over state variables, and therefore one usually works with different
  state spaces within a single specification.) Instead, state is just
  an anonymous type whose only purpose is to provide Skolem constants.
  Moreover, we do not define a type of state variables separate from that
  of arbitrary state functions, again in order to simplify the definition
  of flexible quantification later on. Nevertheless, we need to distinguish
  state variables, mainly to define the enabledness of actions. The user
  identifies (tuples of) ``base'' state variables in a specification via the
  ``meta predicate'' \<open>basevars\<close>, which is defined here.
\<close>

definition stvars    :: "'a statefun \<Rightarrow> bool"
where basevars_def:  "stvars \<equiv> surj"

syntax
  "PRED"    :: "lift \<Rightarrow> 'a"                          ("PRED _")
  "_stvars" :: "lift \<Rightarrow> bool"                        ("basevars _")

translations
  "PRED P"   \<rightharpoonup>  "(P::state => _)"
  "_stvars"  \<rightleftharpoons>  "CONST stvars"

text \<open>
  Base variables may be assigned arbitrary (type-correct) values.
  In the following lemma, note that \<open>vs\<close> may be a tuple of variables.
  The correct identification of base variables is up to the user who must
  take care not to introduce an inconsistency. For example, @{term "basevars (x,x)"}
  would definitely be inconsistent.
\<close>

lemma basevars: "basevars vs \<Longrightarrow> \<exists>u. vs u = c"
proof (unfold basevars_def surj_def)
  assume "\<forall>y. \<exists>x. y = vs x"
  then obtain x where "c = vs x" by blast
  thus "\<exists>u. vs u = c" by blast
qed

lemma baseE:
  assumes H1: "basevars v" and H2:"\<And>x. v x = c \<Longrightarrow> Q"
  shows "Q"
  using H1[THEN basevars] H2 by auto

text \<open>A variant written for sequences rather than single states.\<close>
lemma first_baseE:
  assumes H1: "basevars v" and H2: "\<And>x. v (first x) = c \<Longrightarrow> Q"
  shows "Q"
  using H1[THEN basevars] H2 by (force simp: first_def)

lemma base_pair1:
  assumes h: "basevars (x,y)"
  shows "basevars x"
proof (auto simp: basevars_def)
  fix c
  from h[THEN basevars] obtain s where "(LIFT (x,y)) s = (c, arbitrary)" by auto
  thus "c \<in> range x" by auto
qed

lemma base_pair2:
  assumes h: "basevars (x,y)"
  shows "basevars y"
proof (auto simp: basevars_def)
  fix d
  from h[THEN basevars] obtain s where "(LIFT (x,y)) s = (arbitrary, d)" by auto
  thus "d \<in> range y" by auto
qed

lemma base_pair: "basevars (x,y) \<Longrightarrow> basevars x \<and> basevars y"
  by (auto elim: base_pair1 base_pair2)

text \<open>
  Since the @{typ unit} type has just one value, any state function of unit type
  satisfies the predicate \<open>basevars\<close>. The following theorem can sometimes
  be useful because it gives a trivial solution for \<open>basevars\<close> premises.
\<close>

lemma unit_base: "basevars (v::state \<Rightarrow> unit)"
  by (auto simp: basevars_def)

text \<open>
  A pair of the form \<open>(x,x)\<close> will generally not satisfy the predicate
  \<open>basevars\<close> -- except for pathological cases such as \<open>x::unit\<close>.
\<close>
lemma
  fixes x :: "state \<Rightarrow> bool"
  assumes h1: "basevars (x,x)"
  shows "False"
proof -
  from h1 have "\<exists>u. (LIFT (x,x)) u = (False,True)" by (rule basevars)
  thus False by auto
qed

lemma
  fixes x :: "state \<Rightarrow> nat"
  assumes h1: "basevars (x,x)"
  shows "False"
proof -
  from h1 have "\<exists>u. (LIFT (x,x)) u = (0,1)" by (rule basevars)
  thus False by auto
qed

text \<open>
  The following theorem reduces the reasoning about the existence of a
  state sequence satisfiyng an enabledness predicate to finding a suitable
  value \<open>c\<close> at the successor state for the base variables of the
  specification. This rule is intended for reasoning about standard TLA
  specifications, where \<open>Enabled\<close> is applied to actions, not arbitrary
  pre-formulas.
\<close>
lemma base_enabled:
  assumes h1: "basevars vs"
  and h2: "\<And>u. vs (first u) = c \<Longrightarrow> ((first s) ## u) \<Turnstile> F"
  shows "s \<Turnstile> Enabled F"
using h1 proof (rule first_baseE)
  fix t
  assume "vs (first t) = c"
  hence "((first s) ## t) \<Turnstile> F" by (rule h2)
  thus "s \<Turnstile> Enabled F" unfolding enabled_def by blast
qed

subsection "Temporal Quantifiers"

text\<open>
  In \cite{Lamport94}, Lamport gives a stuttering invariant definition
  of quantification over (flexible) variables. It relies on similarity
  of two sequences (as supported in our @{theory TLA.Sequence} theory), and
  equivalence of two sequences up to a variable (the bound variable).
  However, sequence equaivalence up to a variable, requires state
  equaivalence up to a variable. Our state representation above does not
  support this, hence we cannot encode Lamport's definition in our theory.
  Thus, we need to axiomatise quantification over (flexible) variables.
  Note that with a state representation supporting this, our theory should
  allow such an encoding.
\<close>

consts
  EEx        :: "('a statefun \<Rightarrow> temporal) \<Rightarrow> temporal"       (binder "Eex " 10)
  AAll       :: "('a statefun \<Rightarrow> temporal) \<Rightarrow> temporal"       (binder "Aall " 10)

syntax
  "_EEx"     :: "[idts, lift] => lift"                ("(3\<exists>\<exists> _./ _)" [0,10] 10)
  "_AAll"    :: "[idts, lift] => lift"                ("(3\<forall>\<forall> _./ _)" [0,10] 10)
translations
  "_EEx v A"  ==   "Eex v. A"
  "_AAll v A" ==   "Aall v. A"

axiomatization where
     eexI: "\<turnstile> F x \<longrightarrow> (\<exists>\<exists> x. F x)"
and  eexE: "\<lbrakk>s \<Turnstile> (\<exists>\<exists> x. F x) ; basevars vs; (!! x. \<lbrakk> basevars (x,vs); s \<Turnstile> F x \<rbrakk> \<Longrightarrow> s \<Turnstile> G)\<rbrakk>
            \<Longrightarrow> (s \<Turnstile> G)"
and  all_def: "\<turnstile> (\<forall>\<forall> x. F x) = (\<not>(\<exists>\<exists> x. \<not>(F x)))"
and  eexSTUT: "STUTINV F x \<Longrightarrow> STUTINV (\<exists>\<exists> x. F x)"
and  history: "\<turnstile> (I \<and> \<box>[A]_v) = (\<exists>\<exists> h. ($h = ha) \<and> I \<and> \<box>[A \<and> h$=hb]_(h,v))"

lemmas eexI_unl = eexI[unlift_rule] \<comment> \<open>@{text "w \<Turnstile> F x \<Longrightarrow> w \<Turnstile> (\<exists>\<exists> x. F x)"}\<close>

text \<open>
  \<open>tla_defs\<close> can be used to unfold TLA definitions into lowest predicate level.
  This is particularly useful for reasoning about enabledness of formulas.
\<close>
lemmas tla_defs = unch_def before_def after_def first_def second_def suffix_def
                  tail_def nexts_def app_def angle_actrans_def actrans_def

end


(*
 * Copyright 2015, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory ProvePart
imports Main
begin

text \<open>Introduces a (sort-of) tactic for proving part of a goal by automatic
methods. The split between the proven and unproven part goes down into conjunction,
implication etc. The unproven parts are left in (roughly) their original form.\<close>

text \<open>
The first part is to take a goal and split it into two conjuncts,
e.g. "a \<and> (\<forall>x. b \<and> c x)
    = (((P1 \<longrightarrow> a) \<and> (\<forall>x. (P2 \<longrightarrow> b) \<and> (P3 \<longrightarrow> c x)))
        \<and> ((\<not> P1 \<longrightarrow> a) \<and> (\<forall>x. (\<not> P2 \<longrightarrow> b) \<and> (\<not> P3 \<longrightarrow> c x)))"

The first conjunct is then attacked by some automatic method.

The final part is to eliminate any goals remaining after that
automatic method by setting the Pi to False. The remaining Pi
(whose goal fragments were solved) are set to True. If the
resulting goals cannot be solved by setting to False, or if
no Pi are actually set to true, the process fails.
\<close>

lemma logic_to_conj_thm_workers:
  "A = (A' \<and> A'') \<Longrightarrow> B = (B' \<and> B'')
    \<Longrightarrow> (A \<and> B) = ((A' \<and> B') \<and> (A'' \<and> B''))"
  "B = (B' \<and> B'')
    \<Longrightarrow> (A \<or> B) = ((A \<or> B') \<and> (A \<or> B''))"
  "\<lbrakk> \<And>x. P x = (P' x \<and> P'' x) \<rbrakk>
    \<Longrightarrow> (\<forall>x. P x) = ((\<forall>x. P' x) \<and> (\<forall>x. P'' x))"
  "\<lbrakk> \<And>x. P x = (P' x \<and> P'' x) \<rbrakk>
    \<Longrightarrow> (\<forall>x \<in> S. P x) = ((\<forall>x \<in> S. P' x) \<and> (\<forall>x \<in> S. P'' x))"
  "B = (B' \<and> B'')
    \<Longrightarrow> (A \<longrightarrow> B) = ((A \<longrightarrow> B') \<and> (A \<longrightarrow> B''))"
  by auto

ML \<open>
structure Split_To_Conj = struct

fun abs_name (Abs (s, _, _)) = s
  | abs_name _ = "x"

fun all_type (Const (@{const_name "All"}, T) $ _)
    = domain_type (domain_type T)
  | all_type (Const (@{const_name "Ball"}, T) $ _ $ _)
    = domain_type (domain_type (range_type T))
  | all_type t = raise TERM ("all_type", [t])

fun split_thm prefix ctxt t = let
    val ok = not (String.isPrefix "Q" prefix orelse String.isPrefix "R" prefix)
    val _ = ok orelse error ("split_thm: prefix has prefix Q/R: " ^ prefix)
    fun params (@{term "(\<and>)"} $ x $ y) Ts = params x Ts @ params y Ts
      | params (@{term "(\<or>)"} $ _ $ y) Ts = (Ts, SOME @{typ bool}) :: params y Ts
      | params (all as (Const (@{const_name "All"}, _) $ t)) Ts
        = params (betapply (t, Bound 0)) (all_type all :: Ts)
      | params (ball as (Const (@{const_name "Ball"}, T) $ _ $ t)) Ts
        = (Ts, SOME (domain_type T)) :: params (betapply (t, Bound 0)) (all_type ball :: Ts)
      | params (@{term "(\<longrightarrow>)"} $ _ $ t) Ts = (Ts, SOME @{typ bool}) :: params t Ts
      | params _ Ts = [(Ts, NONE)]
    val ps = params t []
    val Ps = Variable.variant_frees ctxt [t]
        (replicate (length ps) (prefix, @{typ bool}))
        |> map Free
    val Qs = Variable.variant_frees ctxt [t]
        (map (fn (ps, T) => case T of NONE => ("Q", ps ---> @{typ bool})
                | SOME T => ("R", ps ---> T)) ps)
        |> map Free
    val Qs = map (fn (Q, (ps, _)) => Term.list_comb (Q, map Bound (0 upto (length ps - 1))))
        (Qs ~~ ps)
    fun assemble_bits (@{term "(\<and>)"} $ x $ y) Ps = let
        val (x, Ps) = assemble_bits x Ps
        val (y, Ps) = assemble_bits y Ps
      in (@{term "(\<and>)"} $ x $ y, Ps) end
      | assemble_bits (@{term "(\<or>)"} $ _ $ y) Ps = let
        val x = hd Ps
        val (y, Ps) = assemble_bits y (tl Ps)
      in (@{term "(\<or>)"} $ x $ y, Ps) end
      | assemble_bits (all as (Const (@{const_name "All"}, T) $ t)) Ps = let
        val nm = abs_name t
        val (t, Ps) = assemble_bits (betapply (t, Bound 0)) Ps
      in (Const (@{const_name "All"}, T) $ Abs (nm, all_type all, t), Ps) end
      | assemble_bits (ball as (Const (@{const_name "Ball"}, T) $ _ $ t)) Ps = let
        val nm = abs_name t
        val S = hd Ps
        val (t, Ps) = assemble_bits (betapply (t, Bound 0)) (tl Ps)
      in (Const (@{const_name "Ball"}, T) $ S $ Abs (nm, all_type ball, t), Ps) end
      | assemble_bits (@{term "(\<longrightarrow>)"} $ _ $ y) Ps = let
        val x = hd Ps
        val (y, Ps) = assemble_bits y (tl Ps)
      in (@{term "(\<longrightarrow>)"} $ x $ y, Ps) end
      | assemble_bits _ Ps = (hd Ps, tl Ps)
    val bits_lhs = assemble_bits t Qs |> fst
    fun imp tf (P, Q) = if String.isPrefix "R" (fst (dest_Free (head_of Q))) then Q
        else HOLogic.mk_imp (if tf then P else HOLogic.mk_not P, Q)
    val bits_true = assemble_bits t (map (imp true) (Ps ~~ Qs)) |> fst
    val bits_false = assemble_bits t (map (imp false) (Ps ~~ Qs)) |> fst
    val concl = HOLogic.mk_eq (bits_lhs, HOLogic.mk_conj (bits_true, bits_false))
      |> HOLogic.mk_Trueprop
  in (Goal.prove ctxt (map (fst o dest_Free o head_of) Qs) [] concl
    (K (REPEAT_ALL_NEW (resolve_tac ctxt
        @{thms logic_to_conj_thm_workers cases_simp[symmetric]}) 1)),
        map dest_Free Ps)
  end

fun get_split_tac prefix ctxt tac = SUBGOAL (fn (t, i) =>
  let
    val concl = HOLogic.dest_Trueprop (Logic.strip_assums_concl t)
    val (thm, Ps) = split_thm prefix ctxt concl
  in (resolve0_tac [ @{thm iffD2} ] THEN' resolve0_tac [thm] THEN' tac Ps) end i)

end
\<close>

text \<open>Testing.\<close>

ML \<open>
Split_To_Conj.split_thm "P" @{context}
  @{term "x & y & (\<forall>t \<in> UNIV. \<forall>n. True \<longrightarrow> z t n)"}
\<close>

ML \<open>
structure Partial_Prove = struct

fun inst_frees_tac _ Ps ct = REPEAT_DETERM o SUBGOAL (fn (t, _) =>
  fn thm => case Term.add_frees t [] |> filter (member (=) Ps)
  of [] => Seq.empty
  | (f :: _) => let
    val idx = Thm.maxidx_of thm + 1
    val var = ((fst f, idx), snd f)
  in thm |> Thm.generalize ([], [fst f]) idx
    |> Thm.instantiate ([], [(var, ct)])
    |> Seq.single
  end)

fun cleanup_tac ctxt Ps
    = inst_frees_tac ctxt Ps @{cterm False}
      THEN' asm_full_simp_tac ctxt

fun finish_tac ctxt Ps = inst_frees_tac ctxt Ps @{cterm True}
    THEN' CONVERSION (Conv.params_conv ~1 (fn ctxt =>
            (Conv.concl_conv ~1 (Simplifier.rewrite (put_simpset HOL_ss ctxt)))
        ) ctxt)

fun test_start_partial_prove ctxt i t = let
    val j = Thm.nprems_of t - i
  in Split_To_Conj.get_split_tac ("P_" ^ string_of_int j ^ "_") ctxt
        (K (K all_tac)) i t
  end

fun test_end_partial_prove ctxt t = let
    fun match_P (s, T) = case space_explode "_" s of
        ["P", n, _] => try (fn () => ((s, T), the (Int.fromString n))) ()
      | _ => NONE
    val Ps = Term.add_frees (Thm.concl_of t) [] |> map_filter match_P
    fun getmax ((x, n) :: xs) max maxes = if n > max then getmax xs n [x]
      else getmax xs max maxes
      | getmax [] max maxes = (max, maxes)
    val (j, Ps) = getmax Ps 0 []
    val i = Thm.nprems_of t - j
  in REPEAT_DETERM (FIRSTGOAL (fn k => if k < i then cleanup_tac ctxt Ps k else no_tac))
    THEN finish_tac ctxt Ps i end t

fun partial_prove tactic ctxt i
    = Split_To_Conj.get_split_tac ("P_" ^ string_of_int i ^ "_") ctxt
      (fn Ps => fn i => tactic i THEN finish_tac ctxt Ps i) i

fun method (ctxtg, []) = (fn ctxt => Method.SIMPLE_METHOD (test_start_partial_prove ctxt 1),
    (ctxtg, []))
  | method args = error "Partial_Prove: still working on that"

fun fin_method () = Scan.succeed (fn ctxt => Method.SIMPLE_METHOD (test_end_partial_prove ctxt))

end
\<close>

method_setup partial_prove = \<open>Partial_Prove.method\<close>
  "partially prove a compound goal by some automatic method"

method_setup finish_partial_prove = \<open>Partial_Prove.fin_method ()\<close>
  "partially prove a compound goal by some automatic method"

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Basic Order Properties\<close>
theory Transport_Functions_Order_Base
  imports
    Transport_Functions_Base
begin

paragraph \<open>Dependent Function Relator\<close>

context hom_Dep_Fun_Rel_orders
begin

lemma reflexive_on_in_domI:
  assumes refl_L: "reflexive_on (in_codom (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>)"
  and R_le_R_if_L: "\<And>x1 x2. x1 \<le>\<^bsub>L\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>R x2 x2\<^esub>) \<le> (\<le>\<^bsub>R x1 x2\<^esub>)"
  and pequiv_R: "\<And>x1 x2. x1 \<le>\<^bsub>L\<^esub> x2 \<Longrightarrow> partial_equivalence_rel (\<le>\<^bsub>R x1 x2\<^esub>)"
  shows "reflexive_on (in_dom DFR) DFR"
proof (intro reflexive_onI Dep_Fun_Rel_relI)
  fix f x1 x2
  assume "in_dom DFR f"
  then obtain g where "DFR f g" by auto
  moreover assume "x1 \<le>\<^bsub>L\<^esub> x2"
  moreover with refl_L have "x2 \<le>\<^bsub>L\<^esub> x2" by blast
  ultimately have "f x1 \<le>\<^bsub>R x1 x2\<^esub> g x2" "f x2 \<le>\<^bsub>R x1 x2\<^esub> g x2"
    using R_le_R_if_L by auto
  moreover with pequiv_R \<open>x1 \<le>\<^bsub>L\<^esub> x2\<close>  have "g x2 \<le>\<^bsub>R x1 x2\<^esub> f x2"
    by (blast dest: symmetricD)
  ultimately show "f x1 \<le>\<^bsub>R x1 x2\<^esub> f x2" using pequiv_R \<open>x1 \<le>\<^bsub>L\<^esub> x2\<close> by blast
qed

lemma reflexive_on_in_codomI:
  assumes refl_L: "reflexive_on (in_dom (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>)"
  and R_le_R_if_L: "\<And>x1 x2. x1 \<le>\<^bsub>L\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>R x1 x1\<^esub>) \<le> (\<le>\<^bsub>R x1 x2\<^esub>)"
  and pequiv_R: "\<And>x1 x2. x1 \<le>\<^bsub>L\<^esub> x2 \<Longrightarrow> partial_equivalence_rel (\<le>\<^bsub>R x1 x2\<^esub>)"
  shows "reflexive_on (in_codom DFR) DFR"
proof (intro reflexive_onI Dep_Fun_Rel_relI)
  fix f x1 x2
  assume "in_codom DFR f"
  then obtain g where "DFR g f" by auto
  moreover assume "x1 \<le>\<^bsub>L\<^esub> x2"
  moreover with refl_L have "x1 \<le>\<^bsub>L\<^esub> x1" by blast
  ultimately have "g x1 \<le>\<^bsub>R x1 x2\<^esub> f x2" "g x1 \<le>\<^bsub>R x1 x2\<^esub> f x1"
    using R_le_R_if_L by auto
  moreover with pequiv_R \<open>x1 \<le>\<^bsub>L\<^esub> x2\<close>  have "f x1 \<le>\<^bsub>R x1 x2\<^esub> g x1"
    by (blast dest: symmetricD)
  ultimately show "f x1 \<le>\<^bsub>R x1 x2\<^esub> f x2" using pequiv_R \<open>x1 \<le>\<^bsub>L\<^esub> x2\<close> by blast
qed

corollary reflexive_on_in_fieldI:
  assumes "reflexive_on (in_field (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>R x2 x2\<^esub>) \<le> (\<le>\<^bsub>R x1 x2\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>R x1 x1\<^esub>) \<le> (\<le>\<^bsub>R x1 x2\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L\<^esub> x2 \<Longrightarrow> partial_equivalence_rel (\<le>\<^bsub>R x1 x2\<^esub>)"
  shows "reflexive_on (in_field DFR) DFR"
proof -
  from assms have "reflexive_on (in_dom DFR) DFR"
    by (intro reflexive_on_in_domI)
    (auto intro: reflexive_on_if_le_pred_if_reflexive_on in_field_if_in_codom)
  moreover from assms have "reflexive_on (in_codom DFR) DFR"
    by (intro reflexive_on_in_codomI)
    (auto intro: reflexive_on_if_le_pred_if_reflexive_on in_field_if_in_dom)
  ultimately show ?thesis by (auto iff: in_field_iff_in_dom_or_in_codom)
qed

lemma transitiveI:
  assumes refl_L: "reflexive_on (in_dom (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>)"
  and R_le_R_if_L: "\<And>x1 x2. x1 \<le>\<^bsub>L\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>R x1 x1\<^esub>) \<le> (\<le>\<^bsub>R x1 x2\<^esub>)"
  and trans: "\<And>x1 x2. x1 \<le>\<^bsub>L\<^esub> x2 \<Longrightarrow> transitive (\<le>\<^bsub>R x1 x2\<^esub>)"
  shows "transitive DFR"
proof (intro transitiveI Dep_Fun_Rel_relI)
  fix f1 f2 f3 x1 x2 assume "x1 \<le>\<^bsub>L\<^esub> x2"
  with refl_L have "x1 \<le>\<^bsub>L\<^esub> x1" by blast
  moreover assume "DFR f1 f2"
  ultimately have "f1 x1 \<le>\<^bsub>R x1 x1\<^esub> f2 x1" by blast
  with R_le_R_if_L have "f1 x1 \<le>\<^bsub>R x1 x2\<^esub> f2 x1" using \<open>x1 \<le>\<^bsub>L\<^esub> x2\<close> by blast
  assume "DFR f2 f3"
  with \<open>x1 \<le>\<^bsub>L\<^esub> x2\<close> have "f2 x1 \<le>\<^bsub>R x1 x2\<^esub> f3 x2" by blast
  with \<open>f1 x1 \<le>\<^bsub>R x1 x2\<^esub> f2 x1\<close> show "f1 x1 \<le>\<^bsub>R x1 x2\<^esub>  f3 x2"
    using trans \<open>x1 \<le>\<^bsub>L\<^esub> x2\<close> by blast
qed

lemma transitiveI':
  assumes refl_L: "reflexive_on (in_codom (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>)"
  and R_le_R_if_L: "\<And>x1 x2. x1 \<le>\<^bsub>L\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>R x2 x2\<^esub>) \<le> (\<le>\<^bsub>R x1 x2\<^esub>)"
  and trans: "\<And>x1 x2. x1 \<le>\<^bsub>L\<^esub> x2 \<Longrightarrow> transitive (\<le>\<^bsub>R x1 x2\<^esub>)"
  shows "transitive DFR"
proof (intro Binary_Relations_Transitive.transitiveI Dep_Fun_Rel_relI)
  fix f1 f2 f3 x1 x2 assume "DFR f1 f2" "x1 \<le>\<^bsub>L\<^esub> x2"
  then have "f1 x1 \<le>\<^bsub>R x1 x2\<^esub> f2 x2" by blast
  from \<open>x1 \<le>\<^bsub>L\<^esub> x2\<close> refl_L have "x2 \<le>\<^bsub>L\<^esub> x2" by blast
  moreover assume "DFR f2 f3"
  ultimately have "f2 x2 \<le>\<^bsub>R x2 x2\<^esub> f3 x2" by blast
  with R_le_R_if_L have "f2 x2 \<le>\<^bsub>R x1 x2\<^esub> f3 x2" using \<open>x1 \<le>\<^bsub>L\<^esub> x2\<close> by blast
  with \<open>f1 x1 \<le>\<^bsub>R x1 x2\<^esub> f2 x2\<close> show "f1 x1 \<le>\<^bsub>R x1 x2\<^esub> f3 x2"
    using trans \<open>x1 \<le>\<^bsub>L\<^esub> x2\<close> by blast
qed

lemma preorder_on_in_fieldI:
  assumes "reflexive_on (in_field (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>R x2 x2\<^esub>) \<le> (\<le>\<^bsub>R x1 x2\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>R x1 x1\<^esub>) \<le> (\<le>\<^bsub>R x1 x2\<^esub>)"
  and pequiv_R: "\<And>x1 x2. x1 \<le>\<^bsub>L\<^esub> x2 \<Longrightarrow> partial_equivalence_rel (\<le>\<^bsub>R x1 x2\<^esub>)"
  shows "preorder_on (in_field DFR) DFR"
  using assms by (intro preorder_onI reflexive_on_in_fieldI)
  (auto intro!: transitiveI dest: pequiv_R elim!: partial_equivalence_relE)

lemma symmetricI:
  assumes sym_L: "symmetric (\<le>\<^bsub>L\<^esub>)"
  and R_le_R_if_L: "\<And>x1 x2. x1 \<le>\<^bsub>L\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>R x1 x2\<^esub>) \<le> (\<le>\<^bsub>R x2 x1\<^esub>)"
  and sym_R: "\<And>x1 x2. x1 \<le>\<^bsub>L\<^esub> x2 \<Longrightarrow> symmetric (\<le>\<^bsub>R x1 x2\<^esub>)"
  shows "symmetric DFR"
proof (intro symmetricI Dep_Fun_Rel_relI)
  fix f g x y assume "x \<le>\<^bsub>L\<^esub> y"
  with sym_L have "y \<le>\<^bsub>L\<^esub> x" by (rule symmetricD)
  moreover assume "DFR f g"
  ultimately have "f y \<le>\<^bsub>R y x\<^esub> g x" by blast
  with sym_R \<open>y \<le>\<^bsub>L\<^esub> x\<close> have "g x \<le>\<^bsub>R y x\<^esub> f y" by (blast dest: symmetricD)
  with R_le_R_if_L \<open>y \<le>\<^bsub>L\<^esub> x\<close> show "g x \<le>\<^bsub>R x y\<^esub> f y" by blast
qed

corollary partial_equivalence_relI:
  assumes "reflexive_on (in_field (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>)"
  and sym_L: "symmetric (\<le>\<^bsub>L\<^esub>)"
  and mono_R: "([x1 x2 \<Colon> (\<le>\<^bsub>L\<^esub>)] \<Rrightarrow>\<^sub>m [x3 x4 \<Colon> (\<le>\<^bsub>L\<^esub>) | x1 \<le>\<^bsub>L\<^esub> x3] \<Rrightarrow> (\<le>)) R"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L\<^esub> x2 \<Longrightarrow> partial_equivalence_rel (\<le>\<^bsub>R x1 x2\<^esub>)"
  shows "partial_equivalence_rel DFR"
proof -
  have "(\<le>\<^bsub>R x1 x2\<^esub>) \<le> (\<le>\<^bsub>R x2 x1\<^esub>)" if "x1 \<le>\<^bsub>L\<^esub> x2" for x1 x2
  proof -
    from sym_L \<open>x1 \<le>\<^bsub>L\<^esub> x2\<close> have "x2 \<le>\<^bsub>L\<^esub> x1" by (rule symmetricD)
    with mono_R \<open>x1 \<le>\<^bsub>L\<^esub> x2\<close> show ?thesis by blast
  qed
  with assms show ?thesis
    by (intro partial_equivalence_relI transitiveI symmetricI)
    (auto elim: partial_equivalence_relE[OF assms(4)])
qed

end

context transport_Dep_Fun_Rel
begin

lemmas reflexive_on_in_field_leftI = dfro1.reflexive_on_in_fieldI
  [folded left_rel_eq_Dep_Fun_Rel]
lemmas transitive_leftI = dfro1.transitiveI[folded left_rel_eq_Dep_Fun_Rel]
lemmas transitive_leftI' = dfro1.transitiveI'[folded left_rel_eq_Dep_Fun_Rel]
lemmas preorder_on_in_field_leftI = dfro1.preorder_on_in_fieldI
  [folded left_rel_eq_Dep_Fun_Rel]
lemmas symmetric_leftI = dfro1.symmetricI[folded left_rel_eq_Dep_Fun_Rel]
lemmas partial_equivalence_rel_leftI = dfro1.partial_equivalence_relI
  [folded left_rel_eq_Dep_Fun_Rel]

subparagraph \<open>Introduction Rules for Assumptions\<close>

lemma transitive_left2_if_transitive_left2_if_GaloisI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R1\<^esub>)) l1"
  and "((\<le>\<^bsub>L1\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and L2_eq: "(\<le>\<^bsub>L2 x1 x2\<^esub>) = (\<le>\<^bsub>L2 x1 (\<eta>\<^sub>1 x2)\<^esub>)"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> transitive (\<le>\<^bsub>L2 x (r1 x')\<^esub>)"
  and "x1 \<le>\<^bsub>L1\<^esub> x2"
  shows "transitive (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  by (subst L2_eq) (auto intro!: assms t1.Galois_left_if_left_relI)

lemma symmetric_left2_if_symmetric_left2_if_GaloisI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R1\<^esub>)) l1"
  and "((\<le>\<^bsub>L1\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and L2_eq: "(\<le>\<^bsub>L2 x1 x2\<^esub>) = (\<le>\<^bsub>L2 x1 (\<eta>\<^sub>1 x2)\<^esub>)"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> symmetric (\<le>\<^bsub>L2 x (r1 x')\<^esub>)"
  and "x1 \<le>\<^bsub>L1\<^esub> x2"
  shows "symmetric (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  by (subst L2_eq) (auto intro!: assms t1.Galois_left_if_left_relI)

lemma partial_equivalence_rel_left2_if_partial_equivalence_rel_left2_if_GaloisI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R1\<^esub>)) l1"
  and "((\<le>\<^bsub>L1\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and L2_eq: "(\<le>\<^bsub>L2 x1 x2\<^esub>) = (\<le>\<^bsub>L2 x1 (\<eta>\<^sub>1 x2)\<^esub>)"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> partial_equivalence_rel (\<le>\<^bsub>L2 x (r1 x')\<^esub>)"
  and "x1 \<le>\<^bsub>L1\<^esub> x2"
  shows "partial_equivalence_rel (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  by (subst L2_eq) (auto intro!: assms t1.Galois_left_if_left_relI)

context
  assumes galois_prop: "((\<le>\<^bsub>L1\<^esub>) \<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
begin

interpretation flip_inv :
  transport_Dep_Fun_Rel "(\<ge>\<^bsub>R1\<^esub>)" "(\<ge>\<^bsub>L1\<^esub>)" r1 l1 "flip2 R2" "flip2 L2" r2 l2
  rewrites "flip_inv.t1.unit \<equiv> \<epsilon>\<^sub>1"
  and "\<And>R x y. (flip2 R x y) \<equiv> (R y x)\<inverse>"
  and "\<And>R S. R\<inverse> = S\<inverse> \<equiv> R = S"
  and "\<And>R S. (R\<inverse> \<Rrightarrow>\<^sub>m S\<inverse>) \<equiv> (R \<Rrightarrow>\<^sub>m S)"
  and "\<And>x x'. x' \<^bsub>R1\<^esub>\<greaterapprox> x \<equiv> x \<^bsub>L1\<^esub>\<lessapprox> x'"
  and "((\<ge>\<^bsub>R1\<^esub>) \<unlhd>\<^sub>h (\<ge>\<^bsub>L1\<^esub>)) r1 l1 \<equiv> True"
  and "\<And>R. transitive R\<inverse> \<equiv> transitive R"
  and "\<And>R. symmetric R\<inverse> \<equiv> symmetric R"
  and "\<And>R. partial_equivalence_rel R\<inverse> \<equiv> partial_equivalence_rel R"
  and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
  and "\<And>P Q. (True \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> True \<Longrightarrow> PROP Q)"
  using galois_prop
  by (auto intro!: Eq_TrueI simp add: t1.flip_unit_eq_counit
    galois_prop.half_galois_prop_right_rel_inv_iff_half_galois_prop_left
    simp del: rel_inv_iff_rel)

lemma transitive_right2_if_transitive_right2_if_GaloisI:
  assumes "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "(\<le>\<^bsub>R2 x1 x2\<^esub>) = (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1) x2\<^esub>)"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> transitive (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)"
  and "x1 \<le>\<^bsub>R1\<^esub> x2"
  shows "transitive (\<le>\<^bsub>R2 x1 x2\<^esub>)"
  using galois_prop assms
  by (intro flip_inv.transitive_left2_if_transitive_left2_if_GaloisI
    [simplified rel_inv_iff_rel, of x1])
  auto

lemma symmetric_right2_if_symmetric_right2_if_GaloisI:
  assumes "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "(\<le>\<^bsub>R2 x1 x2\<^esub>) = (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1) x2\<^esub>)"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> symmetric (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)"
  and "x1 \<le>\<^bsub>R1\<^esub> x2"
  shows "symmetric (\<le>\<^bsub>R2 x1 x2\<^esub>)"
  using galois_prop assms
  by (intro flip_inv.symmetric_left2_if_symmetric_left2_if_GaloisI
    [simplified rel_inv_iff_rel, of x1])
  auto

lemma partial_equivalence_rel_right2_if_partial_equivalence_rel_right2_if_GaloisI:
  assumes "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "(\<le>\<^bsub>R2 x1 x2\<^esub>) = (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1) x2\<^esub>)"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> partial_equivalence_rel (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)"
  and "x1 \<le>\<^bsub>R1\<^esub> x2"
  shows "partial_equivalence_rel (\<le>\<^bsub>R2 x1 x2\<^esub>)"
  using galois_prop assms
  by (intro flip_inv.partial_equivalence_rel_left2_if_partial_equivalence_rel_left2_if_GaloisI
    [simplified rel_inv_iff_rel, of x1])
  auto

end

lemma transitive_left2_if_preorder_equivalenceI:
  assumes pre_equiv1: "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "([x1 x2 \<Colon> (\<ge>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<^sub>m [x3 x4 \<Colon> (\<le>\<^bsub>L1\<^esub>) | x1 \<le>\<^bsub>L1\<^esub> x3] \<Rrightarrow> (\<le>)) L2"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> ((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>) (r2\<^bsub>x x'\<^esub>)"
  and "x1 \<le>\<^bsub>L1\<^esub> x2"
  shows "transitive (\<le>\<^bsub>L2 x1 x2\<^esub>)"
proof -
  from \<open>x1 \<le>\<^bsub>L1\<^esub> x2\<close> pre_equiv1 have "x2 \<equiv>\<^bsub>L1\<^esub> \<eta>\<^sub>1 x2"
    by (blast elim: t1.preorder_equivalence_order_equivalenceE
      intro: bi_related_if_rel_equivalence_on)
  with assms have "(\<le>\<^bsub>L2 x1 x2\<^esub>) = (\<le>\<^bsub>L2 x1 (\<eta>\<^sub>1 x2)\<^esub>)"
    by (intro left2_eq_if_bi_related_if_monoI) blast+
  with assms show ?thesis
    by (intro transitive_left2_if_transitive_left2_if_GaloisI[of x1]) blast+
qed

lemma symmetric_left2_if_partial_equivalence_rel_equivalenceI:
  assumes PER_equiv1: "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "([x1 x2 \<Colon> (\<ge>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<^sub>m [x3 x4 \<Colon> (\<le>\<^bsub>L1\<^esub>) | x1 \<le>\<^bsub>L1\<^esub> x3] \<Rrightarrow> (\<le>)) L2"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> ((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>) (r2\<^bsub>x x'\<^esub>)"
  and "x1 \<le>\<^bsub>L1\<^esub> x2"
  shows "symmetric (\<le>\<^bsub>L2 x1 x2\<^esub>)"
proof -
  from \<open>x1 \<le>\<^bsub>L1\<^esub> x2\<close> PER_equiv1 have "x2 \<equiv>\<^bsub>L1\<^esub> \<eta>\<^sub>1 x2"
    by (blast elim: t1.preorder_equivalence_order_equivalenceE
      intro: bi_related_if_rel_equivalence_on)
  with assms have "(\<le>\<^bsub>L2 x1 x2\<^esub>) = (\<le>\<^bsub>L2 x1 (\<eta>\<^sub>1 x2)\<^esub>)"
    by (intro left2_eq_if_bi_related_if_monoI) blast+
  with assms show ?thesis
    by (intro symmetric_left2_if_symmetric_left2_if_GaloisI[of x1]) blast+
qed

lemma partial_equivalence_rel_left2_if_partial_equivalence_rel_equivalenceI:
  assumes PER_equiv1: "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "([x1 x2 \<Colon> (\<ge>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<^sub>m [x3 x4 \<Colon> (\<le>\<^bsub>L1\<^esub>) | x1 \<le>\<^bsub>L1\<^esub> x3] \<Rrightarrow> (\<le>)) L2"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> ((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>) (r2\<^bsub>x x'\<^esub>)"
  and "x1 \<le>\<^bsub>L1\<^esub> x2"
  shows "partial_equivalence_rel (\<le>\<^bsub>L2 x1 x2\<^esub>)"
proof -
  from \<open>x1 \<le>\<^bsub>L1\<^esub> x2\<close> PER_equiv1 have "x2 \<equiv>\<^bsub>L1\<^esub> \<eta>\<^sub>1 x2"
    by (blast elim: t1.preorder_equivalence_order_equivalenceE
      intro: bi_related_if_rel_equivalence_on)
  with assms have "(\<le>\<^bsub>L2 x1 x2\<^esub>) = (\<le>\<^bsub>L2 x1 (\<eta>\<^sub>1 x2)\<^esub>)"
    by (intro left2_eq_if_bi_related_if_monoI) blast+
  with assms show ?thesis
    by (intro partial_equivalence_rel_left2_if_partial_equivalence_rel_left2_if_GaloisI[of x1])
    blast+
qed

interpretation flip : transport_Dep_Fun_Rel R1 L1 r1 l1 R2 L2 r2 l2
  rewrites "flip.t1.counit \<equiv> \<eta>\<^sub>1" and "flip.t1.unit \<equiv> \<epsilon>\<^sub>1"
  by (simp_all only: t1.flip_counit_eq_unit t1.flip_unit_eq_counit)

lemma transitive_right2_if_preorder_equivalenceI:
  assumes pre_equiv1: "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "([x1' x2' \<Colon> (\<ge>\<^bsub>R1\<^esub>)] \<Rrightarrow>\<^sub>m [x3' x4' \<Colon> (\<le>\<^bsub>R1\<^esub>) | x1' \<le>\<^bsub>R1\<^esub> x3'] \<Rrightarrow> (\<le>)) R2"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> ((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<equiv>\<^bsub>pre\<^esub> (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>) (r2\<^bsub>x x'\<^esub>)"
  and "x1' \<le>\<^bsub>R1\<^esub> x2'"
  shows "transitive (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
proof -
  from \<open>x1' \<le>\<^bsub>R1\<^esub> x2'\<close> pre_equiv1 have "x1' \<equiv>\<^bsub>R1\<^esub> \<epsilon>\<^sub>1 x1'"
    by (blast elim: t1.preorder_equivalence_order_equivalenceE
      intro: bi_related_if_rel_equivalence_on)
  with assms have "(\<le>\<^bsub>R2 x1' x2'\<^esub>) = (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1') x2'\<^esub>)"
    by (intro flip.left2_eq_if_bi_related_if_monoI) blast+
  with assms show ?thesis
    by (intro transitive_right2_if_transitive_right2_if_GaloisI[of x1']) blast+
qed

lemma symmetric_right2_if_partial_equivalence_rel_equivalenceI:
  assumes PER_equiv1: "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "([x1' x2' \<Colon> (\<ge>\<^bsub>R1\<^esub>)] \<Rrightarrow>\<^sub>m [x3' x4' \<Colon> (\<le>\<^bsub>R1\<^esub>) | x1' \<le>\<^bsub>R1\<^esub> x3'] \<Rrightarrow> (\<le>)) R2"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> ((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>) (r2\<^bsub>x x'\<^esub>)"
  and "x1' \<le>\<^bsub>R1\<^esub> x2'"
  shows "symmetric (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
proof -
  from \<open>x1' \<le>\<^bsub>R1\<^esub> x2'\<close> PER_equiv1 have "x1' \<equiv>\<^bsub>R1\<^esub> \<epsilon>\<^sub>1 x1'"
    by (blast elim: t1.preorder_equivalence_order_equivalenceE
      intro: bi_related_if_rel_equivalence_on)
  with assms have "(\<le>\<^bsub>R2 x1' x2'\<^esub>) = (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1') x2'\<^esub>)"
    by (intro flip.left2_eq_if_bi_related_if_monoI) blast+
  with assms show ?thesis
    by (intro symmetric_right2_if_symmetric_right2_if_GaloisI[of x1']) blast+
qed

lemma partial_equivalence_rel_right2_if_partial_equivalence_rel_equivalenceI:
  assumes PER_equiv1: "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "([x1' x2' \<Colon> (\<ge>\<^bsub>R1\<^esub>)] \<Rrightarrow>\<^sub>m [x3' x4' \<Colon> (\<le>\<^bsub>R1\<^esub>) | x1' \<le>\<^bsub>R1\<^esub> x3'] \<Rrightarrow> (\<le>)) R2"
  and "\<And>x x'. x \<^bsub>L1\<^esub>\<lessapprox> x' \<Longrightarrow> ((\<le>\<^bsub>L2 x (r1 x')\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R2 (l1 x) x'\<^esub>)) (l2\<^bsub>x' x\<^esub>) (r2\<^bsub>x x'\<^esub>)"
  and "x1' \<le>\<^bsub>R1\<^esub> x2'"
  shows "partial_equivalence_rel (\<le>\<^bsub>R2 x1' x2'\<^esub>)"
proof -
  from \<open>x1' \<le>\<^bsub>R1\<^esub> x2'\<close> PER_equiv1 have "x1' \<equiv>\<^bsub>R1\<^esub> \<epsilon>\<^sub>1 x1'"
    by (blast elim: t1.preorder_equivalence_order_equivalenceE
      intro: bi_related_if_rel_equivalence_on)
  with assms have "(\<le>\<^bsub>R2 x1' x2'\<^esub>) = (\<le>\<^bsub>R2 (\<epsilon>\<^sub>1 x1') x2'\<^esub>)"
    by (intro flip.left2_eq_if_bi_related_if_monoI) blast+
  with assms show ?thesis
    by (intro partial_equivalence_rel_right2_if_partial_equivalence_rel_right2_if_GaloisI[of x1'])
    blast+
qed

end

paragraph \<open>Function Relator\<close>

context transport_Fun_Rel
begin

lemma reflexive_on_in_field_leftI:
  assumes "reflexive_on (in_field (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "partial_equivalence_rel (\<le>\<^bsub>L2\<^esub>)"
  shows "reflexive_on (in_field (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>)"
  using assms by (intro tdfr.reflexive_on_in_field_leftI) simp_all

lemma transitive_leftI:
  assumes "reflexive_on (in_dom (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "transitive (\<le>\<^bsub>L2\<^esub>)"
  shows "transitive (\<le>\<^bsub>L\<^esub>)"
  using assms by (intro tdfr.transitive_leftI) simp_all

lemma transitive_leftI':
  assumes "reflexive_on (in_codom (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "transitive (\<le>\<^bsub>L2\<^esub>)"
  shows "transitive (\<le>\<^bsub>L\<^esub>)"
  using assms by (intro tdfr.transitive_leftI') simp_all

lemma preorder_on_in_field_leftI:
  assumes "reflexive_on (in_field (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "partial_equivalence_rel (\<le>\<^bsub>L2\<^esub>)"
  shows "preorder_on (in_field (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>)"
  using assms by (intro tdfr.preorder_on_in_field_leftI) simp_all

lemma symmetric_leftI:
  assumes "symmetric (\<le>\<^bsub>L1\<^esub>)"
  and "symmetric (\<le>\<^bsub>L2\<^esub>)"
  shows "symmetric (\<le>\<^bsub>L\<^esub>)"
  using assms by (intro tdfr.symmetric_leftI) simp_all

corollary partial_equivalence_rel_leftI:
  assumes "reflexive_on (in_field (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "symmetric (\<le>\<^bsub>L1\<^esub>)"
  and "partial_equivalence_rel (\<le>\<^bsub>L2\<^esub>)"
  shows "partial_equivalence_rel (\<le>\<^bsub>L\<^esub>)"
  using assms by (intro tdfr.partial_equivalence_rel_leftI) auto

end

paragraph \<open>Monotone Dependent Function Relator\<close>

context transport_Mono_Dep_Fun_Rel
begin

lemmas reflexive_on_in_field_leftI = Refl_Rel_reflexive_on_in_field[of tdfr.L,
  folded left_rel_eq_tdfr_left_Refl_Rel]
lemmas transitive_leftI = Refl_Rel_transitiveI
  [of tdfr.L, folded left_rel_eq_tdfr_left_Refl_Rel]
lemmas preorder_on_in_field_leftI = Refl_Rel_preorder_on_in_fieldI[of tdfr.L,
  folded left_rel_eq_tdfr_left_Refl_Rel]
lemmas symmetric_leftI = Refl_Rel_symmetricI[of tdfr.L,
  OF tdfr.symmetric_leftI, folded left_rel_eq_tdfr_left_Refl_Rel]
lemmas partial_equivalence_rel_leftI = Refl_Rel_partial_equivalence_relI[of tdfr.L,
  OF tdfr.partial_equivalence_rel_leftI, folded left_rel_eq_tdfr_left_Refl_Rel]

end

paragraph \<open>Monotone Function Relator\<close>

context transport_Mono_Fun_Rel
begin

lemma symmetric_leftI:
  assumes "symmetric (\<le>\<^bsub>L1\<^esub>)"
  and "symmetric (\<le>\<^bsub>L2\<^esub>)"
  shows "symmetric (\<le>\<^bsub>L\<^esub>)"
  using assms by (intro tpdfr.symmetric_leftI) auto

lemma partial_equivalence_rel_leftI:
  assumes "reflexive_on (in_field (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>)"
  and "symmetric (\<le>\<^bsub>L1\<^esub>)"
  and "partial_equivalence_rel (\<le>\<^bsub>L2\<^esub>)"
  shows "partial_equivalence_rel (\<le>\<^bsub>L\<^esub>)"
  using assms by (intro tpdfr.partial_equivalence_rel_leftI) auto

end

end


theory Normalized_Zone_Semantics_Certification_Impl2
  imports
    Normalized_Zone_Semantics_Certification_Impl
    Certification.Unreachability_Certification
begin

context Reachability_Problem_Impl_Precise
begin

thm
  certify_unreachable_impl.refine[
    OF Reachability_Impl_axioms L_list_hnr, unfolded PR_CONST_def, OF M_table.refine
    ]
  op_precise_unreachable_correct'

context
  fixes L_list :: "'si list" and P_loc and M_list :: "('si \<times> int DBMEntry list list) list"
  assumes state_impl_abstract: "\<And>li. P_loc li \<Longrightarrow> \<exists>l. (li, l) \<in> loc_rel"
  assumes P_loc: "list_all (\<lambda>x. P_loc x \<and> states_mem_impl x) L_list"
  assumes M_list_covered: "fst ` set M_list \<subseteq> set L_list"
      and M_dbm_len: "list_all (\<lambda>(l, xs). list_all (\<lambda>M. length M = Suc n * Suc n) xs) M_list"
begin

context
  fixes splitter :: "'s list \<Rightarrow> 's list list" and splitteri :: "'si list \<Rightarrow> 'si list list"
  assumes full_split: "set xs = (\<Union>xs \<in> set (splitter xs). set xs)"
      and same_split:
  "\<And>L Li.
    list_assn (list_assn location_assn) (splitter L) (splitteri Li) = list_assn location_assn L Li"
begin

lemmas certify_unreachable_impl_hnr =
  certify_unreachable_impl.refine[
    OF Reachability_Impl_axioms L_list_hnr, unfolded PR_CONST_def, OF M_table.refine,
    OF full_split same_split,
    FCOMP op_precise_unreachable_correct'
  ]

definition
  "unreachability_checker \<equiv>
  let
    Fi = F_impl;
    Pi = P_impl;
    copyi = amtx_copy;
    Lei = dbm_subset_impl n;
    l\<^sub>0i = Heap_Monad.return l\<^sub>0i;
    s\<^sub>0i = init_dbm_impl;
    succsi = succs_precise'_impl;
    M_table = M_table
  in
    certify_unreachable_impl Fi Pi copyi Lei l\<^sub>0i s\<^sub>0i succsi L_list M_table splitteri"

lemma unreachability_checker_alt_def:
  "unreachability_checker \<equiv>
  let
    Fi = F_impl;
    Pi = P_impl;
    copyi = amtx_copy;
    Lei = dbm_subset_impl n;
    l\<^sub>0i = Heap_Monad.return l\<^sub>0i;
    s\<^sub>0i = init_dbm_impl;
    succsi = succs_precise'_impl
  in do {
    M_table \<leftarrow> M_table;
    certify_unreachable_impl_inner Fi Pi copyi Lei l\<^sub>0i s\<^sub>0i succsi splitteri L_list M_table
  }"
  unfolding unreachability_checker_def certify_unreachable_impl_def Let_def .

lemmas unreachability_checker_hnr =
  certify_unreachable_impl_hnr[folded unreachability_checker_def[unfolded Let_def]]

lemmas unreachability_checker_alt_def' = unreachability_checker_alt_def[unfolded M_table_def]

definition
  "unreachability_checker2 \<equiv>
  let
    Fi = F_impl;
    Pi = P_impl;
    copyi = amtx_copy;
    Lei = dbm_subset_impl n;
    l\<^sub>0i = Heap_Monad.return l\<^sub>0i;
    s\<^sub>0i = init_dbm_impl;
    succsi = succs_precise'_impl;
    M_table = M_table
  in
    certify_unreachable_impl2 Fi Pi copyi Lei l\<^sub>0i s\<^sub>0i succsi splitteri L_list M_table"

lemmas unreachability_checker2_refine = certify_unreachable_impl2_refine[
    of L_list M_table splitter splitteri,
    OF L_list_hnr _ full_split same_split L_dom_M_eqI[symmetric],
    unfolded PR_CONST_def, OF M_table.refine,
    folded unreachability_checker2_def[unfolded Let_def],
    THEN mp, THEN op_precise_unreachable_correct
]

end (* Splitter *)

end (* L and M *)

end (* Reachability Problem Impl Precise *)

context TA_Impl_Precise
begin

lemma (in TA_Impl) dbm_subset_correct:
  assumes "wf_dbm D" and "wf_dbm M"
  shows "[curry (conv_M D)]\<^bsub>v,n\<^esub> \<subseteq> [curry (conv_M M)]\<^bsub>v,n\<^esub> \<longleftrightarrow> dbm_subset n D M"
  unfolding dbm_subset_correct''[OF assms] using dbm_subset_conv_rev dbm_subset_conv ..

lemma empty_steps_states':
  "l' \<in> states'" if "op_precise.E_from_op_empty\<^sup>*\<^sup>* (l, D) (l', D')" "l \<in> states'"
  using that
proof (induction "(l, D)" "(l', D')" arbitrary: l' D')
  case rtrancl_refl
  then show ?case
    by simp
next
  case (rtrancl_into_rtrancl b)
  then show ?case
    by (cases b) (auto simp add: op_precise.E_from_op_empty_def intro: E_from_op_states)
qed

interpretation deadlock: Reachability_Problem_Impl_Precise where
  F = "\<lambda>(l, D). \<not> (check_deadlock_dbm l D)" and
  F1 = "\<lambda>(l, Z). \<not> (TA.check_deadlock l Z)" and
  F' = deadlocked and
  F_impl = "\<lambda>(l, M). do {r \<leftarrow> check_deadlock_impl l M; return (\<not> r)}"
  apply standard
(* mono *)
  subgoal for a b
    apply clarsimp
    apply (auto dest: TA.check_deadlock_anti_mono simp:
        dbm_subset_correct[symmetric] check_deadlock_dbm_correct'[symmetric, unfolded wf_state_def])
    done
(* compatible zone *)
  subgoal
    using
      Bisimulation_Invariant.B_steps_invariant[OF op_precise.step_z_dbm'_E_from_op_bisim_empty]
      wf_state_init states'_states
    unfolding a\<^sub>0_def
    by simp (subst check_deadlock_dbm_correct'[symmetric], auto elim: empty_steps_states')
(* compatible semantics *)
  subgoal for l u Z
    unfolding TA.check_deadlock_correct_step' deadlocked_def by auto
(* implementation correct *)
  subgoal
  proof -
    define location_assn' where "location_assn' = location_assn"
    define mtx_assn' :: "_ \<Rightarrow> int DBMEntry Heap.array \<Rightarrow> _" where "mtx_assn' = mtx_assn n"
    note [sep_heap_rules] = check_deadlock_impl.refine[
        to_hnr, unfolded hn_refine_def hn_ctxt_def,
        folded location_assn'_def mtx_assn'_def, simplified]
    show ?thesis
      unfolding location_assn'_def[symmetric] mtx_assn'_def[symmetric]
      by sepref_to_hoare (sep_auto simp: pure_def)
  qed
  done

lemma deadlock_unreachability_checker2_hnr:
  fixes P_loc :: "'si \<Rightarrow> bool"
    and L_list :: "'si list"
    and M_list :: "('si \<times> int DBMEntry list list) list"
  fixes splitter :: "'s list \<Rightarrow> 's list list" and splitteri :: "'si list \<Rightarrow> 'si list list"
  assumes "\<And>li. P_loc li \<Longrightarrow> \<exists>l. (li, l) \<in> loc_rel"
    and "list_all (\<lambda>x. P_loc x \<and> states_mem_impl x) L_list"
    and "list_all (\<lambda>(l, xs). list_all (\<lambda>M. length M = Suc n * Suc n) xs) M_list"
    and "fst ` set M_list = set L_list"
  assumes full_split: "\<And>xs. set xs = (\<Union>xs \<in> set (splitter xs). set xs)"
    and same_split:
    "\<And>L Li.
      list_assn (list_assn location_assn) (splitter L) (splitteri Li) = list_assn location_assn L Li"
  shows
    "deadlock.unreachability_checker2 L_list M_list splitteri
    \<longrightarrow> (\<forall>u. (\<forall>c\<le>n. u c = 0) \<longrightarrow> \<not> deadlock (l\<^sub>0, u))"
  using deadlock.unreachability_checker2_refine[
      OF assms(1-2) assms(4)[THEN equalityD1] assms(3) full_split same_split assms(4)
      ]
  unfolding deadlock_def steps'_iff[symmetric] by auto

lemma deadlock_unreachability_checker3_hnr:
  fixes P_loc :: "'si \<Rightarrow> bool"
    and L_list :: "'si list"
    and M_list :: "('si \<times> int DBMEntry list list) list"
  fixes Li_split :: "'si list list"
  assumes "\<And>li. P_loc li \<Longrightarrow> \<exists>l. (li, l) \<in> loc_rel"
    and "list_all (\<lambda>x. P_loc x \<and> states_mem_impl x) L_list"
    and "list_all (\<lambda>(l, xs). list_all (\<lambda>M. length M = Suc n * Suc n) xs) M_list"
    and "fst ` set M_list = set L_list"
  assumes full_split: "set L_list = (\<Union>xs \<in> set Li_split. set xs)"
  shows
    "deadlock.certify_unreachable_pure L_list M_list Li_split
    \<longrightarrow> (\<forall>u. (\<forall>c\<le>n. u c = 0) \<longrightarrow> \<not> deadlock (l\<^sub>0, u))"
  using deadlock.certify_unreachable_pure_refine[
      OF assms(1-2) assms(4)[THEN equalityD1] assms(3) full_split assms(4)
      ]
  unfolding deadlock_def steps'_iff[symmetric] by auto

lemmas deadlock_unreachability_checker2_def = deadlock.unreachability_checker2_def

lemmas deadlock_unreachability_checker_alt_def = deadlock.unreachability_checker_alt_def

lemmas deadlock_unreachability_checker3_def = deadlock.certify_unreachable_pure_def

lemma deadlock_unreachability_checker_hnr:
  fixes P_loc :: "'si \<Rightarrow> bool"
    and L_list :: "'si list"
    and M_list :: "('si \<times> int DBMEntry list list) list"
  fixes splitter :: "'s list \<Rightarrow> 's list list" and splitteri :: "'si list \<Rightarrow> 'si list list"
  assumes "\<And>li. P_loc li \<Longrightarrow> \<exists>l. (li, l) \<in> loc_rel"
    and "list_all (\<lambda>x. P_loc x \<and> states_mem_impl x) L_list"
    and "fst ` set M_list \<subseteq> set L_list"
    and "list_all (\<lambda>(l, xs). list_all (\<lambda>M. length M = Suc n * Suc n) xs) M_list"
    and "set (deadlock.L L_list) = dom (deadlock.M M_list)"
  assumes full_split: "\<And>xs. set xs = (\<Union>xs \<in> set (splitter xs). set xs)"
      and same_split:
    "\<And>L Li.
      list_assn (list_assn location_assn) (splitter L) (splitteri Li) = list_assn location_assn L Li"
  shows
    "(uncurry0
       (Reachability_Problem_Impl_Precise.unreachability_checker n trans_impl l\<^sub>0i op_impl
         states_mem_impl (\<lambda>(l, M). check_deadlock_impl l M \<bind> (\<lambda>r. return (\<not> r))) L_list M_list splitteri),
      uncurry0
       (SPEC
         (\<lambda>r. r \<longrightarrow> (\<forall>u. (\<forall>c\<le>n. u c = 0) \<longrightarrow> \<not> deadlock (l\<^sub>0, u)))))
     \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn"
  using deadlock.unreachability_checker_hnr[OF assms(1-4), OF _ full_split same_split assms(5)]
  unfolding deadlock_def steps'_iff[symmetric] by simp linarith

end (* TA Impl Precise *)

concrete_definition (in -) unreachability_checker
  uses Reachability_Problem_Impl_Precise.unreachability_checker_alt_def

end


(******************************************************************************)
(* Project: Isabelle/UTP: Unifying Theories of Programming in Isabelle/HOL    *)
(* File: urel.thy                                                             *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@gmail.com and simon.foster@york.ac.uk                  *)
(******************************************************************************)
(* LAST REVIEWED: 09 Jun 2022 *)

section \<open>Relational Predicates\<close>

theory urel
imports upred ulift
begin

subsection \<open>Operators\<close>

subsubsection \<open>Skip\<close>

definition SkipP :: "upred" where
"SkipP = LiftP (\<lambda>b. \<forall>v\<in>UNDASHED. b\<cdot>v = b\<cdot>(v\<acute>))"

notation SkipP ("II\<^sub>p")

subsubsection \<open>Composition\<close>

text \<open>\fixme{Give an algebraic definition once substitution is mechanised.}\<close>

lift_definition SemiP :: "upred \<Rightarrow> upred \<Rightarrow> upred"
is "(\<lambda>bs1 bs2.
  {b::ustate. \<exists>b1\<in>bs1. \<exists>b2\<in>bs2.
    (b \<cong>\<^sub>b b1 on UNDASHED \<union> NON_REL_VAR) \<and>
    (b \<cong>\<^sub>b b2 on DASHED \<union> NON_REL_VAR) \<and>
    (\<forall>v\<in>UNDASHED. b1\<cdot>(v\<acute>) = b2\<cdot>v)})"
done

notation SemiP (infixl ";\<^sub>p" 100)

subsection \<open>Proof Support\<close>

declare SkipP_def [evalp]

subsection \<open>Experiments\<close>

text \<open>\todo{Automate imposing @{class injectable} on free types!}\<close>

theorem "II\<^sub>p \<and>\<^sub>p (x = @(c::nat))\<^sub>p \<Rightarrow>\<^sub>p (x' = @(c))\<^sub>p"
apply (upred_tac)
apply (unfold ustate_app_poly_def)
apply (simp add: vars)
done
end


section \<open>\isaheader{Generic Set Algorithms}\<close>
theory Gen_Set
imports "../Intf/Intf_Set" "../../Iterator/Iterator"
begin

  lemma foldli_union: "det_fold_set X (\<lambda>_. True) insert a ((\<union>) a)"
  proof (rule, goal_cases)
    case (1 l) thus ?case
      by (induct l arbitrary: a) auto
  qed

  definition gen_union
    :: "_ \<Rightarrow> ('k \<Rightarrow> 's2 \<Rightarrow> 's2)
        \<Rightarrow> 's1 \<Rightarrow> 's2 \<Rightarrow> 's2"
    where
    "gen_union it ins A B \<equiv> it A (\<lambda>_. True) ins B"

  lemma gen_union[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes INS: "GEN_OP ins Set.insert (Rk\<rightarrow>\<langle>Rk\<rangle>Rs2\<rightarrow>\<langle>Rk\<rangle>Rs2)"
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 tsl)"
    shows "(gen_union (\<lambda>x. foldli (tsl x)) ins,(\<union>))
    \<in> (\<langle>Rk\<rangle>Rs1) \<rightarrow> (\<langle>Rk\<rangle>Rs2) \<rightarrow> (\<langle>Rk\<rangle>Rs2)"
    apply (intro fun_relI)
    apply (subst Un_commute)
    unfolding gen_union_def
    apply (rule det_fold_set[OF
      foldli_union IT[unfolded autoref_tag_defs]])
    using INS
    unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma foldli_inter: "det_fold_set X (\<lambda>_. True)
    (\<lambda>x s. if x\<in>a then insert x s else s) {} (\<lambda>s. s\<inter>a)"
    (is "det_fold_set _ _ ?f _ _")
  proof -
    {
      fix l s0
      have "foldli l (\<lambda>_. True)
        (\<lambda>x s. if x\<in>a then insert x s else s) s0 = s0 \<union> (set l \<inter> a)"
        by (induct l arbitrary: s0) auto
    }
    from this[of _ "{}"] show ?thesis apply - by rule simp
  qed

  definition gen_inter :: "_ \<Rightarrow>
    ('k \<Rightarrow> 's2 \<Rightarrow> bool) \<Rightarrow> _"
    where "gen_inter it1 memb2 ins3 empty3 s1 s2
    \<equiv> it1 s1 (\<lambda>_. True)
      (\<lambda>x s. if memb2 x s2 then ins3 x s else s) empty3"

  lemma gen_inter[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 tsl)"
    assumes MEMB:
      "GEN_OP memb2 (\<in>) (Rk \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id)"
    assumes INS:
      "GEN_OP ins3 Set.insert (Rk\<rightarrow>\<langle>Rk\<rangle>Rs3\<rightarrow>\<langle>Rk\<rangle>Rs3)"
    assumes EMPTY:
      "GEN_OP empty3 {} (\<langle>Rk\<rangle>Rs3)"
    shows "(gen_inter (\<lambda>x. foldli (tsl x)) memb2 ins3 empty3,(\<inter>))
    \<in> (\<langle>Rk\<rangle>Rs1) \<rightarrow> (\<langle>Rk\<rangle>Rs2) \<rightarrow> (\<langle>Rk\<rangle>Rs3)"
    apply (intro fun_relI)
    unfolding gen_inter_def
    apply (rule det_fold_set[OF foldli_inter IT[unfolded autoref_tag_defs]])
    using MEMB INS EMPTY
    unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma foldli_diff:
    "det_fold_set X (\<lambda>_. True) (\<lambda>x s. op_set_delete x s) s ((-) s)"
  proof (rule, goal_cases)
    case (1 l) thus ?case
      by (induct l arbitrary: s) auto
  qed

  definition gen_diff :: "('k\<Rightarrow>'s1\<Rightarrow>'s1) \<Rightarrow> _ \<Rightarrow> 's2 \<Rightarrow> _ "
    where "gen_diff del1 it2 s1 s2
    \<equiv> it2 s2 (\<lambda>_. True) (\<lambda>x s. del1 x s) s1"

  lemma gen_diff[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes DEL:
      "GEN_OP del1 op_set_delete (Rk \<rightarrow> \<langle>Rk\<rangle>Rs1 \<rightarrow> \<langle>Rk\<rangle>Rs1)"
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs2 it2)"
    shows "(gen_diff del1 (\<lambda>x. foldli (it2 x)),(-))
      \<in> (\<langle>Rk\<rangle>Rs1) \<rightarrow> (\<langle>Rk\<rangle>Rs2) \<rightarrow> (\<langle>Rk\<rangle>Rs1)"
    apply (intro fun_relI)
    unfolding gen_diff_def
    apply (rule det_fold_set[OF foldli_diff IT[unfolded autoref_tag_defs]])
    using DEL
    unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma foldli_ball_aux:
    "foldli l (\<lambda>x. x) (\<lambda>x _. P x) b \<longleftrightarrow> b \<and> Ball (set l) P"
    by (induct l arbitrary: b) auto

  lemma foldli_ball: "det_fold_set X (\<lambda>x. x) (\<lambda>x _. P x) True (\<lambda>s. Ball s P)"
    apply rule using foldli_ball_aux[where b=True] by simp

  definition gen_ball :: "_ \<Rightarrow> 's \<Rightarrow> ('k \<Rightarrow> bool) \<Rightarrow> _ "
    where "gen_ball it s P \<equiv> it s (\<lambda>x. x) (\<lambda>x _. P x) True"

  lemma gen_ball[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
    shows "(gen_ball (\<lambda>x. foldli (it x)),Ball) \<in> \<langle>Rk\<rangle>Rs \<rightarrow> (Rk\<rightarrow>Id) \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_ball_def
    apply (rule det_fold_set[OF foldli_ball IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma foldli_bex_aux: "foldli l (\<lambda>x. \<not>x) (\<lambda>x _. P x) b \<longleftrightarrow> b \<or> Bex (set l) P"
    by (induct l arbitrary: b) auto

  lemma foldli_bex: "det_fold_set X (\<lambda>x. \<not>x) (\<lambda>x _. P x) False (\<lambda>s. Bex s P)"
    apply rule using foldli_bex_aux[where b=False] by simp

  definition gen_bex :: "_ \<Rightarrow> 's \<Rightarrow> ('k \<Rightarrow> bool) \<Rightarrow> _ "
    where "gen_bex it s P \<equiv> it s (\<lambda>x. \<not>x) (\<lambda>x _. P x) False"

  lemma gen_bex[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
    shows "(gen_bex (\<lambda>x. foldli (it x)),Bex) \<in> \<langle>Rk\<rangle>Rs \<rightarrow> (Rk\<rightarrow>Id) \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_bex_def
    apply (rule det_fold_set[OF foldli_bex IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma ball_subseteq:
    "(Ball s1 (\<lambda>x. x\<in>s2)) \<longleftrightarrow> s1 \<subseteq> s2"
    by blast

  definition gen_subseteq
    :: "('s1 \<Rightarrow> ('k \<Rightarrow> bool) \<Rightarrow> bool) \<Rightarrow> ('k \<Rightarrow> 's2 \<Rightarrow> bool) \<Rightarrow> _"
    where "gen_subseteq ball1 mem2 s1 s2 \<equiv> ball1 s1 (\<lambda>x. mem2 x s2)"

  lemma gen_subseteq[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes "GEN_OP ball1 Ball (\<langle>Rk\<rangle>Rs1 \<rightarrow> (Rk\<rightarrow>Id) \<rightarrow> Id)"
    assumes "GEN_OP mem2 (\<in>) (Rk \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id)"
    shows "(gen_subseteq ball1 mem2,(\<subseteq>)) \<in> \<langle>Rk\<rangle>Rs1 \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_subseteq_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst ball_subseteq[symmetric])
    apply parametricity
    done

  definition "gen_equal ss1 ss2 s1 s2 \<equiv> ss1 s1 s2 \<and> ss2 s2 s1"

  lemma gen_equal[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes "GEN_OP ss1 (\<subseteq>) (\<langle>Rk\<rangle>Rs1 \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id)"
    assumes "GEN_OP ss2 (\<subseteq>) (\<langle>Rk\<rangle>Rs2 \<rightarrow> \<langle>Rk\<rangle>Rs1 \<rightarrow> Id)"
    shows "(gen_equal ss1 ss2, (=)) \<in> \<langle>Rk\<rangle>Rs1 \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_equal_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst set_eq_subset)
    apply (parametricity)
    done

  lemma foldli_card_aux: "distinct l \<Longrightarrow> foldli l (\<lambda>_. True)
    (\<lambda>_ n. Suc n) n = n + card (set l)"
    apply (induct l arbitrary: n)
    apply auto
    done

  lemma foldli_card: "det_fold_set X (\<lambda>_. True) (\<lambda>_ n. Suc n) 0 card"
    apply rule using foldli_card_aux[where n=0] by simp

  definition gen_card where
    "gen_card it s \<equiv> it s (\<lambda>x. True) (\<lambda>_ n. Suc n) 0"

  lemma gen_card[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
    shows "(gen_card (\<lambda>x. foldli (it x)),card) \<in> \<langle>Rk\<rangle>Rs \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_card_def
    apply (rule det_fold_set[OF foldli_card IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma fold_set: "fold Set.insert l s = s \<union> set l"
    by (induct l arbitrary: s) auto

  definition gen_set :: "'s \<Rightarrow> ('k \<Rightarrow> 's \<Rightarrow> 's) \<Rightarrow> _" where
    "gen_set emp ins l = fold ins l emp"

  lemma gen_set[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes EMPTY:
      "GEN_OP emp {} (\<langle>Rk\<rangle>Rs)"
    assumes INS:
      "GEN_OP ins Set.insert (Rk\<rightarrow>\<langle>Rk\<rangle>Rs\<rightarrow>\<langle>Rk\<rangle>Rs)"
    shows "(gen_set emp ins,set)\<in>\<langle>Rk\<rangle>list_rel\<rightarrow>\<langle>Rk\<rangle>Rs"
    apply (intro fun_relI)
    unfolding gen_set_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst fold_set[where s="{}",simplified,symmetric])
    apply parametricity
    done

  lemma ball_isEmpty: "op_set_isEmpty s = (\<forall>x\<in>s. False)"
    by auto

  definition gen_isEmpty :: "('s \<Rightarrow> ('k \<Rightarrow> bool) \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool" where
    "gen_isEmpty ball s \<equiv> ball s (\<lambda>_. False)"

  lemma gen_isEmpty[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes "GEN_OP ball Ball (\<langle>Rk\<rangle>Rs \<rightarrow> (Rk\<rightarrow>Id) \<rightarrow> Id)"
    shows "(gen_isEmpty ball,op_set_isEmpty) \<in> \<langle>Rk\<rangle>Rs \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_isEmpty_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst ball_isEmpty)
    apply parametricity
    done

  lemma foldli_size_abort_aux:
    "\<lbrakk>n0\<le>m; distinct l\<rbrakk> \<Longrightarrow>
      foldli l (\<lambda>n. n<m) (\<lambda>_ n. Suc n) n0 = min m (n0 + card (set l))"
    apply (induct l arbitrary: n0)
    apply auto
    done

  lemma foldli_size_abort: "
    det_fold_set X (\<lambda>n. n<m) (\<lambda>_ n. Suc n) 0 (op_set_size_abort m)"
    apply rule
    using foldli_size_abort_aux[where ?n0.0=0]
    by simp

  definition gen_size_abort where
    "gen_size_abort it m s \<equiv> it s (\<lambda>n. n<m) (\<lambda>_ n. Suc n) 0"

  lemma gen_size_abort[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
    shows "(gen_size_abort (\<lambda>x. foldli (it x)),op_set_size_abort)
    \<in> Id \<rightarrow> \<langle>Rk\<rangle>Rs \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_size_abort_def
    apply (rule det_fold_set[OF foldli_size_abort IT[unfolded autoref_tag_defs]])
    apply (parametricity)+
    done

  lemma size_abort_isSng: "op_set_isSng s \<longleftrightarrow> op_set_size_abort 2 s = 1"
    by auto

  definition gen_isSng :: "(nat \<Rightarrow> 's \<Rightarrow> nat) \<Rightarrow> _" where
    "gen_isSng sizea s \<equiv> sizea 2 s = 1"

  lemma gen_isSng[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes "GEN_OP sizea op_set_size_abort (Id \<rightarrow> (\<langle>Rk\<rangle>Rs) \<rightarrow> Id)"
    shows "(gen_isSng sizea,op_set_isSng) \<in> \<langle>Rk\<rangle>Rs \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_isSng_def using assms
    unfolding autoref_tag_defs
    apply -
    apply (subst size_abort_isSng)
    apply parametricity
    done

  lemma foldli_disjoint_aux:
    "foldli l1 (\<lambda>x. x) (\<lambda>x _. \<not>x\<in>s2) b \<longleftrightarrow> b \<and> op_set_disjoint (set l1) s2"
    by (induct l1 arbitrary: b) auto

  lemma foldli_disjoint:
    "det_fold_set X (\<lambda>x. x) (\<lambda>x _. \<not>x\<in>s2) True (\<lambda>s1. op_set_disjoint s1 s2)"
    apply rule using foldli_disjoint_aux[where b=True] by simp

  definition gen_disjoint
    :: "_ \<Rightarrow> ('k\<Rightarrow>'s2\<Rightarrow>bool) \<Rightarrow> _"
    where "gen_disjoint it1 mem2 s1 s2
    \<equiv> it1 s1 (\<lambda>x. x) (\<lambda>x _. \<not>mem2 x s2) True"

  lemma gen_disjoint[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 it1)"
    assumes MEM: "GEN_OP mem2 (\<in>) (Rk \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id)"
    shows "(gen_disjoint (\<lambda>x. foldli (it1 x)) mem2,op_set_disjoint)
    \<in> \<langle>Rk\<rangle>Rs1 \<rightarrow> \<langle>Rk\<rangle>Rs2 \<rightarrow> Id"
    apply (intro fun_relI)
    unfolding gen_disjoint_def
    apply (rule det_fold_set[OF foldli_disjoint IT[unfolded autoref_tag_defs]])
    using MEM unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma foldli_filter_aux:
    "foldli l (\<lambda>_. True) (\<lambda>x s. if P x then insert x s else s) s0
    = s0 \<union> op_set_filter P (set l)"
    by (induct l arbitrary: s0) auto

  lemma foldli_filter:
    "det_fold_set X (\<lambda>_. True) (\<lambda>x s. if P x then insert x s else s) {}
      (op_set_filter P)"
    apply rule using foldli_filter_aux[where ?s0.0="{}"] by simp

  definition gen_filter
    where "gen_filter it1 emp2 ins2 P s1 \<equiv>
      it1 s1 (\<lambda>_. True) (\<lambda>x s. if P x then ins2 x s else s) emp2"

  lemma gen_filter[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 it1)"
    assumes INS:
      "GEN_OP ins2 Set.insert (Rk\<rightarrow>\<langle>Rk\<rangle>Rs2\<rightarrow>\<langle>Rk\<rangle>Rs2)"
    assumes EMPTY:
      "GEN_OP empty2 {} (\<langle>Rk\<rangle>Rs2)"
    shows "(gen_filter (\<lambda>x. foldli (it1 x)) empty2 ins2,op_set_filter)
    \<in> (Rk\<rightarrow>Id) \<rightarrow> (\<langle>Rk\<rangle>Rs1) \<rightarrow> (\<langle>Rk\<rangle>Rs2)"
    apply (intro fun_relI)
    unfolding gen_filter_def
    apply (rule det_fold_set[OF foldli_filter IT[unfolded autoref_tag_defs]])
    using INS EMPTY unfolding autoref_tag_defs
    apply (parametricity)+
    done

  lemma foldli_image_aux:
    "foldli l (\<lambda>_. True) (\<lambda>x s. insert (f x) s) s0
    = s0 \<union> f`(set l)"
    by (induct l arbitrary: s0) auto

  lemma foldli_image:
    "det_fold_set X (\<lambda>_. True) (\<lambda>x s. insert (f x) s) {}
      ((`) f)"
    apply rule using foldli_image_aux[where ?s0.0="{}"] by simp

  definition gen_image
    where "gen_image it1 emp2 ins2 f s1 \<equiv>
      it1 s1 (\<lambda>_. True) (\<lambda>x s. ins2 (f x) s) emp2"

  lemma gen_image[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 it1)"
    assumes INS:
      "GEN_OP ins2 Set.insert (Rk'\<rightarrow>\<langle>Rk'\<rangle>Rs2\<rightarrow>\<langle>Rk'\<rangle>Rs2)"
    assumes EMPTY:
      "GEN_OP empty2 {} (\<langle>Rk'\<rangle>Rs2)"
    shows "(gen_image (\<lambda>x. foldli (it1 x)) empty2 ins2,(`))
    \<in> (Rk\<rightarrow>Rk') \<rightarrow> (\<langle>Rk\<rangle>Rs1) \<rightarrow> (\<langle>Rk'\<rangle>Rs2)"
    apply (intro fun_relI)
    unfolding gen_image_def
    apply (rule det_fold_set[OF foldli_image IT[unfolded autoref_tag_defs]])
    using INS EMPTY unfolding autoref_tag_defs
    apply (parametricity)+
    done

  (* TODO: Also do sel! *)

  lemma foldli_pick:
    assumes "l\<noteq>[]"
    obtains x where "x\<in>set l"
    and "(foldli l (case_option True (\<lambda>_. False)) (\<lambda>x _. Some x) None) = Some x"
    using assms by (cases l) auto

  definition gen_pick where
    "gen_pick it s \<equiv>
      (the (it s (case_option True (\<lambda>_. False)) (\<lambda>x _. Some x) None))"

context begin interpretation autoref_syn .
  lemma gen_pick[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT: "SIDE_GEN_ALGO (is_set_to_list Rk Rs it)"
    assumes NE: "SIDE_PRECOND (s'\<noteq>{})"
    assumes SREF: "(s,s')\<in>\<langle>Rk\<rangle>Rs"
    shows "(RETURN (gen_pick (\<lambda>x. foldli (it x)) s),
      (OP op_set_pick ::: \<langle>Rk\<rangle>Rs\<rightarrow>\<langle>Rk\<rangle>nres_rel)$s')\<in>\<langle>Rk\<rangle>nres_rel"
  proof -
    obtain tsl' where
      [param]: "(it s,tsl') \<in> \<langle>Rk\<rangle>list_rel"
      and IT': "RETURN tsl' \<le> it_to_sorted_list (\<lambda>_ _. True) s'"
      using IT[unfolded autoref_tag_defs is_set_to_list_def] SREF
      by (rule is_set_to_sorted_listE)

    from IT' NE have "tsl'\<noteq>[]" and [simp]: "s'=set tsl'"
      unfolding it_to_sorted_list_def by simp_all
    then obtain x where "x\<in>s'" and
      "(foldli tsl' (case_option True (\<lambda>_. False)) (\<lambda>x _. Some x) None) = Some x"
      (is "?fld = _")
      by (blast elim: foldli_pick)
    moreover
    have "(RETURN (gen_pick (\<lambda>x. foldli (it x)) s), RETURN (the ?fld))
      \<in> \<langle>Rk\<rangle>nres_rel"
      unfolding gen_pick_def
      apply (parametricity add: the_paramR)
      using \<open>?fld = Some x\<close>
      by simp
    ultimately show ?thesis
      unfolding autoref_tag_defs
      apply -
      apply (drule nres_relD)
      apply (rule nres_relI)
      apply (erule ref_two_step)
      by simp
  qed
end

  definition gen_Sigma
    where "gen_Sigma it1 it2 empX insX s1 f2 \<equiv>
      it1 s1 (\<lambda>_. True) (\<lambda>x s.
        it2 (f2 x) (\<lambda>_. True) (\<lambda>y s. insX (x,y) s) s
      ) empX
    "

  lemma foldli_Sigma_aux:
    fixes s :: "'s1_impl" and s':: "'k set"
    fixes f :: "'k_impl \<Rightarrow> 's2_impl" and f':: "'k \<Rightarrow> 'l set"
    fixes s0 :: "'kl_impl" and s0' :: "('k\<times>'l) set"
    assumes IT1: "is_set_to_list Rk Rs1 it1"
    assumes IT2: "is_set_to_list Rl Rs2 it2"
    assumes INS:
      "(insX, Set.insert) \<in>
        (\<langle>Rk,Rl\<rangle>prod_rel\<rightarrow>\<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3\<rightarrow>\<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3)"
    assumes S0R: "(s0, s0') \<in> \<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3"
    assumes SR: "(s, s') \<in> \<langle>Rk\<rangle>Rs1"
    assumes FR: "(f, f') \<in> Rk \<rightarrow> \<langle>Rl\<rangle>Rs2"
    shows "(foldli (it1 s) (\<lambda>_. True) (\<lambda>x s.
        foldli (it2 (f x)) (\<lambda>_. True) (\<lambda>y s. insX (x,y) s) s
      ) s0,s0' \<union> Sigma s' f')
      \<in> \<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3"
  proof -
    have S: "\<And>x s f. Sigma (insert x s) f = ({x}\<times>f x) \<union> Sigma s f"
      by auto

    obtain l' where
      IT1L: "(it1 s,l')\<in>\<langle>Rk\<rangle>list_rel"
      and SL: "s' = set l'"
      apply (rule
        is_set_to_sorted_listE[OF IT1[unfolded is_set_to_list_def] SR])
      by (auto simp: it_to_sorted_list_def)

    show ?thesis
      unfolding SL
      using IT1L S0R
    proof (induct arbitrary: s0 s0' rule: list_rel_induct)
      case Nil thus ?case by simp
    next
      case (Cons x x' l l')

      obtain l2' where
        IT2L: "(it2 (f x),l2')\<in>\<langle>Rl\<rangle>list_rel"
        and FXL: "f' x' = set l2'"
        apply (rule
          is_set_to_sorted_listE[
            OF IT2[unfolded is_set_to_list_def], of "f x" "f' x'"
          ])
        apply (parametricity add: Cons.hyps(1) FR)
        by (auto simp: it_to_sorted_list_def)

      have "(foldli (it2 (f x)) (\<lambda>_. True) (\<lambda>y. insX (x, y)) s0,
        s0' \<union> {x'}\<times>f' x') \<in> \<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3"
        unfolding FXL
        using IT2L \<open>(s0, s0') \<in> \<langle>\<langle>Rk, Rl\<rangle>prod_rel\<rangle>Rs3\<close>
        apply (induct  arbitrary: s0 s0' rule: list_rel_induct)
        apply simp
        apply simp
        apply (subst Un_insert_left[symmetric])
        apply (rprems)
        apply (parametricity add: INS \<open>(x,x')\<in>Rk\<close>)
        done

      show ?case
        apply simp
        apply (subst S)
        apply (subst Un_assoc[symmetric])
        apply (rule Cons.hyps)
        apply fact
        done
    qed
  qed

  lemma gen_Sigma[autoref_rules_raw]:
    assumes PRIO_TAG_GEN_ALGO
    assumes IT1: "SIDE_GEN_ALGO (is_set_to_list Rk Rs1 it1)"
    assumes IT2: "SIDE_GEN_ALGO (is_set_to_list Rl Rs2 it2)"
    assumes EMPTY:
      "GEN_OP empX {} (\<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3)"
    assumes INS:
      "GEN_OP insX Set.insert
         (\<langle>Rk,Rl\<rangle>prod_rel\<rightarrow>\<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3\<rightarrow>\<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3)"
    shows "(gen_Sigma (\<lambda>x. foldli (it1 x)) (\<lambda>x. foldli (it2 x)) empX insX,Sigma)
      \<in> (\<langle>Rk\<rangle>Rs1) \<rightarrow> (Rk \<rightarrow> \<langle>Rl\<rangle>Rs2) \<rightarrow> \<langle>\<langle>Rk,Rl\<rangle>prod_rel\<rangle>Rs3"
    apply (intro fun_relI)
    unfolding gen_Sigma_def
    using foldli_Sigma_aux[OF
      IT1[unfolded autoref_tag_defs]
      IT2[unfolded autoref_tag_defs]
      INS[unfolded autoref_tag_defs]
      EMPTY[unfolded autoref_tag_defs]
    ]
    by simp

lemma gen_cart:
  assumes PRIO_TAG_GEN_ALGO
  assumes [param]: "(sigma, Sigma) \<in> (\<langle>Rx\<rangle>Rsx \<rightarrow> (Rx \<rightarrow> \<langle>Ry\<rangle>Rsy) \<rightarrow> \<langle>Rx \<times>\<^sub>r Ry\<rangle>Rsp)"
  shows "(\<lambda>x y. sigma x (\<lambda>_. y), op_set_cart) \<in> \<langle>Rx\<rangle>Rsx \<rightarrow> \<langle>Ry\<rangle>Rsy \<rightarrow> \<langle>Rx \<times>\<^sub>r Ry\<rangle>Rsp"
  unfolding op_set_cart_def[abs_def]
  by parametricity
lemmas [autoref_rules] = gen_cart[OF _ GEN_OP_D]

context begin interpretation autoref_syn .

  lemma op_set_to_sorted_list_autoref[autoref_rules]:
    assumes "SIDE_GEN_ALGO (is_set_to_sorted_list ordR Rk Rs tsl)"
    shows "(\<lambda>si. RETURN (tsl si),  OP (op_set_to_sorted_list ordR))
      \<in> \<langle>Rk\<rangle>Rs \<rightarrow> \<langle>\<langle>Rk\<rangle>list_rel\<rangle>nres_rel"
    using assms
    apply (intro fun_relI nres_relI)
    apply simp
    apply (rule RETURN_SPEC_refine)
    apply (auto simp: is_set_to_sorted_list_def it_to_sorted_list_def)
    done

  lemma op_set_to_list_autoref[autoref_rules]:
    assumes "SIDE_GEN_ALGO (is_set_to_sorted_list ordR Rk Rs tsl)"
    shows "(\<lambda>si. RETURN (tsl si), op_set_to_list)
      \<in> \<langle>Rk\<rangle>Rs \<rightarrow> \<langle>\<langle>Rk\<rangle>list_rel\<rangle>nres_rel"
    using assms
    apply (intro fun_relI nres_relI)
    apply simp
    apply (rule RETURN_SPEC_refine)
    apply (auto simp: is_set_to_sorted_list_def it_to_sorted_list_def)
    done

end

lemma foldli_Union: "det_fold_set X (\<lambda>_. True) (\<union>) {} Union"
proof (rule, goal_cases)
  case (1 l)
  have "\<forall>a. foldli l (\<lambda>_. True) (\<union>) a = a \<union> \<Union>(set l)"
    by (induct l) auto
  thus ?case by auto
qed

definition gen_Union
  :: "_ \<Rightarrow> 's3 \<Rightarrow> ('s2 \<Rightarrow> 's3 \<Rightarrow> 's3)
      \<Rightarrow> 's1 \<Rightarrow> 's3"
  where
  "gen_Union it emp un X \<equiv> it X (\<lambda>_. True) un emp"

lemma gen_Union[autoref_rules_raw]:
  assumes PRIO_TAG_GEN_ALGO
  assumes EMP: "GEN_OP emp {} (\<langle>Rk\<rangle>Rs3)"
  assumes UN: "GEN_OP un (\<union>) (\<langle>Rk\<rangle>Rs2\<rightarrow>\<langle>Rk\<rangle>Rs3\<rightarrow>\<langle>Rk\<rangle>Rs3)"
  assumes IT: "SIDE_GEN_ALGO (is_set_to_list (\<langle>Rk\<rangle>Rs2) Rs1 tsl)"
  shows "(gen_Union (\<lambda>x. foldli (tsl x)) emp un,Union) \<in> \<langle>\<langle>Rk\<rangle>Rs2\<rangle>Rs1 \<rightarrow> \<langle>Rk\<rangle>Rs3"
  apply (intro fun_relI)
  unfolding gen_Union_def
  apply (rule det_fold_set[OF
    foldli_Union IT[unfolded autoref_tag_defs]])
  using EMP UN
  unfolding autoref_tag_defs
  apply (parametricity)+
  done

definition "atLeastLessThan_impl a b \<equiv> do {
  (_,r) \<leftarrow> WHILET (\<lambda>(i,r). i<b) (\<lambda>(i,r). RETURN (i+1, insert i r)) (a,{});
  RETURN r
}"

lemma atLeastLessThan_impl_correct:
  "atLeastLessThan_impl a b \<le> SPEC (\<lambda>r. r = {a..<b::nat})"
  unfolding atLeastLessThan_impl_def
  apply (refine_rcg refine_vcg WHILET_rule[where
    I = "\<lambda>(i,r). r = {a..<i} \<and> a\<le>i \<and> ((a<b \<longrightarrow> i\<le>b) \<and> (\<not>a<b \<longrightarrow> i=a))"
    and R = "measure (\<lambda>(i,_). b - i)"
    ])
  by auto

schematic_goal atLeastLessThan_code_aux:
  notes [autoref_rules] = IdI[of a] IdI[of b]
  assumes [autoref_rules]: "(emp,{})\<in>Rs"
  assumes [autoref_rules]: "(ins,insert)\<in>nat_rel \<rightarrow> Rs \<rightarrow> Rs"
  shows "(?c, atLeastLessThan_impl)
  \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> \<langle>Rs\<rangle>nres_rel"
  unfolding atLeastLessThan_impl_def[abs_def]
  apply (autoref (keep_goal))
  done
concrete_definition atLeastLessThan_code uses atLeastLessThan_code_aux

schematic_goal atLeastLessThan_tr_aux:
  "RETURN ?c \<le> atLeastLessThan_code emp ins a b"
  unfolding atLeastLessThan_code_def
  by (refine_transfer (post))
concrete_definition atLeastLessThan_tr
  for emp ins a b uses atLeastLessThan_tr_aux

lemma atLeastLessThan_gen[autoref_rules]:
  assumes "PRIO_TAG_GEN_ALGO"
  assumes "GEN_OP emp {} Rs"
  assumes "GEN_OP ins insert (nat_rel \<rightarrow> Rs \<rightarrow> Rs)"
  shows "(atLeastLessThan_tr emp ins, atLeastLessThan)
    \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> Rs"
proof (intro fun_relI, simp)
  fix a b
  from assms have GEN:
    "(emp,{})\<in>Rs" "(ins,insert)\<in>nat_rel \<rightarrow> Rs \<rightarrow> Rs"
    by auto

  note atLeastLessThan_tr.refine[of emp ins a b]
  also note
    atLeastLessThan_code.refine[OF GEN,param_fo, OF IdI IdI, THEN nres_relD]
  also note atLeastLessThan_impl_correct
  finally show "(atLeastLessThan_tr emp ins a b, {a..<b}) \<in> Rs"
    by (auto simp: pw_le_iff refine_pw_simps)
qed

end


(*<*)
(*
 * The Maybe monad.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory Maybe
imports HOLCF
begin
(*>*)

section\<open>The \<open>'a Maybe\<close> Monad\<close>

text\<open>This section defines the monadic machinery for the \<open>'a
Maybe\<close> type. @{term "return"} is @{term "Just"}.\<close>

domain 'a Maybe = Nothing | Just (lazy "'a")

definition
  mfail :: "'a Maybe"
where
  "mfail \<equiv> Nothing"

definition
  mcatch :: "'a Maybe \<rightarrow> 'a Maybe \<rightarrow> 'a Maybe"
where
  "mcatch \<equiv> \<Lambda> body handler. case body of Nothing \<Rightarrow> handler | Just\<cdot>x \<Rightarrow> Just\<cdot>x"

lemma mcatch_strict[simp]: "mcatch\<cdot>\<bottom> = \<bottom>"
  by (rule cfun_eqI, simp add: mcatch_def)

definition
  mbind :: "'a Maybe \<rightarrow> ('a \<rightarrow> 'b Maybe) \<rightarrow> 'b Maybe" where
  "mbind \<equiv> \<Lambda> f g. (case f of Nothing \<Rightarrow> Nothing | Just\<cdot>f' \<Rightarrow> g\<cdot>f')"

abbreviation
  mbind_syn :: "'a Maybe \<Rightarrow> ('a \<rightarrow> 'b Maybe) \<Rightarrow> 'b Maybe" (infixl ">>=\<^sub>M" 55) where
  "f >>=\<^sub>M g \<equiv> mbind\<cdot>f\<cdot>g"

lemma mbind_strict1[simp]: "\<bottom> >>=\<^sub>M g = \<bottom>" by (simp add: mbind_def)

text\<open>The standard monad laws.\<close>

lemma leftID[simp]: "Just\<cdot>a >>=\<^sub>M f = f\<cdot>a" by (simp add: mbind_def)
lemma rightID[simp]: "m >>=\<^sub>M Just = m" by (cases m, simp_all add: mbind_def)

lemma assoc[simp]: "(m >>=\<^sub>M f) >>=\<^sub>M g = m >>=\<^sub>M (\<Lambda> x. f\<cdot>x >>=\<^sub>M g)"
  by (cases m, simp_all add: mbind_def)

text\<open>Reduction for the Maybe monad.\<close>

lemma nothing_bind[simp]: "Nothing >>=\<^sub>M f = Nothing" by (simp add: mbind_def)
lemma just_bind[simp]: "Just\<cdot>x >>=\<^sub>M f = f\<cdot>x" by (simp add: mbind_def)

definition
  mliftM2 :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<Rightarrow> 'a Maybe \<rightarrow> 'b Maybe \<rightarrow> 'c Maybe" where
  "mliftM2 f \<equiv> \<Lambda> x y. x >>=\<^sub>M (\<Lambda> x'. y >>=\<^sub>M (\<Lambda> y'. Just\<cdot>(f\<cdot>x'\<cdot>y')))"

lemma mliftM2_Nothing1[simp]: "mliftM2 f\<cdot>Nothing\<cdot>y = Nothing" by (simp add: mliftM2_def)
lemma mliftM2_Nothing2[simp]: "mliftM2 f\<cdot>(Just\<cdot>x)\<cdot>Nothing = Nothing" by (simp add: mliftM2_def)
lemma mliftM2_op[simp]: "mliftM2 f\<cdot>(Just\<cdot>x)\<cdot>(Just\<cdot>y) = Just\<cdot>(f\<cdot>x\<cdot>y)" by (simp add: mliftM2_def)

lemma mliftM2_strict1[simp]: "mliftM2 f\<cdot>\<bottom> = \<bottom>" by (rule cfun_eqI)+ (simp add: mliftM2_def)
lemma mliftM2_strict2[simp]: "mliftM2 f\<cdot>(Just\<cdot>x)\<cdot>\<bottom> = \<bottom>" by (simp add: mliftM2_def)

end


(******************************************************************************)
(* Project: Isabelle/UTP: Unifying Theories of Programming in Isabelle/HOL    *)
(* File: Typedep.thy                                                          *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@gmail.com and simon.foster@york.ac.uk                  *)
(******************************************************************************)
(* LAST REVIEWED: 09 Jan 2022 *)

section \<open>Type Dependency\<close>

theory Typedep
imports HOL.Typerep
  Typerep_ind Named_Attrib
begin

subsection \<open>Theorem Attribute\<close>

text \<open>Attribute collecting theorems to reason about type dependencies.\<close>

named_theorems typedep "typedep theorems"

ML \<open>
  structure typedep = Named_Attrib(val name = @{named_theorems typedep});
\<close>

subsection \<open>Class @{text typedep}\<close>

class typedep = typerep +
  fixes typedep :: "'a itself \<Rightarrow> typerep set"

subsection \<open>Syntax\<close>

syntax "_TYPEDEP" :: "type \<Rightarrow> logic"  ("(1TYPEDEP/(1'(_')))")

translations "TYPEDEP('a)" \<rightleftharpoons> "(CONST typedep) TYPE('a)"

subsection \<open>Instantiations\<close>

text \<open>
  We require a few instantiations of ground types i.e.~types not created by
  virtue of a @{text typedef}). Namely, these are @{type bool}, @{type ind},
  @{type fun} and @{type set}. All other types in HOL are derived through type
  definitions and hence we obtain instantiations of @{class typedep} by the
  type interpretation that we subsequently configure.
\<close>

instantiation ind :: typedep
begin
definition typedep_ind :: "ind itself \<Rightarrow> typerep set" where
"typedep_ind t = {TYPEREP(ind)}"
instance by (intro_classes)
end

instantiation bool :: typedep
begin
definition typedep_bool :: "bool itself \<Rightarrow> typerep set" where
"typedep_bool t = {TYPEREP(bool)}"
instance by (intro_classes)
end

instantiation "fun" :: (typedep, typedep) typedep
begin
definition typedep_fun :: "('a \<Rightarrow> 'b) itself \<Rightarrow> typerep set" where
"typedep_fun t = TYPEDEP('a) \<union> TYPEDEP('b)"
instance by (intro_classes)
end

instantiation set :: (typedep) typedep
begin
definition typedep_set :: "'a set itself \<Rightarrow> typerep set" where
"typedep_set t = TYPEDEP('a)"
instance by (intro_classes)
end

subsection \<open>Proof Support\<close>

declare typedep_ind_def [typedep]
declare typedep_bool_def [typedep]
declare typedep_fun_def [typedep]
declare typedep_set_def [typedep]

subsection \<open>Interpretation\<close>

text \<open>
  We next configure a mechanism that instantiates the class @{class typedep}
  automatically for any existing or new type definition. This is done via an
  interpretation of a @{text typedef}. Correct instantiation is crucial since
  the soundness of the axiomatic UTP value model relies on it. We hence must
  not delegate this task to the user to avoid any risk of inconsistencies.
\<close>

text \<open>The following rewrites could be done generically by a conversion.\<close>

theorem insert_dup_simps:
"(insert x (insert x S)) = (insert x S)"
"(insert x (insert a (insert x S))) =
 (insert x (insert a S))"
"(insert x (insert a (insert b (insert x S)))) =
 (insert x (insert a (insert b S)))"
"(insert x (insert a (insert b (insert c (insert x S))))) =
 (insert x (insert a (insert b (insert c S))))"
"(insert x (insert a (insert b (insert c (insert d (insert x S)))))) =
 (insert x (insert a (insert b (insert c (insert d S)))))"
"(insert x (insert a (insert b (insert c (insert d (insert e (insert x S))))))) =
 (insert x (insert a (insert b (insert c (insert d (insert e S))))))"
apply (auto)
done

theorem union_dup_simps:
"A \<union> A = A"
"A \<union> (B \<union> C) = A \<union> B \<union> C"
"A \<union> B \<union> A = A \<union> B"
"A \<union> B \<union> C \<union> A = A \<union> B \<union> C"
"A \<union> B \<union> C \<union> D \<union> A = A \<union> B \<union> C \<union> D"
"A \<union> B \<union> C \<union> D \<union> E \<union> A = A \<union> B \<union> C \<union> D \<union> E"
"X \<union> A \<union> B \<union> A = X \<union> A \<union> B"
"X \<union> A \<union> B \<union> C \<union> A = X \<union> A \<union> B \<union> C"
"X \<union> A \<union> B \<union> C \<union> D \<union> A = X \<union> A \<union> B \<union> C \<union> D"
"X \<union> A \<union> B \<union> C \<union> D \<union> E \<union> A = X \<union> A \<union> B \<union> C \<union> D \<union> E"
apply (auto)
done

ML_file "Typedep.ML"

setup \<open>
  (Typedef.interpretation
    (Local_Theory.background_theory o Typedep.ensure_typedep))
\<close>

subsection \<open>Proof Optimisation\<close>

text \<open>
  It turns out that instantiation proofs of class @{text injectable} can be
  very slow due to large terms arising if we use the @{text "typedep_..._def"}
  theorems directly. This only became noticeable since Isabelle 2015, which is
  presumably due to a more complex type models for datatypes. To overcome this
  issue, what we store in the @{text typedep} attribute are theorems that have
  in fact already been simplified, in the first instance by expanding earlier
  definitions of @{const typedep} and secondly by using the laws provided by
  @{thm [source] insert_dup_simps} and @{thm [source] union_dup_simps}. Hence,
  the theorems in @{attribute typedep} are not the raw definitional axioms but
  proved lemmas that follow from them.
\<close>

declare [[show_types]]

thm typedep

declare [[show_types=false]]
end


chapter {* Define correspondence between a non-deterministic monad with failure,
  and a C-SIMP computation *}

theory ComCorres
imports
  CorresExtras
  NondetExtensions
  ComExtensions
begin

lemma corres_refines[dest]:
  fixes C A st rx P m\<^sub>A m\<^sub>C \<Gamma>
  assumes ndA: "Run A = lift_nd m\<^sub>A"
      and comC: "Run C = lift_com m\<^sub>C \<Gamma>"
      and init: "\<forall>s s\<^sub>C. s\<^sub>C \<in> Init C s \<longrightarrow> P s\<^sub>C \<and> \<not> snd (m\<^sub>A (st s\<^sub>C)) \<and> st s\<^sub>C \<in> Init A s"
      and corres: "ac_corres st \<Gamma> rx P m\<^sub>A m\<^sub>C"
      and fin: "\<forall>s\<^sub>C'. Fin A (st s\<^sub>C') = Fin C s\<^sub>C'"
  shows "C \<sqsubseteq> A"
unfolding refines_def
proof clarify
  fix s s'
  assume "s' \<in> execution C s"
  hence "s' \<in> Fin C ` Run C `` Init C s" unfolding execution_def .
  hence "\<exists>s\<^sub>C s\<^sub>C'. s\<^sub>C \<in> Init C s \<and> (s\<^sub>C, s\<^sub>C') \<in> Run C \<and> (s' = Fin C s\<^sub>C')" by auto
  then obtain s\<^sub>C and s\<^sub>C' where i: "s\<^sub>C \<in> Init C s" and r: "(s\<^sub>C, s\<^sub>C') \<in> Run C"
    and f: "s' = Fin C s\<^sub>C'" by auto
  let ?s\<^sub>A = "st s\<^sub>C" and ?s\<^sub>A' = "st s\<^sub>C'" and ?r\<^sub>A' = "rx s\<^sub>C'"
  from i and init have "P s\<^sub>C" and "\<not> snd (m\<^sub>A ?s\<^sub>A)" and "?s\<^sub>A \<in> Init A s" by auto
  with corres have corr: "\<forall>t. \<Gamma> \<turnstile> \<langle>m\<^sub>C, Normal s\<^sub>C\<rangle> \<Rightarrow> t \<longrightarrow>
           (\<exists>s\<^sub>C'. t = Normal s\<^sub>C' \<and> (Inr (rx s\<^sub>C'), st s\<^sub>C') \<in> fst (m\<^sub>A ?s\<^sub>A))" and
           "\<Gamma> \<turnstile> m\<^sub>C \<down> Normal s\<^sub>C" unfolding ac_corres_def by auto
  from r and comC have "\<Gamma>\<turnstile> \<langle>m\<^sub>C, Normal s\<^sub>C\<rangle> \<Rightarrow> Normal s\<^sub>C'" unfolding lift_com_def by simp
  with corr have "(Inr ?r\<^sub>A', ?s\<^sub>A') \<in> fst (m\<^sub>A ?s\<^sub>A)" by auto
  hence "(?s\<^sub>A, ?s\<^sub>A') \<in> Run A" using ndA unfolding lift_nd_def by auto
  moreover from i and init have "?s\<^sub>A \<in> Init A s" by auto
  moreover from fin have "Fin A ?s\<^sub>A' = Fin C s\<^sub>C'" ..
  ultimately show "s' \<in> execution A s" using f unfolding execution_def
    by (metis ImageI imageI)
qed

end