section\<open>Aids to internalize formulas\<close>
theory Internalizations
  imports
    "ZF-Constructible.DPow_absolute"
begin

text\<open>We found it useful to have slightly different versions of some
results in ZF-Constructible:\<close>
lemma nth_closed :
  assumes "0\<in>A" "env\<in>list(A)"
  shows "nth(n,env)\<in>A"
  using assms(2,1) unfolding nth_def by (induct env; simp)

lemmas FOL_sats_iff = sats_Nand_iff sats_Forall_iff sats_Neg_iff sats_And_iff
  sats_Or_iff sats_Implies_iff sats_Iff_iff sats_Exists_iff

lemma nth_ConsI: "\<lbrakk>nth(n,l) = x; n \<in> nat\<rbrakk> \<Longrightarrow> nth(succ(n), Cons(a,l)) = x"
by simp

lemmas nth_rules = nth_0 nth_ConsI nat_0I nat_succI
lemmas sep_rules = nth_0 nth_ConsI FOL_iff_sats function_iff_sats
                   fun_plus_iff_sats successor_iff_sats
                    omega_iff_sats FOL_sats_iff Replace_iff_sats

text\<open>Also a different compilation of lemmas (term\<open>sep_rules\<close>) used in formula
 synthesis\<close>
lemmas fm_defs = omega_fm_def limit_ordinal_fm_def empty_fm_def typed_function_fm_def
                 pair_fm_def upair_fm_def domain_fm_def function_fm_def succ_fm_def
                 cons_fm_def fun_apply_fm_def image_fm_def big_union_fm_def union_fm_def
                 relation_fm_def composition_fm_def field_fm_def ordinal_fm_def range_fm_def
                 transset_fm_def subset_fm_def Replace_fm_def

end


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

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun filter :: "('a => bool) => 'a list => 'a list" where
  "filter y (nil2) = nil2"
| "filter y (cons2 z2 xs) =
     (if y z2 then cons2 z2 (filter y xs) else filter y xs)"

theorem property0 :
  "((filter p (x xs ys)) = (x (filter p xs) (filter p ys)))"
  oops

end


(*  Title:      HOL/Isar_Examples/Peirce.thy
    Author:     Markus Wenzel, TU Muenchen
*)

section \<open>Peirce's Law\<close>

theory Peirce
imports Main
begin

text \<open>We consider Peirce's Law: $((A \impl B) \impl A) \impl A$.
  This is an inherently non-intuitionistic statement, so its proof
  will certainly involve some form of classical contradiction.

  The first proof is again a well-balanced combination of plain
  backward and forward reasoning.  The actual classical step is where
  the negated goal may be introduced as additional assumption.  This
  eventually leads to a contradiction.\footnote{The rule involved
  there is negation elimination; it holds in intuitionistic logic as
  well.}\<close>

theorem "((A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A"
proof
  assume "(A \<longrightarrow> B) \<longrightarrow> A"
  show A
  proof (rule classical)
    assume "\<not> A"
    have "A \<longrightarrow> B"
    proof
      assume A
      with \<open>\<not> A\<close> show B by contradiction
    qed
    with \<open>(A \<longrightarrow> B) \<longrightarrow> A\<close> show A ..
  qed
qed

text \<open>In the subsequent version the reasoning is rearranged by means
  of ``weak assumptions'' (as introduced by \isacommand{presume}).
  Before assuming the negated goal $\neg A$, its intended consequence
  $A \impl B$ is put into place in order to solve the main problem.
  Nevertheless, we do not get anything for free, but have to establish
  $A \impl B$ later on.  The overall effect is that of a logical
  \emph{cut}.

  Technically speaking, whenever some goal is solved by
  \isacommand{show} in the context of weak assumptions then the latter
  give rise to new subgoals, which may be established separately.  In
  contrast, strong assumptions (as introduced by \isacommand{assume})
  are solved immediately.\<close>

theorem "((A \<longrightarrow> B) \<longrightarrow> A) \<longrightarrow> A"
proof
  assume "(A \<longrightarrow> B) \<longrightarrow> A"
  show A
  proof (rule classical)
    presume "A \<longrightarrow> B"
    with \<open>(A \<longrightarrow> B) \<longrightarrow> A\<close> show A ..
  next
    assume "\<not> A"
    show "A \<longrightarrow> B"
    proof
      assume A
      with \<open>\<not> A\<close> show B by contradiction
    qed
  qed
qed

text \<open>Note that the goals stemming from weak assumptions may be even
  left until qed time, where they get eventually solved ``by
  assumption'' as well.  In that case there is really no fundamental
  difference between the two kinds of assumptions, apart from the
  order of reducing the individual parts of the proof configuration.

  Nevertheless, the ``strong'' mode of plain assumptions is quite
  important in practice to achieve robustness of proof text
  interpretation.  By forcing both the conclusion \emph{and} the
  assumptions to unify with the pending goal to be solved, goal
  selection becomes quite deterministic.  For example, decomposition
  with rules of the ``case-analysis'' type usually gives rise to
  several goals that only differ in there local contexts.  With strong
  assumptions these may be still solved in any order in a predictable
  way, while weak ones would quickly lead to great confusion,
  eventually demanding even some backtracking.\<close>

end


(*<*)
theory TAO_3_Quantifiable
imports TAO_2_Semantics
begin
(*>*)

section\<open>General Quantification\<close>
text\<open>\label{TAO_Quantifiable}\<close>

text\<open>
\begin{remark}
  In order to define general quantifiers that can act
  on individuals as well as relations a type class
  is introduced which assumes the semantics of the all quantifier.
  This type class is then instantiated for individuals and
  relations.
\end{remark}
\<close>

subsection\<open>Type Class\<close>
text\<open>\label{TAO_Quantifiable_Class}\<close>

class quantifiable = fixes forall :: "('a\<Rightarrow>\<o>)\<Rightarrow>\<o>" (binder "\<^bold>\<forall>" [8] 9)
  assumes quantifiable_T8: "(w \<Turnstile> (\<^bold>\<forall> x . \<psi> x)) = (\<forall> x . (w \<Turnstile> (\<psi> x)))"
begin
end

lemma (in Semantics) T8: shows "(w \<Turnstile> \<^bold>\<forall> x . \<psi> x) = (\<forall> x . (w \<Turnstile> \<psi> x))"
  using quantifiable_T8 .

subsection\<open>Instantiations\<close>
text\<open>\label{TAO_Quantifiable_Instantiations}\<close>

instantiation \<nu> :: quantifiable
begin
  definition forall_\<nu> :: "(\<nu>\<Rightarrow>\<o>)\<Rightarrow>\<o>" where "forall_\<nu> \<equiv> forall\<^sub>\<nu>"
  instance proof
    fix w :: i and \<psi> :: "\<nu>\<Rightarrow>\<o>"
    show "(w \<Turnstile> \<^bold>\<forall>x. \<psi> x) = (\<forall>x. (w \<Turnstile> \<psi> x))"
      unfolding forall_\<nu>_def using Semantics.T8_\<nu> .
  qed
end

instantiation \<o> :: quantifiable
begin
  definition forall_\<o> :: "(\<o>\<Rightarrow>\<o>)\<Rightarrow>\<o>" where "forall_\<o> \<equiv> forall\<^sub>\<o>"
  instance proof
    fix w :: i and \<psi> :: "\<o>\<Rightarrow>\<o>"
    show "(w \<Turnstile> \<^bold>\<forall>x. \<psi> x) = (\<forall>x. (w \<Turnstile> \<psi> x))"
      unfolding forall_\<o>_def using Semantics.T8_\<o> .
  qed
end

instantiation \<Pi>\<^sub>1 :: quantifiable
begin
  definition forall_\<Pi>\<^sub>1 :: "(\<Pi>\<^sub>1\<Rightarrow>\<o>)\<Rightarrow>\<o>" where "forall_\<Pi>\<^sub>1 \<equiv> forall\<^sub>1"
  instance proof
    fix w :: i and \<psi> :: "\<Pi>\<^sub>1\<Rightarrow>\<o>"
    show "(w \<Turnstile> \<^bold>\<forall>x. \<psi> x) = (\<forall>x. (w \<Turnstile> \<psi> x))"
      unfolding forall_\<Pi>\<^sub>1_def using Semantics.T8_1 .
  qed
end

instantiation \<Pi>\<^sub>2 :: quantifiable
begin
  definition forall_\<Pi>\<^sub>2 :: "(\<Pi>\<^sub>2\<Rightarrow>\<o>)\<Rightarrow>\<o>" where "forall_\<Pi>\<^sub>2 \<equiv> forall\<^sub>2"
  instance proof
    fix w :: i and \<psi> :: "\<Pi>\<^sub>2\<Rightarrow>\<o>"
    show "(w \<Turnstile> \<^bold>\<forall>x. \<psi> x) = (\<forall>x. (w \<Turnstile> \<psi> x))"
      unfolding forall_\<Pi>\<^sub>2_def using Semantics.T8_2 .
  qed
end

instantiation \<Pi>\<^sub>3 :: quantifiable
begin
  definition forall_\<Pi>\<^sub>3 :: "(\<Pi>\<^sub>3\<Rightarrow>\<o>)\<Rightarrow>\<o>" where "forall_\<Pi>\<^sub>3 \<equiv> forall\<^sub>3"
  instance proof
    fix w :: i and \<psi> :: "\<Pi>\<^sub>3\<Rightarrow>\<o>"
    show "(w \<Turnstile> \<^bold>\<forall>x. \<psi> x) = (\<forall>x. (w \<Turnstile> \<psi> x))"
      unfolding forall_\<Pi>\<^sub>3_def using Semantics.T8_3 .
  qed
end

(*<*)
end
(*>*)


(*  File:       Borda_Module_Ref.thy
    Copyright   2023  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Valentin Springsklee, Karlsruhe Institute of Technology (KIT)"\<close>

chapter \<open>Refined Basic Modules\<close>

theory Borda_Module_Ref
  imports "Verified_Voting_Rule_Construction.Borda_Module"
           "Component_Types/Elimination_Module_Ref"
begin

section \<open>Refined Borda Module\<close>

subsection \<open>Definition\<close>

definition borda_score_mon :: "'a::{default, heap, hashable} Evaluation_Function_Ref" where
  "borda_score_mon x A p =
    sum_impl (prefer_count_monadic_imp p x) A"

fun borda_score_l :: "'a  \<Rightarrow> 'a set \<Rightarrow> 'a Profile_List \<Rightarrow> nat" where
  "borda_score_l x A p = (\<Sum> y \<in> A. (prefer_count_l p x y))"

lemma borda_score_l_eq:
  fixes A:: "'a::{default, heap, hashable} set"
  fixes pl:: "'a Profile_List" and pr:: "'a Profile"
  assumes
    fina: "finite A"
    and profrel: "(pl, pr) \<in> profile_rel"
    and profl: "profile_l A pl"
  shows "borda_score_l x A pl = borda_score x A pr"
  unfolding borda_score_l.simps borda_score.simps
  using profrel
    prefer_count_l_eq
  by (metis)

subsection \<open>Optimized Monadic Score Computation\<close>

definition borda_score_opt_mon :: "'a::{default, heap, hashable} Evaluation_Function_Ref" where
  "borda_score_opt_mon a A p =
     nfoldli p (\<lambda>_.True) (\<lambda> x ac.
        do {
         ra \<leftarrow> index_mon x a;
         let bordac = length x - ra;
         RETURN  (ac + bordac)
    }) (0::nat)"

sepref_definition opt_bsc is "uncurry2 borda_score_opt_mon"
  :: "nat_assn\<^sup>k *\<^sub>a (hs.assn nat_assn)\<^sup>k *\<^sub>a (profile_impl_assn nat_assn)\<^sup>k \<rightarrow>\<^sub>a nat_assn"
  unfolding borda_score_opt_mon_def
  by sepref

definition borda_ref :: "'a::{default, heap, hashable} Electoral_Module_Ref" where
  "borda_ref A pl \<equiv> do {
   scores \<leftarrow> (pre_compute_scores borda_score_mon A pl);
   max_eliminator_ref scores A pl
}"

definition borda_ref_opt :: "'a::{default, heap, hashable} Electoral_Module_Ref" where
  "borda_ref_opt A pl \<equiv> do {
   scores \<leftarrow> (pre_compute_scores borda_score_opt_mon A pl);
   max_eliminator_ref scores A pl
}"

subsection \<open>Refinement Lemmas\<close>

lemma borda_score_correct:
  fixes A:: "'a::{default, heap, hashable} set"
  fixes pl:: "'a Profile_List" and pr:: "'a Profile"
  assumes
    fina: "finite A"
    and profrel: "(pl, pr) \<in> profile_rel"
  shows "\<forall> a \<in> A. borda_score_mon a A pl \<le> SPEC (\<lambda> sc. sc = (borda_score a A pr))"
  unfolding borda_score_mon_def borda_score.simps
  apply safe
  apply (refine_vcg sum_impl_correct fina prefer_count_monadic_imp_correct profrel)
  done

lemma borda_score_opt_refine:
  fixes A:: "'a::{default, heap, hashable} set"
  fixes pl:: "'a Profile_List"
  assumes
    fina: "finite A"
    and profl: "profile_l A pl"
  shows "\<forall> a \<in> A. borda_score_opt_mon a A pl  \<le> SPEC (\<lambda> sc. sc = (borda_score_l a A pl))"
proof (unfold  borda_score_opt_mon_def, safe)
  fix a :: 'a
  assume aA: "a \<in> A"
  show "nfoldli pl (\<lambda>_. True)
          (\<lambda>x ac. index_mon x a \<bind> (\<lambda>ra. let bordac = length x - ra in RETURN (ac + bordac))) 0
         \<le> SPEC (\<lambda>sc. sc = borda_score_l a A pl)"
    apply (refine_vcg index_mon_correct nfoldli_rule[where I = "\<lambda> p1 p2 x.
    (x = borda_score_l a A p1)"])
    subgoal by auto
    unfolding  rank_l.simps profile_l_def
      well_formed_pl_def losimp  apply (auto simp del: borda_score_l.simps)
  proof -
    fix x :: "'a Preference_List"
    fix l1 l2 :: "'a Profile_List"
    assume xpl: "pl = l1 @ x # l2"
    from xpl have idxx: "\<exists> i < length pl. x = pl!i"
      apply (rule_tac x="length l1" in exI) by auto
    from idxx have lox: "set x = A"
      using profl unfolding profile_l_def well_formed_pl_def losimp by auto
    from idxx have disx: "distinct x"
      using profl unfolding profile_l_def well_formed_pl_def by auto
    from lox disx fina have lengtheq: "length x = card A"
      using distinct_card by fastforce
    have validc: "(length x - index x a) = borda_score_l a A ([x])"
      using aA disx unfolding lox[symmetric]
    proof (induction "x" arbitrary: a)
      case Nil
      then show ?case by auto
    next
      case ih: (Cons newa x)
      show ?case
      proof (cases "a = newa")
        case aeqna: True
        from aeqna ih(3) have "borda_score_l a (set (newa # x)) [newa # x] = length (newa # x)"
          apply clarsimp
          using distinct_card by blast
        from this aeqna show ?thesis
          by (simp)
      next
        case aneqna: False
        then have nseq: "length (newa # x) - index (newa # x) a = length (x) - index (x) a"
          by auto
        from aneqna have "borda_score_l a (set (newa # x)) [newa # x] =
                        borda_score_l a (set (x)) [x]" apply auto
          by (smt (verit, del_insts) List.finite_set ab_semigroup_add_class.add.commute add.right_neutral add_le_cancel_right bot_nat_0.not_eq_extremum distinct.simps(2) ih.prems(2) less_or_eq_imp_le linorder_not_le plus_1_eq_Suc sum.cong sum.insert)
        from this nseq ih.IH ih.prems(1) ih.prems(2) show ?thesis
          by (metis aneqna distinct.simps(2) set_ConsD)
      qed
    qed
    have "\<forall> b \<in> A. prefer_count_l (l1 @ [x]) a b = prefer_count_l (l1) a b  + prefer_count_l ([x]) a b"
      by auto
    from this have "borda_score_l a A (l1 @ [x]) = borda_score_l a A (l1) + borda_score_l a A ([x])"
      apply (auto simp del: prefer_count_l.simps)
      using sum.distrib by blast
    from this show " borda_score_l a A l1 + (length x - index x a) = borda_score_l a A (l1 @ [x])"
      unfolding validc by simp
  qed
qed

lemma borda_score_opt_correct:
    fixes A:: "'a::{default, heap, hashable} set"
 fixes pl:: "'a Profile_List" and pr:: "'a Profile"
  assumes
    fina: "finite A"
    and profrel: "(pl, pr) \<in> profile_rel"
    and profl: "profile A pr"
  shows "\<forall> a \<in> A. borda_score_opt_mon a A pl  \<le> SPEC (\<lambda> sc. sc = (borda_score a A pr))"
using  borda_score_opt_refine assms borda_score_l_eq profile_ref
  by (metis)

lemma borda_ref_correct:
  shows "(uncurry borda_ref, uncurry (RETURN oo borda)) \<in>
  [\<lambda> (A, _). finite A]\<^sub>f (\<langle>Id\<rangle>set_rel \<times>\<^sub>r profile_rel)
  \<rightarrow> \<langle>\<langle>Id\<rangle>set_rel \<times>\<^sub>r \<langle>Id\<rangle>set_rel \<times>\<^sub>r \<langle>Id\<rangle>set_rel\<rangle>nres_rel"
proof (intro frefI nres_relI, clarsimp simp del: max_eliminator.simps, rename_tac A pl pr)
  fix A:: "'a set"
  fix pl :: "'a Profile_List"
  fix pr :: "'a Profile"
  assume prel: " (pl, pr) \<in> profile_rel"
  assume fina: "finite A"
  show "borda_ref A pl \<le> RETURN (max_eliminator borda_score A pr)"
    unfolding borda_ref_def RETURN_SPEC_conv
    by (refine_vcg borda_score_correct max_eliminator_ref_correct_default fina prel)
qed

definition pre_compute_borda_scores :: "'a set
   \<Rightarrow> 'a Profile_List \<Rightarrow> 'a Scores_Map nres"
  where "pre_compute_borda_scores A pl \<equiv>
  if (op_set_is_empty A) then RETURN Map.empty else
  do {
   zeromap:: 'a Scores_Map  \<leftarrow> init_map A;
  nfoldli pl (\<lambda>_. True)
    (\<lambda>ballot map.
       nfoldli ballot (\<lambda>_. True)
        (\<lambda>a map. do { ASSERT (op_map_contains_key a map);
      let scx = the (op_map_lookup a map);
        RETURN (op_map_update a (scx + (length ballot - index ballot a)) map)}) map)
     (zeromap)}"

lemma borda_ref_opt_correct:
  shows "(uncurry borda_ref_opt, uncurry (RETURN oo borda)) \<in>
  [\<lambda> (A, p). finite_profile A p]\<^sub>f (\<langle>Id\<rangle>set_rel \<times>\<^sub>r profile_rel)
  \<rightarrow> \<langle>\<langle>Id\<rangle>set_rel \<times>\<^sub>r \<langle>Id\<rangle>set_rel \<times>\<^sub>r \<langle>Id\<rangle>set_rel\<rangle>nres_rel"
proof (intro frefI nres_relI, clarsimp simp del: max_eliminator.simps, rename_tac A pl pr)
  fix A:: "'a set"
  fix pl :: "'a Profile_List"
  fix pr :: "'a Profile"
  assume prel: " (pl, pr) \<in> profile_rel"
  assume fina: "finite A"
  assume profp: "profile A pr"
  show "borda_ref_opt A pl \<le> RETURN (max_eliminator borda_score A pr)"  unfolding borda_ref_opt_def RETURN_SPEC_conv
   by (refine_vcg borda_score_opt_correct max_eliminator_ref_correct_default fina profp prel)
qed

subsection \<open>Imperative HOL Synthesis Using Sepref\<close>

sepref_definition borda_elim_sep_opt is
  "uncurry borda_ref_opt"::
    "(alts_set_impl_assn id_assn)\<^sup>k *\<^sub>a (profile_impl_assn id_assn)\<^sup>k
   \<rightarrow>\<^sub>a (result_impl_assn id_assn)"
  unfolding borda_ref_opt_def  max_eliminator_ref_def borda_score_opt_mon_def sum_impl_def
    less_eliminator_ref_def  elimination_module_ref_def[abs_def] eliminate_def[abs_def]
    pre_compute_scores_def[abs_def] scoremax_def[abs_def]
  apply (rewrite in "FOREACH _ _ rewrite_HOLE" hm.fold_custom_empty)
  apply (rewrite in "FOREACH _ _ rewrite_HOLE" hs.fold_custom_empty)
  apply (rewrite in "FOREACH _ _ rewrite_HOLE" hs.fold_custom_empty)
  apply (rewrite in "RETURN ({}, {}, rewrite_HOLE)" hs.fold_custom_empty)
  apply (rewrite in "RETURN ({}, rewrite_HOLE, _)" hs.fold_custom_empty)
  apply (rewrite in "RETURN ( rewrite_HOLE, _, _)" hs.fold_custom_empty)
  apply (rewrite in "_ \<bind> (\<lambda>(rej, def). if def = {} then RETURN (rewrite_HOLE, _, rej) else RETURN ({}, rej, def))" hs.fold_custom_empty)
  apply (rewrite in "_ \<bind> (\<lambda>(rej, def). if def = {} then RETURN (_, rewrite_HOLE, rej) else RETURN ({}, rej, def))" hs.fold_custom_empty)
  apply (rewrite in "_ \<bind> (\<lambda>(rej, def). if def = {} then RETURN (_, _, rej) else RETURN (rewrite_HOLE, rej, def))" hs.fold_custom_empty)
  apply sepref_dbg_keep
  done

lemma  borda_elim_sep_opt_correct:
  shows "(uncurry borda_elim_sep_opt, uncurry (RETURN \<circ>\<circ> borda))
    \<in> elec_mod_seprel id_assn"
  using borda_elim_sep_opt.refine[FCOMP borda_ref_opt_correct, THEN hfrefD] apply (intro hfrefI)
  using set_rel_id hr_comp_Id2 unfolding ballot_assn_def  by (simp)

declare borda_elim_sep_opt_correct [sepref_fr_rules]

end


(*  Title:      HOL/Library/Function_Division.thy
    Author:     Florian Haftmann, TUM
*)

section \<open>Pointwise instantiation of functions to division\<close>

theory Function_Division
imports Function_Algebras
begin

subsection \<open>Syntactic with division\<close>

instantiation "fun" :: (type, inverse) inverse
begin

definition "inverse f = inverse \<circ> f"

definition "f div g = (\<lambda>x. f x / g x)"

instance ..

end

lemma inverse_fun_apply [simp]:
  "inverse f x = inverse (f x)"
  by (simp add: inverse_fun_def)

lemma divide_fun_apply [simp]:
  "(f / g) x = f x / g x"
  by (simp add: divide_fun_def)

text \<open>
  Unfortunately, we cannot lift this operations to algebraic type
  classes for division: being different from the constant
  zero function @{term "f \<noteq> 0"} is too weak as precondition.
  So we must introduce our own set of lemmas.
\<close>

abbreviation zero_free :: "('b \<Rightarrow> 'a::field) \<Rightarrow> bool" where
  "zero_free f \<equiv> \<not> (\<exists>x. f x = 0)"

lemma fun_left_inverse:
  fixes f :: "'b \<Rightarrow> 'a::field"
  shows "zero_free f \<Longrightarrow> inverse f * f = 1"
  by (simp add: fun_eq_iff)

lemma fun_right_inverse:
  fixes f :: "'b \<Rightarrow> 'a::field"
  shows "zero_free f \<Longrightarrow> f * inverse f = 1"
  by (simp add: fun_eq_iff)

lemma fun_divide_inverse:
  fixes f g :: "'b \<Rightarrow> 'a::field"
  shows "f / g = f * inverse g"
  by (simp add: fun_eq_iff divide_inverse)

text \<open>Feel free to extend this.\<close>

text \<open>
  Another possibility would be a reformulation of the division type
  classes to user a @{term zero_free} predicate rather than
  a direct @{term "a \<noteq> 0"} condition.
\<close>

end


theory SC_Cut
imports SC
begin

subsubsection\<open>Contraction\<close>

text\<open>First, we need contraction:\<close>
lemma contract:
  "(F,F,\<Gamma> \<Rightarrow> \<Delta> \<longrightarrow> F,\<Gamma> \<Rightarrow> \<Delta>) \<and> (\<Gamma> \<Rightarrow> F,F,\<Delta> \<longrightarrow> \<Gamma> \<Rightarrow> F,\<Delta>)"
proof(induction F arbitrary: \<Gamma> \<Delta>)
  case (Atom k)
  have "Atom k, Atom k, \<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> Atom k, \<Gamma> \<Rightarrow> \<Delta>"
    by(induction "Atom k, Atom k, \<Gamma>" \<Delta> arbitrary: \<Gamma> rule: SCp.induct)
      (auto dest!: multi_member_split intro!: SCp.intros(3-) simp add: lem2 lem1 SCp.intros)
  moreover have "\<Gamma> \<Rightarrow> Atom k, Atom k, \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> Atom k, \<Delta>"
    by(induction "\<Gamma>" "Atom k, Atom k, \<Delta>" arbitrary: \<Delta> rule: SCp.induct)
      (auto dest!: multi_member_split intro!: SCp.intros(3-) simp add: lem2 lem1 SCp.intros)
  ultimately show ?case by blast
next
  case Bot
  have "\<bottom>, \<bottom>, \<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<bottom>, \<Gamma> \<Rightarrow> \<Delta>" by(blast)
  moreover have "(\<Gamma> \<Rightarrow> \<bottom>, \<bottom>, \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<bottom>, \<Delta>)"
    using Bot_delR by fastforce
  ultimately show ?case by blast
next
  case (Not F)
  then show ?case by (meson NotL_inv NotR_inv SCp.NotL SCp.NotR)
next
  case (And F1 F2) then show ?case by(auto intro!: SCp.intros(3-) dest!: AndR_inv AndL_inv) (metis add_mset_commute)
next
  case (Or F1 F2) then show ?case by(auto intro!: SCp.intros(3-) dest!: OrR_inv OrL_inv) (metis add_mset_commute)
next
  (* Okay, so the induction hypothesis is poison for the simplifier.
     For some reason, this didn't cause trouble for the other two cases, but here, it does. *)
  case (Imp F1 F2) show ?case by(auto dest!: ImpR_inv ImpL_inv intro!: SCp.intros(3-)) (insert Imp.IH; blast)+
qed
corollary
  shows contractL: "F, F, \<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> F, \<Gamma> \<Rightarrow> \<Delta>"
  and contractR:   "\<Gamma> \<Rightarrow> F, F, \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> F, \<Delta>"
  using contract by blast+

subsubsection\<open>Cut\<close>

text\<open>Which cut rule we show is up to us:\<close>
lemma cut_cs_cf:
  assumes context_sharing_Cut: "\<And>(A::'a formula) \<Gamma> \<Delta>. \<Gamma> \<Rightarrow> A,\<Delta> \<Longrightarrow> A,\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>"
  shows context_free_Cut: "\<Gamma> \<Rightarrow> (A::'a formula),\<Delta> \<Longrightarrow> A,\<Gamma>' \<Rightarrow> \<Delta>' \<Longrightarrow> \<Gamma> + \<Gamma>' \<Rightarrow> \<Delta> + \<Delta>'"
  by(intro context_sharing_Cut[of "\<Gamma> + \<Gamma>'" A "\<Delta> + \<Delta>'"])
    (metis add.commute union_mset_add_mset_left weakenL_set weakenR_set)+
lemma cut_cf_cs:
  assumes context_free_Cut: "\<And>(A::'a formula) \<Gamma> \<Gamma>' \<Delta> \<Delta>'. \<Gamma> \<Rightarrow> A,\<Delta> \<Longrightarrow> A,\<Gamma>' \<Rightarrow> \<Delta>' \<Longrightarrow> \<Gamma> + \<Gamma>' \<Rightarrow> \<Delta> + \<Delta>'"
  shows context_sharing_Cut: "\<Gamma> \<Rightarrow> (A::'a formula),\<Delta> \<Longrightarrow> A,\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>"
proof -
  have contract\<Gamma>\<Gamma>: "\<Gamma>+\<Gamma>' \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma>' \<subseteq># \<Gamma> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>" for \<Gamma> \<Gamma>' \<Delta>
  proof(induction "\<Gamma>'" arbitrary: \<Gamma>)
    case empty thus ?case using weakenL_set by force
  next
    case (add x \<Gamma>' \<Gamma>)
    from add.prems(2) have "x \<in># \<Gamma>" by (simp add: insert_subset_eq_iff)
    then obtain \<Gamma>'' where \<Gamma>[simp]: "\<Gamma> = x,\<Gamma>''" by (meson multi_member_split)
    from add.prems(1) have "x,x,\<Gamma>'' + \<Gamma>' \<Rightarrow> \<Delta>" by simp
    with contractL have "x, \<Gamma>'' + \<Gamma>' \<Rightarrow> \<Delta>" .
    with add.IH[of \<Gamma>] show ?case using \<Gamma>  add.prems(2) subset_mset.trans by force
  qed
  have contract\<Delta>\<Delta>: "\<Gamma> \<Rightarrow> \<Delta>+\<Delta>' \<Longrightarrow> \<Delta>' \<subseteq># \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>" for \<Gamma> \<Delta> \<Delta>'
  proof(induction "\<Delta>'" arbitrary: \<Delta>)
    case empty thus ?case using weakenL_set by force
  next
    case (add x \<Delta>' \<Delta>)
    from add.prems(2) have "x \<in># \<Delta>" by (simp add: insert_subset_eq_iff)
    then obtain \<Delta>'' where \<Delta>[simp]: "\<Delta> = x,\<Delta>''" by (metis multi_member_split)
    from add.prems(1) have "\<Gamma> \<Rightarrow> x,x,\<Delta>'' + \<Delta>'" by simp
    with contractR have "\<Gamma> \<Rightarrow> x, \<Delta>'' + \<Delta>'" .
    with add.IH[of \<Delta>] show ?case using \<Delta> add.prems(2) subset_mset.trans by force
  qed
  show "\<Gamma> \<Rightarrow> A,\<Delta> \<Longrightarrow> A,\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>"
    using context_free_Cut[of \<Gamma> A \<Delta> \<Gamma> \<Delta>] contract\<Gamma>\<Gamma> contract\<Delta>\<Delta>
    by blast
qed
(* since these are the only lemmas that need contraction on sets, I've decided to transfer those in place *)
text\<open>According to Troelstra and Schwichtenberg~\<^cite>\<open>"troelstra2000basic"\<close>, the sharing variant is the one we want to prove.\<close>

lemma Cut_Atom_pre: "Atom k,\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> Atom k,\<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>"
proof(induction "Atom k,\<Gamma>" "\<Delta>" arbitrary: \<Gamma> rule: SCp.induct)
  case BotL
  hence "\<bottom> \<in># \<Gamma>" by simp
  thus ?case using SCp.BotL by blast
next
  case (Ax l \<Delta>)
  show ?case proof cases
    assume "l = k"
    with \<open>Atom l \<in># \<Delta>\<close> obtain \<Delta>' where "\<Delta> = Atom k, \<Delta>'" by (meson multi_member_split)
    with \<open>\<Gamma> \<Rightarrow> Atom k, \<Delta>\<close> have "\<Gamma> \<Rightarrow> \<Delta>" using contractR by blast
    thus ?thesis by auto
  next
    assume "l \<noteq> k"
    with \<open>Atom l \<in># Atom k, \<Gamma>\<close> have "Atom l \<in># \<Gamma>" by simp
    with \<open>Atom l \<in># \<Delta>\<close> show ?thesis using SCp.Ax[of l] by blast
  qed
next
  case NotL
  thus ?case by(auto simp: add_eq_conv_ex intro!: SCp.NotL dest!: NotL_inv)
next
  case NotR
  then show ?case by(auto intro!: SCp.NotR dest!: NotR_inv)
next
  case AndL
  thus ?case by(auto simp: add_eq_conv_ex intro!: SCp.AndL dest!: AndL_inv)
next
  case AndR
  then show ?case by(auto intro!: SCp.AndR dest!: AndR_inv)
next
  case OrL
  thus ?case by(auto simp: add_eq_conv_ex intro!: SCp.OrL dest!: OrL_inv)
next
  case OrR
  thus ?case by(auto intro!: SCp.OrR dest!: OrR_inv)
next
  case ImpL
  thus ?case by(auto simp: add_eq_conv_ex intro!: SCp.ImpL dest!: ImpL_inv)
next
  case ImpR
  then show ?case by (auto dest!: ImpR_inv intro!: SCp.ImpR)
qed

text\<open>We can show the admissibility of the cut rule by induction on the cut formula
(or, if you will, as a procedure that splits the cut into smaller formulas that get cut).
The only mildly complicated case is that of cutting in an @{term "Atom k"}.
It is, contrary to the general case, only mildly complicated, since the cut formula can only appear principal in the axiom rules.\<close>

theorem cut: "\<Gamma> \<Rightarrow> F,\<Delta> \<Longrightarrow> F,\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> \<Gamma> \<Rightarrow> \<Delta>"
proof(induction F arbitrary: \<Gamma> \<Delta>)
  case Atom thus ?case using Cut_Atom_pre by metis
next
  case Bot thus ?case using Bot_delR by fastforce
next
  case Not with  NotL_inv NotR_inv show ?case by blast
next
  case And thus ?case by (meson AndL_inv AndR_inv weakenL)
next
  case Or thus ?case by (metis OrL_inv OrR_inv weakenR)
next
  case (Imp F G)
(* an automatic proof:
  thus ?case by (meson ImpL_inv ImpR_inv weakenR)
   a readable one: *)
  from ImpR_inv \<open>\<Gamma> \<Rightarrow> F \<^bold>\<rightarrow> G, \<Delta>\<close> have R: "F, \<Gamma> \<Rightarrow> G, \<Delta>" by blast
  from ImpL_inv \<open>F \<^bold>\<rightarrow> G, \<Gamma> \<Rightarrow> \<Delta>\<close> have L: "\<Gamma> \<Rightarrow> F, \<Delta>" "G, \<Gamma> \<Rightarrow> \<Delta>" by blast+
  from L(1) have "\<Gamma> \<Rightarrow> F, G, \<Delta>" using weakenR add_ac(3) by blast
  with R have "\<Gamma> \<Rightarrow> G, \<Delta>" using Imp.IH(1) by simp
  with L(2) show "\<Gamma> \<Rightarrow> \<Delta>" using Imp.IH(2) by clarsimp
qed
  (* For this proof to work with FOL, I think we would need very special inversion rules.
  For example, for \<forall>R, we would need that there's a (finite!) multiset of substitutions S, such that
  instead of having \<forall>x.F,\<Delta>, having {F[s/x] | s \<in> S} + \<Delta> is enough. I don't think that holds,
  but we may be able to cheat ourselves around it\<dots> *)

corollary cut_cf: "\<lbrakk> \<Gamma> \<Rightarrow> A, \<Delta>; A, \<Gamma>' \<Rightarrow> \<Delta>'\<rbrakk> \<Longrightarrow> \<Gamma> + \<Gamma>' \<Rightarrow> \<Delta> + \<Delta>'"
  using cut_cs_cf cut by metis

lemma assumes cut: "\<And> \<Gamma>' \<Delta>' (A::'a formula). \<lbrakk>\<Gamma>' \<Rightarrow> A, \<Delta>'; A, \<Gamma>' \<Rightarrow> \<Delta>'\<rbrakk> \<Longrightarrow> \<Gamma>' \<Rightarrow> \<Delta>'"
  shows contraction_admissibility: "F,F,\<Gamma> \<Rightarrow> \<Delta> \<Longrightarrow> (F::'a formula),\<Gamma> \<Rightarrow> \<Delta>"
  by(rule cut[of "F,\<Gamma>" F \<Delta>, OF extended_Ax]) simp_all
(* yes, unpublished Chapman p 2/5, second to last paragraph. that's right. we can prove contraction with cut. but what's that good for? *)

end


(*  Title:      HOL/HOLCF/Cpodef.thy
    Author:     Brian Huffman
*)

section \<open>Subtypes of pcpos\<close>

theory Cpodef
imports Adm
keywords "pcpodef" "cpodef" :: thy_goal
begin

subsection \<open>Proving a subtype is a partial order\<close>

text \<open>
  A subtype of a partial order is itself a partial order,
  if the ordering is defined in the standard way.
\<close>

setup \<open>Sign.add_const_constraint (@{const_name Porder.below}, NONE)\<close>

theorem typedef_po:
  fixes Abs :: "'a::po \<Rightarrow> 'b::type"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
  shows "OFCLASS('b, po_class)"
 apply (intro_classes, unfold below)
   apply (rule below_refl)
  apply (erule (1) below_trans)
 apply (rule type_definition.Rep_inject [OF type, THEN iffD1])
 apply (erule (1) below_antisym)
done

setup \<open>Sign.add_const_constraint (@{const_name Porder.below},
  SOME @{typ "'a::below \<Rightarrow> 'a::below \<Rightarrow> bool"})\<close>

subsection \<open>Proving a subtype is finite\<close>

lemma typedef_finite_UNIV:
  fixes Abs :: "'a::type \<Rightarrow> 'b::type"
  assumes type: "type_definition Rep Abs A"
  shows "finite A \<Longrightarrow> finite (UNIV :: 'b set)"
proof -
  assume "finite A"
  hence "finite (Abs ` A)" by (rule finite_imageI)
  thus "finite (UNIV :: 'b set)"
    by (simp only: type_definition.Abs_image [OF type])
qed

subsection \<open>Proving a subtype is chain-finite\<close>

lemma ch2ch_Rep:
  assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
  shows "chain S \<Longrightarrow> chain (\<lambda>i. Rep (S i))"
unfolding chain_def below .

theorem typedef_chfin:
  fixes Abs :: "'a::chfin \<Rightarrow> 'b::po"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
  shows "OFCLASS('b, chfin_class)"
 apply intro_classes
 apply (drule ch2ch_Rep [OF below])
 apply (drule chfin)
 apply (unfold max_in_chain_def)
 apply (simp add: type_definition.Rep_inject [OF type])
done

subsection \<open>Proving a subtype is complete\<close>

text \<open>
  A subtype of a cpo is itself a cpo if the ordering is
  defined in the standard way, and the defining subset
  is closed with respect to limits of chains.  A set is
  closed if and only if membership in the set is an
  admissible predicate.
\<close>

lemma typedef_is_lubI:
  assumes below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
  shows "range (\<lambda>i. Rep (S i)) <<| Rep x \<Longrightarrow> range S <<| x"
unfolding is_lub_def is_ub_def below by simp

lemma Abs_inverse_lub_Rep:
  fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and adm:  "adm (\<lambda>x. x \<in> A)"
  shows "chain S \<Longrightarrow> Rep (Abs (\<Squnion>i. Rep (S i))) = (\<Squnion>i. Rep (S i))"
 apply (rule type_definition.Abs_inverse [OF type])
 apply (erule admD [OF adm ch2ch_Rep [OF below]])
 apply (rule type_definition.Rep [OF type])
done

theorem typedef_is_lub:
  fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and adm: "adm (\<lambda>x. x \<in> A)"
  shows "chain S \<Longrightarrow> range S <<| Abs (\<Squnion>i. Rep (S i))"
proof -
  assume S: "chain S"
  hence "chain (\<lambda>i. Rep (S i))" by (rule ch2ch_Rep [OF below])
  hence "range (\<lambda>i. Rep (S i)) <<| (\<Squnion>i. Rep (S i))" by (rule cpo_lubI)
  hence "range (\<lambda>i. Rep (S i)) <<| Rep (Abs (\<Squnion>i. Rep (S i)))"
    by (simp only: Abs_inverse_lub_Rep [OF type below adm S])
  thus "range S <<| Abs (\<Squnion>i. Rep (S i))"
    by (rule typedef_is_lubI [OF below])
qed

lemmas typedef_lub = typedef_is_lub [THEN lub_eqI]

theorem typedef_cpo:
  fixes Abs :: "'a::cpo \<Rightarrow> 'b::po"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and adm: "adm (\<lambda>x. x \<in> A)"
  shows "OFCLASS('b, cpo_class)"
proof
  fix S::"nat \<Rightarrow> 'b" assume "chain S"
  hence "range S <<| Abs (\<Squnion>i. Rep (S i))"
    by (rule typedef_is_lub [OF type below adm])
  thus "\<exists>x. range S <<| x" ..
qed

subsubsection \<open>Continuity of \emph{Rep} and \emph{Abs}\<close>

text \<open>For any sub-cpo, the @{term Rep} function is continuous.\<close>

theorem typedef_cont_Rep:
  fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and adm: "adm (\<lambda>x. x \<in> A)"
  shows "cont (\<lambda>x. f x) \<Longrightarrow> cont (\<lambda>x. Rep (f x))"
 apply (erule cont_apply [OF _ _ cont_const])
 apply (rule contI)
 apply (simp only: typedef_lub [OF type below adm])
 apply (simp only: Abs_inverse_lub_Rep [OF type below adm])
 apply (rule cpo_lubI)
 apply (erule ch2ch_Rep [OF below])
done

text \<open>
  For a sub-cpo, we can make the @{term Abs} function continuous
  only if we restrict its domain to the defining subset by
  composing it with another continuous function.
\<close>

theorem typedef_cont_Abs:
  fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
  fixes f :: "'c::cpo \<Rightarrow> 'a::cpo"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and adm: "adm (\<lambda>x. x \<in> A)" (* not used *)
    and f_in_A: "\<And>x. f x \<in> A"
  shows "cont f \<Longrightarrow> cont (\<lambda>x. Abs (f x))"
unfolding cont_def is_lub_def is_ub_def ball_simps below
by (simp add: type_definition.Abs_inverse [OF type f_in_A])

subsection \<open>Proving subtype elements are compact\<close>

theorem typedef_compact:
  fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and adm: "adm (\<lambda>x. x \<in> A)"
  shows "compact (Rep k) \<Longrightarrow> compact k"
proof (unfold compact_def)
  have cont_Rep: "cont Rep"
    by (rule typedef_cont_Rep [OF type below adm cont_id])
  assume "adm (\<lambda>x. Rep k \<notsqsubseteq> x)"
  with cont_Rep have "adm (\<lambda>x. Rep k \<notsqsubseteq> Rep x)" by (rule adm_subst)
  thus "adm (\<lambda>x. k \<notsqsubseteq> x)" by (unfold below)
qed

subsection \<open>Proving a subtype is pointed\<close>

text \<open>
  A subtype of a cpo has a least element if and only if
  the defining subset has a least element.
\<close>

theorem typedef_pcpo_generic:
  fixes Abs :: "'a::cpo \<Rightarrow> 'b::cpo"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and z_in_A: "z \<in> A"
    and z_least: "\<And>x. x \<in> A \<Longrightarrow> z \<sqsubseteq> x"
  shows "OFCLASS('b, pcpo_class)"
 apply (intro_classes)
 apply (rule_tac x="Abs z" in exI, rule allI)
 apply (unfold below)
 apply (subst type_definition.Abs_inverse [OF type z_in_A])
 apply (rule z_least [OF type_definition.Rep [OF type]])
done

text \<open>
  As a special case, a subtype of a pcpo has a least element
  if the defining subset contains @{term \<bottom>}.
\<close>

theorem typedef_pcpo:
  fixes Abs :: "'a::pcpo \<Rightarrow> 'b::cpo"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and bottom_in_A: "\<bottom> \<in> A"
  shows "OFCLASS('b, pcpo_class)"
by (rule typedef_pcpo_generic [OF type below bottom_in_A], rule minimal)

subsubsection \<open>Strictness of \emph{Rep} and \emph{Abs}\<close>

text \<open>
  For a sub-pcpo where @{term \<bottom>} is a member of the defining
  subset, @{term Rep} and @{term Abs} are both strict.
\<close>

theorem typedef_Abs_strict:
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and bottom_in_A: "\<bottom> \<in> A"
  shows "Abs \<bottom> = \<bottom>"
 apply (rule bottomI, unfold below)
 apply (simp add: type_definition.Abs_inverse [OF type bottom_in_A])
done

theorem typedef_Rep_strict:
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and bottom_in_A: "\<bottom> \<in> A"
  shows "Rep \<bottom> = \<bottom>"
 apply (rule typedef_Abs_strict [OF type below bottom_in_A, THEN subst])
 apply (rule type_definition.Abs_inverse [OF type bottom_in_A])
done

theorem typedef_Abs_bottom_iff:
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and bottom_in_A: "\<bottom> \<in> A"
  shows "x \<in> A \<Longrightarrow> (Abs x = \<bottom>) = (x = \<bottom>)"
 apply (rule typedef_Abs_strict [OF type below bottom_in_A, THEN subst])
 apply (simp add: type_definition.Abs_inject [OF type] bottom_in_A)
done

theorem typedef_Rep_bottom_iff:
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and bottom_in_A: "\<bottom> \<in> A"
  shows "(Rep x = \<bottom>) = (x = \<bottom>)"
 apply (rule typedef_Rep_strict [OF type below bottom_in_A, THEN subst])
 apply (simp add: type_definition.Rep_inject [OF type])
done

subsection \<open>Proving a subtype is flat\<close>

theorem typedef_flat:
  fixes Abs :: "'a::flat \<Rightarrow> 'b::pcpo"
  assumes type: "type_definition Rep Abs A"
    and below: "op \<sqsubseteq> \<equiv> \<lambda>x y. Rep x \<sqsubseteq> Rep y"
    and bottom_in_A: "\<bottom> \<in> A"
  shows "OFCLASS('b, flat_class)"
 apply (intro_classes)
 apply (unfold below)
 apply (simp add: type_definition.Rep_inject [OF type, symmetric])
 apply (simp add: typedef_Rep_strict [OF type below bottom_in_A])
 apply (simp add: ax_flat)
done

subsection \<open>HOLCF type definition package\<close>

ML_file "Tools/cpodef.ML"

end


section {* \isaheader{Generic Algorithms for Sequences} *}
theory ListGA
imports "../spec/ListSpec"
begin

subsection {* Iterators *}

subsubsection {* iteratei (by get, size) *}

locale idx_iteratei_loc =
  list_size + list_get +
  constrains \<alpha> :: "'s \<Rightarrow> 'a list"
  assumes [simp]: "\<And>s. invar s"
begin

  fun idx_iteratei_aux
    :: "nat \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> ('\<sigma>\<Rightarrow>bool) \<Rightarrow> ('a \<Rightarrow>'\<sigma> \<Rightarrow> '\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"
  where
    "idx_iteratei_aux sz i l c f \<sigma> = (
      if i=0 \<or> \<not> c \<sigma> then \<sigma>
      else idx_iteratei_aux sz (i - 1) l c f (f (get l (sz-i)) \<sigma>)
    )"

  declare idx_iteratei_aux.simps[simp del]

  lemma idx_iteratei_aux_simps[simp]:
    "i=0 \<Longrightarrow> idx_iteratei_aux sz i l c f \<sigma> = \<sigma>"
    "\<not>c \<sigma> \<Longrightarrow> idx_iteratei_aux sz i l c f \<sigma> = \<sigma>"
    "\<lbrakk>i\<noteq>0; c \<sigma>\<rbrakk> \<Longrightarrow> idx_iteratei_aux sz i l c f \<sigma> = idx_iteratei_aux sz (i - 1) l c f (f (get l (sz-i)) \<sigma>)"
    apply -
    apply (subst idx_iteratei_aux.simps, simp)+
    done

  definition idx_iteratei where
    "idx_iteratei l c f \<sigma> \<equiv> idx_iteratei_aux (size l) (size l) l c f \<sigma>"

  lemma idx_iteratei_correct:
    shows "idx_iteratei s = foldli (\<alpha> s)"
  proof -
    {
      fix n l
      assume A: "Suc n \<le> length l"
      hence B: "length l - Suc n < length l" by simp
      from A have [simp]: "Suc (length l - Suc n) = length l - n" by simp
      from Cons_nth_drop_Suc[OF B, simplified] have
        "drop (length l - Suc n) l = l!(length l - Suc n)#drop (length l - n) l"
        by simp
    } note drop_aux=this

    {
      fix s c f \<sigma> i
      assume "invar s" "i\<le>size s"
      hence "idx_iteratei_aux (size s) i s c f \<sigma>
        = foldli (drop (size s - i) (\<alpha> s)) c f \<sigma>"
      proof (induct i arbitrary: \<sigma>)
        case 0 with size_correct[of s] show ?case by simp
      next
        case (Suc n)
        note [simp, intro!] = Suc.prems(1)
        show ?case proof (cases "c \<sigma>")
          case False thus ?thesis by simp
        next
          case [simp, intro!]: True
          show ?thesis using Suc by (simp add: get_correct size_correct drop_aux)
        qed
      qed
    } note aux=this

    show ?thesis
      unfolding idx_iteratei_def[abs_def]
      by (auto simp add: fun_eq_iff aux[of _ "size s", simplified])
  qed

  lemmas idx_iteratei_unfold[code_unfold] = idx_iteratei_correct[symmetric]

  subsubsection {* reverse\_iteratei (by get, size) *}

  fun idx_reverse_iteratei_aux
    :: "nat \<Rightarrow> nat \<Rightarrow> 's \<Rightarrow> ('\<sigma>\<Rightarrow>bool) \<Rightarrow> ('a \<Rightarrow>'\<sigma> \<Rightarrow> '\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"
    where
    "idx_reverse_iteratei_aux sz i l c f \<sigma> = (
      if i=0 \<or> \<not> c \<sigma> then \<sigma>
      else idx_reverse_iteratei_aux sz (i - 1) l c f (f (get l (i - 1)) \<sigma>)
    )"

  declare idx_reverse_iteratei_aux.simps[simp del]

  lemma idx_reverse_iteratei_aux_simps[simp]:
    "i=0 \<Longrightarrow> idx_reverse_iteratei_aux sz i l c f \<sigma> = \<sigma>"
    "\<not>c \<sigma> \<Longrightarrow> idx_reverse_iteratei_aux sz i l c f \<sigma> = \<sigma>"
    "\<lbrakk>i\<noteq>0; c \<sigma>\<rbrakk> \<Longrightarrow> idx_reverse_iteratei_aux sz i l c f \<sigma>
    = idx_reverse_iteratei_aux sz (i - 1) l c f (f (get l (i - 1)) \<sigma>)"
    by (subst idx_reverse_iteratei_aux.simps, simp)+

  definition "idx_reverse_iteratei l c f \<sigma>
    == idx_reverse_iteratei_aux (size l) (size l) l c f \<sigma>"

  lemma idx_reverse_iteratei_correct:
    shows "idx_reverse_iteratei s = foldri (\<alpha> s)"
  proof -
    {
      fix s c f \<sigma> i
      assume "invar s" "i\<le>size s"
      hence "idx_reverse_iteratei_aux (size s) i s c f \<sigma>
        = foldri (take i (\<alpha> s)) c f \<sigma>"
      proof (induct i arbitrary: \<sigma>)
        case 0 with size_correct[of s] show ?case by simp
      next
        case (Suc n)
        note [simp, intro!] = Suc.prems(1)
        show ?case proof (cases "c \<sigma>")
          case False thus ?thesis by simp
        next
          case [simp, intro!]: True
          show ?thesis using Suc
            by (simp add: get_correct size_correct take_Suc_conv_app_nth)
        qed
      qed
    } note aux=this

    show ?thesis
      unfolding idx_reverse_iteratei_def[abs_def]
      apply (simp add: fun_eq_iff aux[of _ "size s", simplified])
      apply (simp add: size_correct)
    done
  qed

  lemmas idx_reverse_iteratei_unfold[code_unfold]
    = idx_reverse_iteratei_correct[symmetric]

end

subsection {* Size (by iterator) *}

locale it_size_loc = poly_list_iteratei +
  constrains \<alpha> :: "'s \<Rightarrow> 'a list"
begin

  definition it_size :: "'s \<Rightarrow> nat"
    where "it_size l == iterate l (\<lambda>x res. Suc res) (0::nat)"

  lemma it_size_impl: shows "list_size \<alpha> invar it_size"
    apply (unfold_locales)
    apply (unfold it_size_def)
    apply (simp add: iterate_correct foldli_foldl)
    done
end

subsubsection {* Size (by reverse\_iterator) *}

locale rev_it_size_loc = poly_list_rev_iteratei +
  constrains \<alpha> :: "'s \<Rightarrow> 'a list"
begin

  definition rev_it_size :: "'s \<Rightarrow> nat"
    where "rev_it_size l == rev_iterate l (\<lambda>x res. Suc res) (0::nat)"

  lemma rev_it_size_impl:
    shows "list_size \<alpha> invar rev_it_size"
    apply (unfold_locales)
    apply (unfold rev_it_size_def)
    apply (simp add: rev_iterate_correct foldri_foldr)
    done

end

subsection {* Get (by iteratori) *}
locale it_get_loc = poly_list_iteratei +
  constrains \<alpha> :: "'s \<Rightarrow> 'a list"
begin

  definition it_get:: "'s \<Rightarrow> nat \<Rightarrow> 'a"
    where "it_get s i \<equiv>
      the (snd (iteratei s
                (\<lambda>(i,x). x=None)
                (\<lambda>x (i,_). if i=0 then (0,Some x) else (i - 1,None))
                (i,None)))"

  lemma it_get_correct:
    shows "list_get \<alpha> invar it_get"
  proof
    fix s i
    assume "invar s" "i < length (\<alpha> s)"

    def l \<equiv> "\<alpha> s"
    from `i < length (\<alpha> s)`
    show "it_get s i = \<alpha> s ! i"
      unfolding it_get_def iteratei_correct l_def[symmetric]
    proof (induct i arbitrary: l)
      case 0
      then obtain x xs where l_eq[simp]: "l = x # xs" by (cases l, auto)
      thus ?case by simp
    next
      case (Suc i)
      note ind_hyp = Suc(1)
      note Suc_i_le = Suc(2)
      from Suc_i_le obtain x xs
        where l_eq[simp]: "l = x # xs" by (cases l, auto)

      from ind_hyp [of xs] Suc_i_le
      show ?case by simp
    qed
  qed
end

end


(*  Author:     Tobias Nipkow, 2007  *)

theory FRE
imports LinArith
begin

subsection\<open>Ferrante-Rackoff \label{sec:FRE}\<close>

text\<open>This section formalizes a slight variant of Ferrante and
Rackoff's algorithm~\cite{FerranteR-SIAM75}. We consider equalities
separately, which improves performance.\<close>

fun between :: "real * real list \<Rightarrow> real * real list \<Rightarrow> real * real list"
where "between (r,cs) (s,ds) = ((r+s)/2, (1/2) *\<^sub>s (cs+ds))"

definition FR\<^sub>1 :: "atom fm \<Rightarrow> atom fm" where
"FR\<^sub>1 \<phi> =
(let as = R.atoms\<^sub>0 \<phi>; lbs = lbounds as; ubs = ubounds as; ebs = ebounds as;
     intrs = [subst \<phi> (between l u) . l \<leftarrow> lbs, u \<leftarrow> ubs]
 in list_disj (inf\<^sub>- \<phi> # inf\<^sub>+ \<phi> # intrs @ map (subst \<phi>) ebs))"

lemma dense:
  "\<lbrakk> nqfree f; \<forall>y\<in>{l<..<x}. y \<notin> LB f xs; \<forall>y\<in>{x<..<u}. y \<notin> UB f xs;
     l < x; x < u; x \<notin> EQ f xs;  R.I f (x#xs); l < y; y < u\<rbrakk>
   \<Longrightarrow> R.I f (y#xs)"
proof(induct f)
  case (Atom a)
  show ?case
  proof (cases a)
    case (Less r cs)
    show ?thesis
    proof (cases cs)
      case Nil thus ?thesis using Atom Less by (simp add:depends\<^sub>R_def)
    next
      case (Cons c cs)
      hence "r < c*x + \<langle>cs,xs\<rangle>" using Atom Less by simp
      { assume "c=0" hence ?thesis using Atom Less Cons by simp }
      moreover
      { assume "c<0"
        hence "x < (r - \<langle>cs,xs\<rangle>)/c" (is "_ < ?u") using \<open>r < c*x + \<langle>cs,xs\<rangle>\<close>
          by (simp add: field_simps)
        have ?thesis
        proof (rule ccontr)
          assume "\<not> R.I (Atom a) (y#xs)"
          hence "?u \<le> y" using Atom Less Cons \<open>c<0\<close>
            by (auto simp add: field_simps)
          hence "?u < u" using \<open>y<u\<close> by simp
          with \<open>x<?u\<close> show False using Atom Less Cons \<open>c<0\<close>
            by(auto simp:depends\<^sub>R_def)
        qed } moreover
      { assume "c>0"
        hence "x > (r - \<langle>cs,xs\<rangle>)/c" (is "_ > ?l") using \<open>r < c*x + \<langle>cs,xs\<rangle>\<close>
          by (simp add: field_simps)
        have ?thesis
        proof (rule ccontr)
          assume "\<not> R.I (Atom a) (y#xs)"
          hence "?l \<ge> y" using Atom Less Cons \<open>c>0\<close>
            by (auto simp add: field_simps)
          hence "?l > l" using \<open>y>l\<close> by simp
          with \<open>?l<x\<close> show False using Atom Less Cons \<open>c>0\<close>
            by (auto simp:depends\<^sub>R_def)
        qed }
      ultimately show ?thesis by force
    qed
  next
    case (Eq r cs)
    show ?thesis
    proof (cases cs)
      case Nil thus ?thesis using Atom Eq by (simp add:depends\<^sub>R_def)
    next
      case (Cons c cs)
      hence "r = c*x + \<langle>cs,xs\<rangle>" using Atom Eq by simp
      { assume "c=0" hence ?thesis using Atom Eq Cons by simp }
      moreover
      { assume "c\<noteq>0"
        hence ?thesis using \<open>r = c*x + \<langle>cs,xs\<rangle>\<close> Atom Eq Cons \<open>l<y\<close> \<open>y<u\<close>
          by(auto simp: ac_simps depends\<^sub>R_def split:if_splits) }
      ultimately show ?thesis by force
    qed
  qed
next
  case (And f1 f2) thus ?case
    by auto (metis (no_types, hide_lams))+
next
  case (Or f1 f2) thus ?case
    by auto (metis (no_types, hide_lams))+
qed fastforce+

theorem I_FR\<^sub>1:
assumes "nqfree \<phi>" shows "R.I (FR\<^sub>1 \<phi>) xs = (\<exists>x. R.I \<phi> (x#xs))"
  (is "?FR = ?EX")
proof
  assume ?FR
  { assume "R.I (inf\<^sub>- \<phi>) xs"
    hence ?EX using \<open>?FR\<close> min_inf[OF \<open>nqfree \<phi>\<close>, where xs=xs]
      by(auto simp add:FR\<^sub>1_def)
  } moreover
  { assume "R.I (inf\<^sub>+ \<phi>) xs"
    hence ?EX using \<open>?FR\<close> plus_inf[OF \<open>nqfree \<phi>\<close>, where xs=xs]
      by(auto simp add:FR\<^sub>1_def)
  } moreover
  { assume "\<exists>x \<in> EQ \<phi> xs. R.I \<phi> (x#xs)"
    hence ?EX using \<open>?FR\<close> by(auto simp add:FR\<^sub>1_def)
  } moreover
  { assume "\<not>R.I (inf\<^sub>- \<phi>) xs \<and> \<not>R.I (inf\<^sub>+ \<phi>) xs \<and>
            (\<forall>x\<in>EQ \<phi> xs. \<not>R.I \<phi> (x#xs))"
    with \<open>?FR\<close> obtain r cs s ds
      where "R.I (subst \<phi> (between (r,cs) (s,ds))) xs"
      by(auto simp: FR\<^sub>1_def eval_def
        diff_divide_distrib set_ebounds I_subst \<open>nqfree \<phi>\<close>) blast
    hence "R.I \<phi> (eval (between (r,cs) (s,ds)) xs # xs)"
      by(simp add:I_subst \<open>nqfree \<phi>\<close>)
    hence ?EX .. }
  ultimately show ?EX by blast
next
  assume ?EX
  then obtain x where x: "R.I \<phi> (x#xs)" ..
  { assume "R.I (inf\<^sub>- \<phi>) xs \<or> R.I (inf\<^sub>+ \<phi>) xs"
    hence ?FR by(auto simp:FR\<^sub>1_def)
  } moreover
  { assume "x \<in> EQ \<phi> xs"
    then obtain r cs
      where "(r,cs) \<in> set(ebounds(R.atoms\<^sub>0 \<phi>)) \<and> x = r + \<langle>cs,xs\<rangle>"
      by(force simp:set_ebounds field_simps)
    moreover hence "R.I (subst \<phi> (r,cs)) xs" using x
      by(auto simp: I_subst \<open>nqfree \<phi>\<close> eval_def)
    ultimately have ?FR by(force simp:FR\<^sub>1_def) } moreover
  { assume "\<not> R.I (inf\<^sub>- \<phi>) xs" and "\<not> R.I (inf\<^sub>+ \<phi>) xs" and "x \<notin> EQ \<phi> xs"
    obtain l where "l \<in> LB \<phi> xs" "l < x"
      using LBex[OF \<open>nqfree \<phi>\<close> x \<open>\<not> R.I (inf\<^sub>- \<phi>) xs\<close> \<open>x \<notin> EQ \<phi> xs\<close>] ..
    obtain u where "u \<in> UB \<phi> xs" "x < u"
      using UBex[OF \<open>nqfree \<phi>\<close> x \<open>\<not> R.I (inf\<^sub>+ \<phi>) xs\<close> \<open>x \<notin> EQ \<phi> xs\<close>] ..
    have "\<exists>l\<in>LB \<phi> xs. \<exists>u\<in>UB \<phi> xs. l<u \<and> (\<forall>y. l < y \<and> y < u \<longrightarrow> R.I \<phi> (y#xs))"
      using dense_interval[where P = "\<lambda>x. R.I \<phi> (x#xs)", OF finite_LB finite_UB \<open>l:LB \<phi> xs\<close> \<open>u:UB \<phi> xs\<close> \<open>l<x\<close> \<open>x<u\<close> x] x dense[OF \<open>nqfree \<phi>\<close> _ _ _ _ \<open>x \<notin> EQ \<phi> xs\<close>] by simp
    then obtain r c cs s d ds
      where "Less r (c # cs) \<in> set (R.atoms\<^sub>0 \<phi>)" "Less s (d # ds) \<in> set (R.atoms\<^sub>0 \<phi>)"
          "\<And>y. (r - \<langle>cs,xs\<rangle>) / c < y \<Longrightarrow> y < (s - \<langle>ds,xs\<rangle>) / d \<Longrightarrow> R.I \<phi> (y # xs)"
        and *: "c > 0" "d < 0" "(r - \<langle>cs,xs\<rangle>) / c < (s - \<langle>ds,xs\<rangle>) / d"
      by blast
    moreover
      have "(r - \<langle>cs,xs\<rangle>) / c < eval (between (r / c, (-1 / c) *\<^sub>s cs) (s / d, (-1 / d) *\<^sub>s ds)) xs" (is ?P)
        and "eval (between (r / c, (-1 / c) *\<^sub>s cs) (s / d, (-1 / d) *\<^sub>s ds)) xs < (s - \<langle>ds,xs\<rangle>) / d" (is ?Q)
    proof -
      from * have [simp]: "c * (c * (d * (d * 4))) > 0"
        by (simp add: algebra_split_simps)
      from * have "c * s + d * \<langle>cs,xs\<rangle> < d * r + c * \<langle>ds,xs\<rangle>"
        by (simp add: field_simps)
      with * have "(2 * c * c * d) * (d * r + c * \<langle>ds,xs\<rangle>)
        < (2 * c * c * d) * (c * s + d * \<langle>cs,xs\<rangle>)"
        and "(2 * c * d * d) * (c * s + d * \<langle>cs,xs\<rangle>)
        < (2 * c * d * d) * (d * r + c * \<langle>ds,xs\<rangle>)" by simp_all
      with * show ?P and ?Q by (auto simp add: field_simps eval_def iprod_left_add_distrib)
    qed
    ultimately have ?FR
      by (fastforce simp: FR\<^sub>1_def bex_Un set_lbounds set_ubounds set_ebounds I_subst \<open>nqfree \<phi>\<close>)
  } ultimately show ?FR by blast
qed

definition "FR = R.lift_nnf_qe FR\<^sub>1"

lemma qfree_FR\<^sub>1: "nqfree \<phi> \<Longrightarrow> qfree (FR\<^sub>1 \<phi>)"
apply(simp add:FR\<^sub>1_def)
apply(rule qfree_list_disj)
apply(auto simp:qfree_min_inf qfree_plus_inf set_ubounds set_lbounds set_ebounds image_def qfree_map_fm)
done

theorem I_FR: "R.I (FR \<phi>) xs = R.I \<phi> xs"
by(simp add:I_FR\<^sub>1 FR_def R.I_lift_nnf_qe qfree_FR\<^sub>1)

theorem qfree_FR: "qfree (FR \<phi>)"
by(simp add:FR_def R.qfree_lift_nnf_qe qfree_FR\<^sub>1)

end


(* Author: Tobias Nipkow *)

subsection "Verification Conditions for Total Correctness"

subsubsection "The Standard Approach"

theory VCG_Total_EX
imports Hoare_Total_EX
begin

text\<open>Annotated commands: commands where loops are annotated with
invariants.\<close>

datatype acom =
  Askip                  ("SKIP") |
  Aassign vname aexp     ("(_ ::= _)" [1000, 61] 61) |
  Aseq   acom acom       ("_;;/ _"  [60, 61] 60) |
  Aif bexp acom acom     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61) |
  Awhile "nat \<Rightarrow> assn" bexp acom
    ("({_}/ WHILE _/ DO _)"  [0, 0, 61] 61)

notation com.SKIP ("SKIP")

text\<open>Strip annotations:\<close>

fun strip :: "acom \<Rightarrow> com" where
"strip SKIP = SKIP" |
"strip (x ::= a) = (x ::= a)" |
"strip (C\<^sub>1;; C\<^sub>2) = (strip C\<^sub>1;; strip C\<^sub>2)" |
"strip (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = (IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2)" |
"strip ({_} WHILE b DO C) = (WHILE b DO strip C)"

text\<open>Weakest precondition from annotated commands:\<close>

fun pre :: "acom \<Rightarrow> assn \<Rightarrow> assn" where
"pre SKIP Q = Q" |
"pre (x ::= a) Q = (\<lambda>s. Q(s(x := aval a s)))" |
"pre (C\<^sub>1;; C\<^sub>2) Q = pre C\<^sub>1 (pre C\<^sub>2 Q)" |
"pre (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q =
  (\<lambda>s. if bval b s then pre C\<^sub>1 Q s else pre C\<^sub>2 Q s)" |
"pre ({I} WHILE b DO C) Q = (\<lambda>s. \<exists>n. I n s)"

text\<open>Verification condition:\<close>

fun vc :: "acom \<Rightarrow> assn \<Rightarrow> bool" where
"vc SKIP Q = True" |
"vc (x ::= a) Q = True" |
"vc (C\<^sub>1;; C\<^sub>2) Q = (vc C\<^sub>1 (pre C\<^sub>2 Q) \<and> vc C\<^sub>2 Q)" |
"vc (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q = (vc C\<^sub>1 Q \<and> vc C\<^sub>2 Q)" |
"vc ({I} WHILE b DO C) Q =
  (\<forall>s n. (I (Suc n) s \<longrightarrow> pre C (I n) s) \<and>
       (I (Suc n) s \<longrightarrow> bval b s) \<and>
       (I 0 s \<longrightarrow> \<not> bval b s \<and> Q s) \<and>
       vc C (I n))"

lemma vc_sound: "vc C Q \<Longrightarrow> \<turnstile>\<^sub>t {pre C Q} strip C {Q}"
proof(induction C arbitrary: Q)
  case (Awhile I b C)
  show ?case
  proof(simp, rule conseq[OF _ While[of I]], goal_cases)
    case (2 n) show ?case
      using Awhile.IH[of "I n"] Awhile.prems
      by (auto intro: strengthen_pre)
  qed (insert Awhile.prems, auto)
qed (auto intro: conseq Seq If simp: Skip Assign)

text\<open>When trying to extend the completeness proof of the VCG for partial correctness
to total correctness one runs into the following problem.
In the case of the while-rule, the universally quantified \<open>n\<close> in the first premise
means that for that premise the induction hypothesis does not yield a single
annotated command \<open>C\<close> but merely that for every \<open>n\<close> such a \<open>C\<close> exists.\<close>

end


header {*\isaheader{Implementation of Priority Queues by Skew Binomial Heaps}*}

theory SkewPrioImpl
imports
  "../../../Binomial-Heaps/SkewBinomialHeap"
  "../spec/PrioSpec"
  "../tools/Record_Intf"
  "../tools/Locale_Code"
begin

(*@impl Prio
  @type ('a,'p::linorder) skew
  @abbrv skew
  Priority queues by skew binomial heaps.
*)

subsection "Definitions"
type_synonym ('a,'b) skew = "('a, 'b) SkewBinomialHeap"

definition skew_\<alpha> where "skew_\<alpha> q \<equiv> SkewBinomialHeap.to_mset q"
definition skew_insert where "skew_insert \<equiv> SkewBinomialHeap.insert"
abbreviation (input) skew_invar :: "('a, 'b) SkewBinomialHeap \<Rightarrow> bool"
  where "skew_invar \<equiv> \<lambda>_. True"
definition skew_find where "skew_find \<equiv> SkewBinomialHeap.findMin"
definition skew_delete where "skew_delete \<equiv> SkewBinomialHeap.deleteMin"
definition skew_meld where "skew_meld \<equiv> SkewBinomialHeap.meld"
definition skew_empty where "skew_empty \<equiv> \<lambda>_::unit. SkewBinomialHeap.empty"
definition skew_isEmpty where "skew_isEmpty = SkewBinomialHeap.isEmpty"

definition [icf_rec_def]: "skew_ops == \<lparr>
  prio_op_\<alpha> = skew_\<alpha>,
  prio_op_invar = skew_invar,
  prio_op_empty = skew_empty,
  prio_op_isEmpty = skew_isEmpty,
  prio_op_insert = skew_insert,
  prio_op_find = skew_find,
  prio_op_delete = skew_delete,
  prio_op_meld = skew_meld
\<rparr>"

lemmas skew_defs =
  skew_\<alpha>_def
  skew_insert_def
  skew_find_def
  skew_delete_def
  skew_meld_def
  skew_empty_def
  skew_isEmpty_def

subsection "Correctness"

theorem skew_empty_impl: "prio_empty skew_\<alpha> skew_invar skew_empty"
  by (unfold_locales, auto simp add: skew_defs)

theorem skew_isEmpty_impl: "prio_isEmpty skew_\<alpha> skew_invar skew_isEmpty"
  by unfold_locales
     (simp add: skew_defs SkewBinomialHeap.isEmpty_correct SkewBinomialHeap.empty_correct)

theorem skew_find_impl: "prio_find skew_\<alpha> skew_invar skew_find"
  apply unfold_locales
  apply (simp add: skew_defs SkewBinomialHeap.empty_correct SkewBinomialHeap.findMin_correct)
  done

lemma skew_insert_impl: "prio_insert skew_\<alpha> skew_invar skew_insert"
  apply(unfold_locales)
  apply(unfold skew_defs)
  apply (simp_all add: SkewBinomialHeap.insert_correct)
  done

lemma skew_meld_impl: "prio_meld skew_\<alpha> skew_invar skew_meld"
  apply(unfold_locales)
  apply(unfold skew_defs)
  apply(simp_all add: SkewBinomialHeap.meld_correct)
  done

lemma skew_delete_impl:
  "prio_delete skew_\<alpha> skew_invar skew_find skew_delete"
  apply intro_locales
  apply (rule skew_find_impl)
  apply(unfold_locales)
  apply(simp_all add: skew_defs SkewBinomialHeap.empty_correct SkewBinomialHeap.deleteMin_correct)
done

setup Locale_Code.open_block
interpretation skew!: StdPrio skew_ops
  apply (rule StdPrio.intro)
  apply (simp_all add: icf_rec_unf)
  apply (rule
    skew_empty_impl
    skew_isEmpty_impl
    skew_find_impl
    skew_insert_impl
    skew_meld_impl
    skew_delete_impl
  )+
  done
interpretation skew!: StdPrio_no_invar skew_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

definition test_codegen where "test_codegen \<equiv> (
  skew.empty,
  skew.isEmpty,
  skew.find,
  skew.insert,
  skew.meld,
  skew.delete
)"

export_code test_codegen in SML

end


(*  Title:      ZF/ex/misc.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge

Composition of homomorphisms, Pastre's examples, ...
*)

section\<open>Miscellaneous ZF Examples\<close>

theory misc imports Main begin

subsection\<open>Various Small Problems\<close>

text\<open>The singleton problems are much harder in HOL.\<close>
lemma singleton_example_1:
     "\<forall>x \<in> S. \<forall>y \<in> S. x \<subseteq> y \<Longrightarrow> \<exists>z. S \<subseteq> {z}"
  by blast

lemma singleton_example_2:
     "\<forall>x \<in> S. \<Union>S \<subseteq> x \<Longrightarrow> \<exists>z. S \<subseteq> {z}"
  \<comment> \<open>Variant of the problem above.\<close>
  by blast

lemma "\<exists>!x. f (g(x)) = x \<Longrightarrow> \<exists>!y. g (f(y)) = y"
  \<comment> \<open>A unique fixpoint theorem --- \<open>fast\<close>/\<open>best\<close>/\<open>auto\<close> all fail.\<close>
  apply (erule ex1E, rule ex1I, erule subst_context)
  apply (rule subst, assumption, erule allE, rule subst_context, erule mp)
  apply (erule subst_context)
  done

text\<open>A weird property of ordered pairs.\<close>
lemma "b\<noteq>c ==> <a,b> \<inter> <a,c> = <a,a>"
by (simp add: Pair_def Int_cons_left Int_cons_right doubleton_eq_iff, blast)

text\<open>These two are cited in Benzmueller and Kohlhase's system description of
 LEO, CADE-15, 1998 (page 139-143) as theorems LEO could not prove.\<close>
lemma "(X = Y \<union> Z) \<longleftrightarrow> (Y \<subseteq> X & Z \<subseteq> X & (\<forall>V. Y \<subseteq> V & Z \<subseteq> V \<longrightarrow> X \<subseteq> V))"
by (blast intro!: equalityI)

text\<open>the dual of the previous one\<close>
lemma "(X = Y \<inter> Z) \<longleftrightarrow> (X \<subseteq> Y & X \<subseteq> Z & (\<forall>V. V \<subseteq> Y & V \<subseteq> Z \<longrightarrow> V \<subseteq> X))"
by (blast intro!: equalityI)

text\<open>trivial example of term synthesis: apparently hard for some provers!\<close>
schematic_goal "a \<noteq> b ==> a:?X & b \<notin> ?X"
by blast

text\<open>Nice blast benchmark.  Proved in 0.3s; old tactics can't manage it!\<close>
lemma "\<forall>x \<in> S. \<forall>y \<in> S. x \<subseteq> y ==> \<exists>z. S \<subseteq> {z}"
by blast

text\<open>variant of the benchmark above\<close>
lemma "\<forall>x \<in> S. \<Union>(S) \<subseteq> x ==> \<exists>z. S \<subseteq> {z}"
by blast

(*Example 12 (credited to Peter Andrews) from
 W. Bledsoe.  A Maximal Method for Set Variables in Automatic Theorem-proving.
 In: J. Hayes and D. Michie and L. Mikulich, eds.  Machine Intelligence 9.
 Ellis Horwood, 53-100 (1979). *)
lemma "(\<forall>F. {x} \<in> F \<longrightarrow> {y} \<in> F) \<longrightarrow> (\<forall>A. x \<in> A \<longrightarrow> y \<in> A)"
by best

text\<open>A characterization of functions suggested by Tobias Nipkow\<close>
lemma "r \<in> domain(r)->B  \<longleftrightarrow>  r \<subseteq> domain(r)*B & (\<forall>X. r `` (r -`` X) \<subseteq> X)"
by (unfold Pi_def function_def, best)

subsection\<open>Composition of homomorphisms is a Homomorphism\<close>

text\<open>Given as a challenge problem in
  R. Boyer et al.,
  Set Theory in First-Order Logic: Clauses for G\"odel's Axioms,
  JAR 2 (1986), 287-327\<close>

text\<open>collecting the relevant lemmas\<close>
declare comp_fun [simp] SigmaI [simp] apply_funtype [simp]

(*Force helps prove conditions of rewrites such as comp_fun_apply, since
  rewriting does not instantiate Vars.*)
lemma "(\<forall>A f B g. hom(A,f,B,g) =
           {H \<in> A->B. f \<in> A*A->A & g \<in> B*B->B &
                     (\<forall>x \<in> A. \<forall>y \<in> A. H`(f`<x,y>) = g`<H`x,H`y>)}) \<longrightarrow>
       J \<in> hom(A,f,B,g) & K \<in> hom(B,g,C,h) \<longrightarrow>
       (K O J) \<in> hom(A,f,C,h)"
by force

text\<open>Another version, with meta-level rewriting\<close>
lemma "(!! A f B g. hom(A,f,B,g) ==
           {H \<in> A->B. f \<in> A*A->A & g \<in> B*B->B &
                     (\<forall>x \<in> A. \<forall>y \<in> A. H`(f`<x,y>) = g`<H`x,H`y>)})
       ==> J \<in> hom(A,f,B,g) & K \<in> hom(B,g,C,h) \<longrightarrow> (K O J) \<in> hom(A,f,C,h)"
by force

subsection\<open>Pastre's Examples\<close>

text\<open>D Pastre.  Automatic theorem proving in set theory.
        Artificial Intelligence, 10:1--27, 1978.
Previously, these were done using ML code, but blast manages fine.\<close>

lemmas compIs [intro] = comp_surj comp_inj comp_fun [intro]
lemmas compDs [dest] =  comp_mem_injD1 comp_mem_surjD1
                        comp_mem_injD2 comp_mem_surjD2

lemma pastre1:
    "[| (h O g O f) \<in> inj(A,A);
        (f O h O g) \<in> surj(B,B);
        (g O f O h) \<in> surj(C,C);
        f \<in> A->B;  g \<in> B->C;  h \<in> C->A |] ==> h \<in> bij(C,A)"
by (unfold bij_def, blast)

lemma pastre3:
    "[| (h O g O f) \<in> surj(A,A);
        (f O h O g) \<in> surj(B,B);
        (g O f O h) \<in> inj(C,C);
        f \<in> A->B;  g \<in> B->C;  h \<in> C->A |] ==> h \<in> bij(C,A)"
by (unfold bij_def, blast)

lemma pastre4:
    "[| (h O g O f) \<in> surj(A,A);
        (f O h O g) \<in> inj(B,B);
        (g O f O h) \<in> inj(C,C);
        f \<in> A->B;  g \<in> B->C;  h \<in> C->A |] ==> h \<in> bij(C,A)"
by (unfold bij_def, blast)

lemma pastre5:
    "[| (h O g O f) \<in> inj(A,A);
        (f O h O g) \<in> surj(B,B);
        (g O f O h) \<in> inj(C,C);
        f \<in> A->B;  g \<in> B->C;  h \<in> C->A |] ==> h \<in> bij(C,A)"
by (unfold bij_def, blast)

lemma pastre6:
    "[| (h O g O f) \<in> inj(A,A);
        (f O h O g) \<in> inj(B,B);
        (g O f O h) \<in> surj(C,C);
        f \<in> A->B;  g \<in> B->C;  h \<in> C->A |] ==> h \<in> bij(C,A)"
by (unfold bij_def, blast)

end


(*  Title:      HOL/HOLCF/Sprod.thy
    Author:     Franz Regensburger
    Author:     Brian Huffman
*)

section {* The type of strict products *}

theory Sprod
imports Cfun
begin

default_sort pcpo

subsection {* Definition of strict product type *}

definition "sprod = {p::'a \<times> 'b. p = \<bottom> \<or> (fst p \<noteq> \<bottom> \<and> snd p \<noteq> \<bottom>)}"

pcpodef ('a, 'b) sprod (infixr "**" 20) = "sprod :: ('a \<times> 'b) set"
  unfolding sprod_def by simp_all

instance sprod :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
by (rule typedef_chfin [OF type_definition_sprod below_sprod_def])

type_notation (xsymbols)
  sprod  ("(_ \<otimes>/ _)" [21,20] 20)
type_notation (HTML output)
  sprod  ("(_ \<otimes>/ _)" [21,20] 20)

subsection {* Definitions of constants *}

definition
  sfst :: "('a ** 'b) \<rightarrow> 'a" where
  "sfst = (\<Lambda> p. fst (Rep_sprod p))"

definition
  ssnd :: "('a ** 'b) \<rightarrow> 'b" where
  "ssnd = (\<Lambda> p. snd (Rep_sprod p))"

definition
  spair :: "'a \<rightarrow> 'b \<rightarrow> ('a ** 'b)" where
  "spair = (\<Lambda> a b. Abs_sprod (seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b))"

definition
  ssplit :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> ('a ** 'b) \<rightarrow> 'c" where
  "ssplit = (\<Lambda> f p. seq\<cdot>p\<cdot>(f\<cdot>(sfst\<cdot>p)\<cdot>(ssnd\<cdot>p)))"

syntax
  "_stuple" :: "[logic, args] \<Rightarrow> logic"  ("(1'(:_,/ _:'))")

translations
  "(:x, y, z:)" == "(:x, (:y, z:):)"
  "(:x, y:)"    == "CONST spair\<cdot>x\<cdot>y"

translations
  "\<Lambda>(CONST spair\<cdot>x\<cdot>y). t" == "CONST ssplit\<cdot>(\<Lambda> x y. t)"

subsection {* Case analysis *}

lemma spair_sprod: "(seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b) \<in> sprod"
by (simp add: sprod_def seq_conv_if)

lemma Rep_sprod_spair: "Rep_sprod (:a, b:) = (seq\<cdot>b\<cdot>a, seq\<cdot>a\<cdot>b)"
by (simp add: spair_def cont_Abs_sprod Abs_sprod_inverse spair_sprod)

lemmas Rep_sprod_simps =
  Rep_sprod_inject [symmetric] below_sprod_def
  prod_eq_iff below_prod_def
  Rep_sprod_strict Rep_sprod_spair

lemma sprodE [case_names bottom spair, cases type: sprod]:
  obtains "p = \<bottom>" | x y where "p = (:x, y:)" and "x \<noteq> \<bottom>" and "y \<noteq> \<bottom>"
using Rep_sprod [of p] by (auto simp add: sprod_def Rep_sprod_simps)

lemma sprod_induct [case_names bottom spair, induct type: sprod]:
  "\<lbrakk>P \<bottom>; \<And>x y. \<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> P (:x, y:)\<rbrakk> \<Longrightarrow> P x"
by (cases x, simp_all)

subsection {* Properties of \emph{spair} *}

lemma spair_strict1 [simp]: "(:\<bottom>, y:) = \<bottom>"
by (simp add: Rep_sprod_simps)

lemma spair_strict2 [simp]: "(:x, \<bottom>:) = \<bottom>"
by (simp add: Rep_sprod_simps)

lemma spair_bottom_iff [simp]: "((:x, y:) = \<bottom>) = (x = \<bottom> \<or> y = \<bottom>)"
by (simp add: Rep_sprod_simps seq_conv_if)

lemma spair_below_iff:
  "((:a, b:) \<sqsubseteq> (:c, d:)) = (a = \<bottom> \<or> b = \<bottom> \<or> (a \<sqsubseteq> c \<and> b \<sqsubseteq> d))"
by (simp add: Rep_sprod_simps seq_conv_if)

lemma spair_eq_iff:
  "((:a, b:) = (:c, d:)) =
    (a = c \<and> b = d \<or> (a = \<bottom> \<or> b = \<bottom>) \<and> (c = \<bottom> \<or> d = \<bottom>))"
by (simp add: Rep_sprod_simps seq_conv_if)

lemma spair_strict: "x = \<bottom> \<or> y = \<bottom> \<Longrightarrow> (:x, y:) = \<bottom>"
by simp

lemma spair_strict_rev: "(:x, y:) \<noteq> \<bottom> \<Longrightarrow> x \<noteq> \<bottom> \<and> y \<noteq> \<bottom>"
by simp

lemma spair_defined: "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> (:x, y:) \<noteq> \<bottom>"
by simp

lemma spair_defined_rev: "(:x, y:) = \<bottom> \<Longrightarrow> x = \<bottom> \<or> y = \<bottom>"
by simp

lemma spair_below:
  "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> (:x, y:) \<sqsubseteq> (:a, b:) = (x \<sqsubseteq> a \<and> y \<sqsubseteq> b)"
by (simp add: spair_below_iff)

lemma spair_eq:
  "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> ((:x, y:) = (:a, b:)) = (x = a \<and> y = b)"
by (simp add: spair_eq_iff)

lemma spair_inject:
  "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>; (:x, y:) = (:a, b:)\<rbrakk> \<Longrightarrow> x = a \<and> y = b"
by (rule spair_eq [THEN iffD1])

lemma inst_sprod_pcpo2: "\<bottom> = (:\<bottom>, \<bottom>:)"
by simp

lemma sprodE2: "(\<And>x y. p = (:x, y:) \<Longrightarrow> Q) \<Longrightarrow> Q"
by (cases p, simp only: inst_sprod_pcpo2, simp)

subsection {* Properties of \emph{sfst} and \emph{ssnd} *}

lemma sfst_strict [simp]: "sfst\<cdot>\<bottom> = \<bottom>"
by (simp add: sfst_def cont_Rep_sprod Rep_sprod_strict)

lemma ssnd_strict [simp]: "ssnd\<cdot>\<bottom> = \<bottom>"
by (simp add: ssnd_def cont_Rep_sprod Rep_sprod_strict)

lemma sfst_spair [simp]: "y \<noteq> \<bottom> \<Longrightarrow> sfst\<cdot>(:x, y:) = x"
by (simp add: sfst_def cont_Rep_sprod Rep_sprod_spair)

lemma ssnd_spair [simp]: "x \<noteq> \<bottom> \<Longrightarrow> ssnd\<cdot>(:x, y:) = y"
by (simp add: ssnd_def cont_Rep_sprod Rep_sprod_spair)

lemma sfst_bottom_iff [simp]: "(sfst\<cdot>p = \<bottom>) = (p = \<bottom>)"
by (cases p, simp_all)

lemma ssnd_bottom_iff [simp]: "(ssnd\<cdot>p = \<bottom>) = (p = \<bottom>)"
by (cases p, simp_all)

lemma sfst_defined: "p \<noteq> \<bottom> \<Longrightarrow> sfst\<cdot>p \<noteq> \<bottom>"
by simp

lemma ssnd_defined: "p \<noteq> \<bottom> \<Longrightarrow> ssnd\<cdot>p \<noteq> \<bottom>"
by simp

lemma spair_sfst_ssnd: "(:sfst\<cdot>p, ssnd\<cdot>p:) = p"
by (cases p, simp_all)

lemma below_sprod: "(x \<sqsubseteq> y) = (sfst\<cdot>x \<sqsubseteq> sfst\<cdot>y \<and> ssnd\<cdot>x \<sqsubseteq> ssnd\<cdot>y)"
by (simp add: Rep_sprod_simps sfst_def ssnd_def cont_Rep_sprod)

lemma eq_sprod: "(x = y) = (sfst\<cdot>x = sfst\<cdot>y \<and> ssnd\<cdot>x = ssnd\<cdot>y)"
by (auto simp add: po_eq_conv below_sprod)

lemma sfst_below_iff: "sfst\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (:y, ssnd\<cdot>x:)"
apply (cases "x = \<bottom>", simp, cases "y = \<bottom>", simp)
apply (simp add: below_sprod)
done

lemma ssnd_below_iff: "ssnd\<cdot>x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (:sfst\<cdot>x, y:)"
apply (cases "x = \<bottom>", simp, cases "y = \<bottom>", simp)
apply (simp add: below_sprod)
done

subsection {* Compactness *}

lemma compact_sfst: "compact x \<Longrightarrow> compact (sfst\<cdot>x)"
by (rule compactI, simp add: sfst_below_iff)

lemma compact_ssnd: "compact x \<Longrightarrow> compact (ssnd\<cdot>x)"
by (rule compactI, simp add: ssnd_below_iff)

lemma compact_spair: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact (:x, y:)"
by (rule compact_sprod, simp add: Rep_sprod_spair seq_conv_if)

lemma compact_spair_iff:
  "compact (:x, y:) = (x = \<bottom> \<or> y = \<bottom> \<or> (compact x \<and> compact y))"
apply (safe elim!: compact_spair)
apply (drule compact_sfst, simp)
apply (drule compact_ssnd, simp)
apply simp
apply simp
done

subsection {* Properties of \emph{ssplit} *}

lemma ssplit1 [simp]: "ssplit\<cdot>f\<cdot>\<bottom> = \<bottom>"
by (simp add: ssplit_def)

lemma ssplit2 [simp]: "\<lbrakk>x \<noteq> \<bottom>; y \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> ssplit\<cdot>f\<cdot>(:x, y:) = f\<cdot>x\<cdot>y"
by (simp add: ssplit_def)

lemma ssplit3 [simp]: "ssplit\<cdot>spair\<cdot>z = z"
by (cases z, simp_all)

subsection {* Strict product preserves flatness *}

instance sprod :: (flat, flat) flat
proof
  fix x y :: "'a \<otimes> 'b"
  assume "x \<sqsubseteq> y" thus "x = \<bottom> \<or> x = y"
    apply (induct x, simp)
    apply (induct y, simp)
    apply (simp add: spair_below_iff flat_below_iff)
    done
qed

end


(*  Title:      HOL/Induct/Com.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1997  University of Cambridge

Example of Mutual Induction via Iteratived Inductive Definitions: Commands
*)

section\<open>Mutual Induction via Iteratived Inductive Definitions\<close>

theory Com imports MainRLT begin

typedecl loc
type_synonym state = "loc => nat"

datatype
  exp = N nat
      | X loc
      | Op "nat => nat => nat" exp exp
      | valOf com exp          ("VALOF _ RESULTIS _"  60)
and
  com = SKIP
      | Assign loc exp         (infixl ":=" 60)
      | Semi com com           ("_;;_"  [60, 60] 60)
      | Cond exp com com       ("IF _ THEN _ ELSE _"  60)
      | While exp com          ("WHILE _ DO _"  60)

subsection \<open>Commands\<close>

text\<open>Execution of commands\<close>

abbreviation (input)
  generic_rel  ("_/ -|[_]-> _" [50,0,50] 50)  where
  "esig -|[eval]-> ns == (esig,ns) \<in> eval"

text\<open>Command execution.  Natural numbers represent Booleans: 0=True, 1=False\<close>

inductive_set
  exec :: "((exp*state) * (nat*state)) set => ((com*state)*state)set"
  and exec_rel :: "com * state => ((exp*state) * (nat*state)) set => state => bool"
    ("_/ -[_]-> _" [50,0,50] 50)
  for eval :: "((exp*state) * (nat*state)) set"
  where
    "csig -[eval]-> s == (csig,s) \<in> exec eval"

  | Skip:    "(SKIP,s) -[eval]-> s"

  | Assign:  "(e,s) -|[eval]-> (v,s') ==> (x := e, s) -[eval]-> s'(x:=v)"

  | Semi:    "[| (c0,s) -[eval]-> s2; (c1,s2) -[eval]-> s1 |]
             ==> (c0 ;; c1, s) -[eval]-> s1"

  | IfTrue: "[| (e,s) -|[eval]-> (0,s');  (c0,s') -[eval]-> s1 |]
             ==> (IF e THEN c0 ELSE c1, s) -[eval]-> s1"

  | IfFalse: "[| (e,s) -|[eval]->  (Suc 0, s');  (c1,s') -[eval]-> s1 |]
              ==> (IF e THEN c0 ELSE c1, s) -[eval]-> s1"

  | WhileFalse: "(e,s) -|[eval]-> (Suc 0, s1)
                 ==> (WHILE e DO c, s) -[eval]-> s1"

  | WhileTrue:  "[| (e,s) -|[eval]-> (0,s1);
                    (c,s1) -[eval]-> s2;  (WHILE e DO c, s2) -[eval]-> s3 |]
                 ==> (WHILE e DO c, s) -[eval]-> s3"

declare exec.intros [intro]

inductive_cases
        [elim!]: "(SKIP,s) -[eval]-> t"
    and [elim!]: "(x:=a,s) -[eval]-> t"
    and [elim!]: "(c1;;c2, s) -[eval]-> t"
    and [elim!]: "(IF e THEN c1 ELSE c2, s) -[eval]-> t"
    and exec_WHILE_case: "(WHILE b DO c,s) -[eval]-> t"

text\<open>Justifies using "exec" in the inductive definition of "eval"\<close>
lemma exec_mono: "A<=B ==> exec(A) <= exec(B)"
apply (rule subsetI)
apply (simp add: split_paired_all)
apply (erule exec.induct)
apply blast+
done

lemma [pred_set_conv]:
  "((\<lambda>x x' y y'. ((x, x'), (y, y')) \<in> R) <= (\<lambda>x x' y y'. ((x, x'), (y, y')) \<in> S)) = (R <= S)"
  unfolding subset_eq
  by (auto simp add: le_fun_def)

lemma [pred_set_conv]:
  "((\<lambda>x x' y. ((x, x'), y) \<in> R) <= (\<lambda>x x' y. ((x, x'), y) \<in> S)) = (R <= S)"
  unfolding subset_eq
  by (auto simp add: le_fun_def)

text\<open>Command execution is functional (deterministic) provided evaluation is\<close>
theorem single_valued_exec: "single_valued ev ==> single_valued(exec ev)"
apply (simp add: single_valued_def)
apply (intro allI)
apply (rule impI)
apply (erule exec.induct)
apply (blast elim: exec_WHILE_case)+
done

subsection \<open>Expressions\<close>

text\<open>Evaluation of arithmetic expressions\<close>

inductive_set
  eval    :: "((exp*state) * (nat*state)) set"
  and eval_rel :: "[exp*state,nat*state] => bool"  (infixl "-|->" 50)
  where
    "esig -|-> ns == (esig, ns) \<in> eval"

  | N [intro!]: "(N(n),s) -|-> (n,s)"

  | X [intro!]: "(X(x),s) -|-> (s(x),s)"

  | Op [intro]: "[| (e0,s) -|-> (n0,s0);  (e1,s0)  -|-> (n1,s1) |]
                 ==> (Op f e0 e1, s) -|-> (f n0 n1, s1)"

  | valOf [intro]: "[| (c,s) -[eval]-> s0;  (e,s0)  -|-> (n,s1) |]
                    ==> (VALOF c RESULTIS e, s) -|-> (n, s1)"

  monos exec_mono

inductive_cases
        [elim!]: "(N(n),sigma) -|-> (n',s')"
    and [elim!]: "(X(x),sigma) -|-> (n,s')"
    and [elim!]: "(Op f a1 a2,sigma)  -|-> (n,s')"
    and [elim!]: "(VALOF c RESULTIS e, s) -|-> (n, s1)"

lemma var_assign_eval [intro!]: "(X x, s(x:=n)) -|-> (n, s(x:=n))"
  by (rule fun_upd_same [THEN subst]) fast

text\<open>Make the induction rule look nicer -- though \<open>eta_contract\<close> makes the new
    version look worse than it is...\<close>

lemma split_lemma: "{((e,s),(n,s')). P e s n s'} = Collect (case_prod (%v. case_prod (case_prod P v)))"
  by auto

text\<open>New induction rule.  Note the form of the VALOF induction hypothesis\<close>
lemma eval_induct
  [case_names N X Op valOf, consumes 1, induct set: eval]:
  "[| (e,s) -|-> (n,s');
      !!n s. P (N n) s n s;
      !!s x. P (X x) s (s x) s;
      !!e0 e1 f n0 n1 s s0 s1.
         [| (e0,s) -|-> (n0,s0); P e0 s n0 s0;
            (e1,s0) -|-> (n1,s1); P e1 s0 n1 s1
         |] ==> P (Op f e0 e1) s (f n0 n1) s1;
      !!c e n s s0 s1.
         [| (c,s) -[eval Int {((e,s),(n,s')). P e s n s'}]-> s0;
            (c,s) -[eval]-> s0;
            (e,s0) -|-> (n,s1); P e s0 n s1 |]
         ==> P (VALOF c RESULTIS e) s n s1
   |] ==> P e s n s'"
apply (induct set: eval)
apply blast
apply blast
apply blast
apply (frule Int_lower1 [THEN exec_mono, THEN subsetD])
apply (auto simp add: split_lemma)
done

text\<open>Lemma for \<open>Function_eval\<close>.  The major premise is that \<open>(c,s)\<close> executes to \<open>s1\<close>
  using eval restricted to its functional part.  Note that the execution
  \<open>(c,s) -[eval]-> s2\<close> can use unrestricted \<open>eval\<close>!  The reason is that
  the execution \<open>(c,s) -[eval Int {...}]-> s1\<close> assures us that execution is
  functional on the argument \<open>(c,s)\<close>.
\<close>
lemma com_Unique:
 "(c,s) -[eval Int {((e,s),(n,t)). \<forall>nt'. (e,s) -|-> nt' --> (n,t)=nt'}]-> s1
  ==> \<forall>s2. (c,s) -[eval]-> s2 --> s2=s1"
apply (induct set: exec)
      apply simp_all
      apply blast
     apply force
    apply blast
   apply blast
  apply blast
 apply (blast elim: exec_WHILE_case)
apply (erule_tac V = "(c,s2) -[ev]-> s3" for c ev in thin_rl)
apply clarify
apply (erule exec_WHILE_case, blast+)
done

text\<open>Expression evaluation is functional, or deterministic\<close>
theorem single_valued_eval: "single_valued eval"
apply (unfold single_valued_def)
apply (intro allI, rule impI)
apply (simp (no_asm_simp) only: split_tupled_all)
apply (erule eval_induct)
apply (drule_tac [4] com_Unique)
apply (simp_all (no_asm_use))
apply blast+
done

lemma eval_N_E [dest!]: "(N n, s) -|-> (v, s') ==> (v = n & s' = s)"
  by (induct e == "N n" s v s' set: eval) simp_all

text\<open>This theorem says that "WHILE TRUE DO c" cannot terminate\<close>
lemma while_true_E:
    "(c', s) -[eval]-> t ==> c' = WHILE (N 0) DO c ==> False"
  by (induct set: exec) auto

subsection\<open>Equivalence of IF e THEN c;;(WHILE e DO c) ELSE SKIP  and
       WHILE e DO c\<close>

lemma while_if1:
     "(c',s) -[eval]-> t
      ==> c' = WHILE e DO c ==>
          (IF e THEN c;;c' ELSE SKIP, s) -[eval]-> t"
  by (induct set: exec) auto

lemma while_if2:
     "(c',s) -[eval]-> t
      ==> c' = IF e THEN c;;(WHILE e DO c) ELSE SKIP ==>
          (WHILE e DO c, s) -[eval]-> t"
  by (induct set: exec) auto

theorem while_if:
     "((IF e THEN c;;(WHILE e DO c) ELSE SKIP, s) -[eval]-> t)  =
      ((WHILE e DO c, s) -[eval]-> t)"
by (blast intro: while_if1 while_if2)

subsection\<open>Equivalence of  (IF e THEN c1 ELSE c2);;c
                         and  IF e THEN (c1;;c) ELSE (c2;;c)\<close>

lemma if_semi1:
     "(c',s) -[eval]-> t
      ==> c' = (IF e THEN c1 ELSE c2);;c ==>
          (IF e THEN (c1;;c) ELSE (c2;;c), s) -[eval]-> t"
  by (induct set: exec) auto

lemma if_semi2:
     "(c',s) -[eval]-> t
      ==> c' = IF e THEN (c1;;c) ELSE (c2;;c) ==>
          ((IF e THEN c1 ELSE c2);;c, s) -[eval]-> t"
  by (induct set: exec) auto

theorem if_semi: "(((IF e THEN c1 ELSE c2);;c, s) -[eval]-> t)  =
                  ((IF e THEN (c1;;c) ELSE (c2;;c), s) -[eval]-> t)"
  by (blast intro: if_semi1 if_semi2)

subsection\<open>Equivalence of  VALOF c1 RESULTIS (VALOF c2 RESULTIS e)
                  and  VALOF c1;;c2 RESULTIS e
\<close>

lemma valof_valof1:
     "(e',s) -|-> (v,s')
      ==> e' = VALOF c1 RESULTIS (VALOF c2 RESULTIS e) ==>
          (VALOF c1;;c2 RESULTIS e, s) -|-> (v,s')"
  by (induct set: eval) auto

lemma valof_valof2:
     "(e',s) -|-> (v,s')
      ==> e' = VALOF c1;;c2 RESULTIS e ==>
          (VALOF c1 RESULTIS (VALOF c2 RESULTIS e), s) -|-> (v,s')"
  by (induct set: eval) auto

theorem valof_valof:
     "((VALOF c1 RESULTIS (VALOF c2 RESULTIS e), s) -|-> (v,s'))  =
      ((VALOF c1;;c2 RESULTIS e, s) -|-> (v,s'))"
  by (blast intro: valof_valof1 valof_valof2)

subsection\<open>Equivalence of  VALOF SKIP RESULTIS e  and  e\<close>

lemma valof_skip1:
     "(e',s) -|-> (v,s')
      ==> e' = VALOF SKIP RESULTIS e ==>
          (e, s) -|-> (v,s')"
  by (induct set: eval) auto

lemma valof_skip2:
    "(e,s) -|-> (v,s') ==> (VALOF SKIP RESULTIS e, s) -|-> (v,s')"
  by blast

theorem valof_skip:
    "((VALOF SKIP RESULTIS e, s) -|-> (v,s'))  =  ((e, s) -|-> (v,s'))"
  by (blast intro: valof_skip1 valof_skip2)

subsection\<open>Equivalence of  VALOF x:=e RESULTIS x  and  e\<close>

lemma valof_assign1:
     "(e',s) -|-> (v,s'')
      ==> e' = VALOF x:=e RESULTIS X x ==>
          (\<exists>s'. (e, s) -|-> (v,s') & (s'' = s'(x:=v)))"
  by (induct set: eval) (simp_all del: fun_upd_apply, clarify, auto)

lemma valof_assign2:
    "(e,s) -|-> (v,s') ==> (VALOF x:=e RESULTIS X x, s) -|-> (v,s'(x:=v))"
  by blast

end