(*
 * Copyright 2016, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

(*
 * Source: pass_simple-case3.cogent
 * To generate:
 *   cogent -gpass_simple-case3 --table-c-types=pass_simple-case3.table pass_simple-case3.cogent
 *   cogent --type-proof=Case --fml-typing-tree pass_simple-case3.cogent
*)
theory Case
imports
  "../Cogent_Corres"
  "../TypeProofGen"
  "../Heap_Relation_Generation" "../Type_Relation_Generation"
  "../Deep_Embedding_Auto"
  "../Corres_Tac"
  "../Tidy"
begin

definition
  "abbreviatedType1 \<equiv> TSum [(''Atag'', TPrim (Num U8)), (''Btag'', TPrim (Num U8)), (''Ctag'', TPrim (Num U8))]"

lemmas abbreviated_type_defs =
  abbreviatedType1_def

definition
  "foo_type \<equiv> ([], (abbreviatedType1, TPrim (Num U8)))"

definition
  "foo \<equiv> Case (Var 0) ''Atag'' (Var 0) (Case (Var 0) ''Btag'' (Var 0) (Let (Esac (Var 0)) (Var 0)))"

definition
  "\<Xi> func_name' \<equiv> case func_name' of ''foo'' \<Rightarrow> foo_type"

definition
  "foo_typetree \<equiv> TyTrSplit (Cons (Some TSK_L) []) [] TyTrLeaf [] (TyTrSplit (Cons None []) [Some (TPrim (Num U8))] TyTrLeaf [Some (TSum [(''Btag'', TPrim (Num U8)), (''Ctag'', TPrim (Num U8))])] (TyTrSplit (Cons (Some TSK_L) (Cons None [])) [] TyTrLeaf [] (TyTrSplit (append (replicate 2 None) []) [Some (TPrim (Num U8))] TyTrLeaf [Some (TSum [(''Ctag'', TPrim (Num U8))])] (TyTrSplit (Cons (Some TSK_L) (append (replicate 2 None) [])) [] TyTrLeaf [Some (TPrim (Num U8))] TyTrLeaf))))"

ML {* open TTyping_Tactics *}

ML_quiet {*
val typing_helper_1_script : tac list = [
(RTac @{thm kind_tprim})
] *}

lemma typing_helper_1[unfolded abbreviated_type_defs] :
  "kinding [] (TPrim (Num U8)) {E, S, D}"
  apply (unfold abbreviated_type_defs)?
  apply (tactic {* map (fn t => DETERM (interpret_tac t @{context} 1)) typing_helper_1_script |> EVERY *})
  done

ML_quiet {*
val typing_helper_2_script : tac list = [
(RTac @{thm kind_tsum[where k = "{E,S,D}"]}),
(SimpTac ([],[])),
(SimpTac ([],[])),
(RTac @{thm kind_all_cons}),
(RTac @{thm typing_helper_1}),
(RTac @{thm kind_all_cons}),
(RTac @{thm typing_helper_1}),
(RTac @{thm kind_all_cons}),
(RTac @{thm typing_helper_1}),
(RTac @{thm kind_all_empty})
] *}

lemma typing_helper_2[unfolded abbreviated_type_defs] :
  "kinding [] abbreviatedType1 {E, S, D}"
  apply (unfold abbreviated_type_defs)?
  apply (tactic {* map (fn t => DETERM (interpret_tac t @{context} 1)) typing_helper_2_script |> EVERY *})
  done

ML_quiet {*
val typing_helper_3_script : tac list = [
(RTac @{thm kind_tsum[where k = "{E,S,D}"]}),
(SimpTac ([],[])),
(SimpTac ([],[])),
(RTac @{thm kind_all_cons}),
(RTac @{thm typing_helper_1}),
(RTac @{thm kind_all_cons}),
(RTac @{thm typing_helper_1}),
(RTac @{thm kind_all_empty})
] *}

lemma typing_helper_3[unfolded abbreviated_type_defs] :
  "kinding [] (TSum [(''Btag'', TPrim (Num U8)), (''Ctag'', TPrim (Num U8))]) {E, S, D}"
  apply (unfold abbreviated_type_defs)?
  apply (tactic {* map (fn t => DETERM (interpret_tac t @{context} 1)) typing_helper_3_script |> EVERY *})
  done

ML_quiet {*
val typing_helper_4_script : tac list = [
(RTac @{thm kind_tsum[where k = "{E,S,D}"]}),
(SimpTac ([],[])),
(SimpTac ([],[])),
(RTac @{thm kind_all_cons}),
(RTac @{thm typing_helper_1}),
(RTac @{thm kind_all_empty})
] *}

lemma typing_helper_4[unfolded abbreviated_type_defs] :
  "kinding [] (TSum [(''Ctag'', TPrim (Num U8))]) {E, S, D}"
  apply (unfold abbreviated_type_defs)?
  apply (tactic {* map (fn t => DETERM (interpret_tac t @{context} 1)) typing_helper_4_script |> EVERY *})
  done

ML_quiet {*
val foo_typecorrect_script : hints list = [
KindingTacs [(RTac @{thm typing_helper_2})],
KindingTacs [(RTac @{thm typing_helper_1})],
KindingTacs [(RTac @{thm typing_helper_3})],
TypingTacs [],
TypingTacs [],
KindingTacs [(RTac @{thm typing_helper_1})],
KindingTacs [(RTac @{thm typing_helper_4})],
TypingTacs [],
TypingTacs [],
KindingTacs [(RTac @{thm typing_helper_1})],
TypingTacs [(RTac @{thm typing_esac}),(RTac @{thm typing_var}),(SimpTac ([@{thm empty_def}],[])),(WeakeningTac [@{thm typing_helper_4}]),(SimpTac ([],[]))],
TypingTacs []
] *}

ML_quiet {*
val foo_ttyping_details_future = get_all_typing_details_future @{context} "foo"
   foo_typecorrect_script*}

lemma foo_typecorrect :
  "\<Xi>, fst foo_type, (foo_typetree, [Some (fst (snd foo_type))]) T\<turnstile> foo : snd (snd foo_type)"
  apply (tactic {* resolve_future_typecorrect @{context} foo_ttyping_details_future *})
  done

ML_quiet {*
val (_, foo_typing_tree, foo_typing_bucket)
= Future.join foo_ttyping_details_future
*}

new_C_include_dir "../../cogent/lib"
install_C_file "pass_simple-case3.c"
autocorres [ts_rules=nondet, no_opt, skip_word_abs] "pass_simple-case3.c"

instantiation bool_t_C :: cogent_C_val
begin
definition type_rel_bool_t_C_def:
  "type_rel typ (_ :: bool_t_C itself) \<equiv> (typ = RPrim Bool)"

definition val_rel_bool_t_C_def:
  "val_rel uv (x :: bool_t_C) \<equiv> uv = UPrim (LBool (bool_t_C.boolean_C x \<noteq> 0))"
instance ..
end

(* C type and value relations *)
instantiation unit_t_C :: cogent_C_val
begin
  definition type_rel_unit_t_C_def: "type_rel r (_ :: unit_t_C itself) \<equiv> r = RUnit"
  definition val_rel_unit_t_C_def: "val_rel uv (_ :: unit_t_C) \<equiv> uv = UUnit"
  instance ..
end

(* Automatically generated relations *)
local_setup{* local_setup_val_rel_type_rel_put_them_in_buckets "pass_simple-case3.c" *}
print_theorems

(* Manually written relations *)
lemmas type_rel_simps =
  type_rel_word type_rel_ptr_def type_rel_unit_def type_rel_unit_t_C_def

lemmas val_rel_simps =
  val_rel_word val_rel_ptr_def val_rel_unit_def val_rel_unit_t_C_def

context update_sem_init
begin

(* Automatically generate specialised lemmas and store them in buckets.*)
local_setup{* local_setup_take_put_member_case_esac_specialised_lemmas "pass_simple-case3.c" *}

end
locale case_cogent = "pass_simple-case3" + update_sem_init
begin

find_theorems TAG_ENUM_Btag corres
thm corres_case_t2_1th_field[no_vars]

(* Preprocess AutoCorres output *)
local_setup {* tidy_C_fun_def' "foo" *}

lemmas list_to_map_simps = list_to_map_more[where f=Var] list_to_map_singleton[where f=Var]

(* TODO: automate this. Do not include LETBANG_TRUE_def in the same bucket.*)
lemmas tag_enum_defs =
  TAG_ENUM_Atag_def
  TAG_ENUM_Btag_def
  TAG_ENUM_Ctag_def

lemmas corres_nested_let = TrueI (* unused *)
lemmas corres_if = TrueI (* unused *)

lemma foo_corres:
  "val_rel (\<gamma> ! 0) a1 \<Longrightarrow>
   corres state_rel foo (foo' a1) \<xi> \<gamma> \<Xi> [Some (fst (snd foo_type))] \<sigma> s"
  apply (tactic {* corres_tac @{context} (peel_two foo_typing_tree)
                   @{thms foo_def foo'_def' foo_type_def abbreviated_type_defs} [] []
                   @{thm corres_if} @{thms corres_esacs} @{thms val_rel_simps} @{thms type_rel_simps}
                   @{thms tag_enum_defs} @{thm LETBANG_TRUE_def} @{thms list_to_map_simps} true *})
  done

end
end


theory Mapreduce
  imports EventSystem
begin

subsection \<open>Events\<close>

datatype event =
  QUERY "nat \<times> nat list"
| RESPOND nat
| TICK
| INIT

subsection \<open>Implementation of server\<close>

record server =
  input :: "nat list"
  index :: nat
  cursum :: nat
  returned :: bool

text \<open>Add a query\<close>
definition query_impl :: "nat list \<Rightarrow> (server, event, unit) event_monad" where
  "query_impl xs = put (\<lparr>input = xs, index = 0, cursum = 0, returned = False\<rparr>)"

theorem query_impl_rule:
  "\<lbrace> \<lambda>s es. s = s0 \<and> es = [] \<rbrace>
     query_impl xs
   \<lbrace> \<lambda>_ s es. s = \<lparr>input = xs, index = 0, cursum = 0, returned = False\<rparr> \<and> es = [] \<rbrace>!"
  unfolding query_impl_def apply wp by auto

text \<open>Implementation of tick: if there is a job present,
  nondeterministically advance one index.\<close>
definition tick_node_impl :: "(server, event, unit) event_monad" where
  "tick_node_impl = (get \<bind> (\<lambda>s.
   (if \<not>returned s then
      if index s = length (input s) then
        signal (RESPOND (cursum s)) \<bind> (\<lambda>_. put (s\<lparr>returned := True\<rparr>))
      else
        put (s\<lparr>index := index s + 1, cursum := cursum s + input s ! (index s)\<rparr>)
    else
      skip) \<squnion> skip))"

definition tick_node_fun :: "server \<Rightarrow> server \<times> event list" where
  "tick_node_fun s =
    (if \<not>returned s then
       if index s = length (input s) then
         (s\<lparr>returned := True\<rparr>, [RESPOND (cursum s)])
       else
         (s\<lparr>index := index s + 1, cursum := cursum s + input s ! (index s)\<rparr>, [])
     else
       (s, []))"

lemma tick_node_rule:
  "\<lbrace> \<lambda>s es. s = s0 \<and> es = [] \<rbrace>
     tick_node_impl
   \<lbrace> \<lambda>_ s es. (s = fst (tick_node_fun s0) \<and> es = snd (tick_node_fun s0)) \<or>
              (s = s0 \<and> es = []) \<rbrace>!"
  unfolding tick_node_impl_def
  apply (rule validNF_bind)
   apply (rule validNF_get_post)
  subgoal for s'
    apply (subst validNF_conj_pre) apply (rule impI)
    apply (rule validNF_nondet2)
    subgoal apply wp by (auto simp add: tick_node_fun_def)
    subgoal by wp
    done
  done

fun node_inv :: "nat list \<times> bool \<Rightarrow> server \<Rightarrow> bool" where
  "node_inv (xs, b) s = (
    if b then returned s else
    input s = xs \<and> index s \<le> length xs \<and> \<not>returned s \<and>
    cursum s = sum (\<lambda>i. input s ! i) {0 ..< index s})"

definition sum_list :: "nat list \<Rightarrow> nat" where
  "sum_list xs = sum (\<lambda>i. xs ! i) {0 ..< length xs}"

lemma tick_node_fun_inv:
  assumes "node_inv (xs, False) s"
  shows "(node_inv (xs, False) (fst (tick_node_fun s)) \<and> snd (tick_node_fun s) = []) \<or>
         (node_inv (xs, True) (fst (tick_node_fun s)) \<and> snd (tick_node_fun s) = [RESPOND (sum_list xs)])"
  using assms unfolding node_inv.simps tick_node_fun_def sum_list_def by auto

lemma tick_node_rule2:
  "node_inv (xs, False) s0 \<Longrightarrow>
   \<lbrace> \<lambda>s es. s = s0 \<and> es = [] \<rbrace>
     tick_node_impl
   \<lbrace> \<lambda>_ s es. (node_inv (xs, False) s \<and> es = []) \<or>
              (node_inv (xs, True) s \<and> es = [RESPOND (sum_list xs)]) \<rbrace>!"
  apply (rule validNF_strengthen_post)
   apply (rule tick_node_rule)
  using tick_node_fun_inv by auto

lemma tick_node_rule3:
  "\<lbrace> \<lambda>s es. node_inv (xs, False) s \<and> es = [] \<rbrace>
     tick_node_impl
   \<lbrace> \<lambda>_ s es. (node_inv (xs, False) s \<and> es = []) \<or>
              (node_inv (xs, True) s \<and> es = [RESPOND (sum_list xs)]) \<rbrace>!"
  apply (rule validNF_weaken_pre[where Q="\<lambda>s es. \<exists>s0. node_inv (xs, False) s0 \<and> s = s0 \<and> es = []"])
   apply (rule validNF_ex_pre)
  subgoal for s0 apply (subst validNF_conj_pre)
    using tick_node_rule2 by auto
  by auto

lemma tick_node_rule4:
  "node_inv (xs, True) s0 \<Longrightarrow>
   \<lbrace> \<lambda>s es. s = s0 \<and> es = [] \<rbrace>
     tick_node_impl
   \<lbrace> \<lambda>_ s es. node_inv (xs, True) s \<and> es = [] \<rbrace>!"
  apply (rule validNF_strengthen_post)
   apply (rule tick_node_rule)
  by (auto simp add: tick_node_fun_def)

lemma tick_node_rule5:
  "\<lbrace> \<lambda>s es. node_inv (xs, True) s \<and> es = [] \<rbrace>
     tick_node_impl
   \<lbrace> \<lambda>_ s es. node_inv (xs, True) s \<and> es = [] \<rbrace>!"
  apply (rule validNF_weaken_pre[where Q="\<lambda>s es. \<exists>s0. node_inv (xs, True) s0 \<and> s = s0 \<and> es = []"])
  apply (rule validNF_ex_pre)
  subgoal for s0 apply (subst validNF_conj_pre)
    using tick_node_rule4 by auto
  by auto

lemma tick_node_rule6:
  "\<lbrace> \<lambda>s es. node_inv (xs, b) s \<and> es = [] \<rbrace>
     tick_node_impl
   \<lbrace> \<lambda>_ s es. (node_inv (xs, b) s \<and> es = []) \<or> (b = False \<and> node_inv (xs, True) s \<and> es = [RESPOND (sum_list xs)]) \<rbrace>!"
  apply (cases b)
  using tick_node_rule3 tick_node_rule5 by auto

record client =
  num_received :: nat
  acc :: nat
  alldone :: bool

text \<open>Implementation of respond\<close>
definition respond_impl :: "nat \<Rightarrow> nat \<Rightarrow> (client, event, unit) event_monad" where
  "respond_impl N a = (get \<bind> (\<lambda>s.
    put (s\<lparr>acc := acc s + a, num_received := num_received s + 1\<rparr>)) \<bind> (\<lambda>_.
    get \<bind> (\<lambda>s.
    if num_received s = N then
      put (s\<lparr>alldone := True\<rparr>)
    else
      skip)))"

definition respond_fun :: "nat \<Rightarrow> nat \<Rightarrow> client \<Rightarrow> client" where
  "respond_fun N a s = (let s' = s\<lparr>acc := acc s + a, num_received := num_received s + 1\<rparr> in
                    if num_received s' = N then s'\<lparr>alldone := True\<rparr> else s')"

theorem validNF_respond:
  "\<lbrace> \<lambda>s es. s = s0 \<and> es = [] \<rbrace>
     respond_impl N a
   \<lbrace> \<lambda>_ s es. s = respond_fun N a s0 \<and> es = [] \<rbrace>!"
  unfolding respond_impl_def
  apply wp by (auto simp add: respond_fun_def)

text \<open>Implementation of init\<close>
definition init_impl :: "nat \<Rightarrow> nat list list \<Rightarrow> (client, event, unit) event_monad" where
  "init_impl N data = (
    whileLoop (\<lambda>i _. i < N)
      (\<lambda>i. signal (QUERY (i, data ! i)) \<bind> (\<lambda>_.
           return (Suc i))) 0) \<bind> (\<lambda>_. return ())"

subsection \<open>Verify the event system\<close>

definition tick_impl :: "nat \<Rightarrow> (server list \<times> client, event, unit) event_monad" where
  "tick_impl N = (
    whileLoop (\<lambda>i _. i < N)
      (\<lambda>i. apply_fst (apply_idx tick_node_impl i) \<bind> (\<lambda>_.
           return (Suc i))) 0) \<bind> (\<lambda>_. return ())"

fun system :: "nat \<Rightarrow> nat list list \<Rightarrow> (event, server list \<times> client) event_system" where
  "system N data (QUERY (i, xs)) = Some (apply_fst (apply_idx (query_impl xs) i))"
| "system N data (RESPOND a) = Some (apply_snd (respond_impl N a))"
| "system N data TICK = Some (tick_impl N)"
| "system N data INIT = Some (apply_snd (init_impl N data))"

definition server_inv :: "nat \<Rightarrow> nat list list \<Rightarrow> bool list \<Rightarrow> server list \<Rightarrow> bool" where
  "server_inv N data bs ss =
    (length bs = N \<and> length ss = N \<and>
    (\<forall>i. i < N \<longrightarrow> node_inv (data ! i, bs ! i) (ss ! i)))"

fun tick_events :: "nat \<Rightarrow> bool list \<Rightarrow> bool list \<Rightarrow> nat list list \<Rightarrow> nat \<Rightarrow> event list" where
  "tick_events N bs bs' xss 0 = []"
| "tick_events N bs bs' xss (Suc i) =
    (if \<not>bs ! i \<and> bs' ! i then tick_events N bs bs' xss i @ [RESPOND (sum_list (xss ! i))]
     else tick_events N bs bs' xss i)"

lemma tick_events_cong:
  "\<forall>i<r. bs1 ! i = bs2 ! i \<Longrightarrow> tick_events N bs bs1 xss r = tick_events N bs bs2 xss r"
  apply (induction r) by auto

definition dominates :: "nat \<Rightarrow> bool list \<Rightarrow> bool list \<Rightarrow> bool" where
  "dominates N bs bs' = (\<forall>i<N. bs ! i \<longrightarrow> bs' ! i)"

lemma tick_rule:
  "\<lbrace> \<lambda>p es. server_inv N xss bs (fst p) \<and> snd p = c0 \<and> nil\<^sub>e es \<rbrace>
     tick_impl N
   \<lbrace> \<lambda>_ p es. \<exists>bs'. server_inv N xss bs' (fst p) \<and> dominates N bs bs' \<and> snd p = c0 \<and> es = tick_events N bs bs' xss N \<rbrace>!"
  unfolding tick_impl_def
  apply (rule validNF_bind) prefer 2 apply (rule validNF_return)
  apply (rule validNF_whileLoop[where
        I="\<lambda>i p es. i \<le> N \<and> (\<exists>bs'. server_inv N xss bs' (fst p) \<and>
              length bs' = N \<and> dominates N bs bs' \<and> (\<forall>j\<ge>i. bs ! j = bs' ! j) \<and>
              snd p = c0 \<and> es = tick_events N bs bs' xss i)" and
        R="measure (\<lambda>(i,p). (N - i))"])
  subgoal for p es
    apply (rule conjI) apply simp
    apply (rule exI[where x=bs])
    by (auto simp add: nil_event_def server_inv_def dominates_def)
  subgoal for r s
    apply (rule validNF_bind) prefer 2
     apply (rule validNF_return)
    apply (rule validNF_weaken_pre[where
          Q="\<lambda>p es. r < N \<and> (\<exists>bs'. (length bs' = N \<and> dominates N bs bs' \<and>
                (\<forall>i\<ge>r. bs ! i = bs' ! i)) \<and>
                (server_inv N xss bs' (fst p) \<and> es = tick_events N bs bs' xss r) \<and> snd p = c0)"])
     prefer 2 subgoal by auto
    apply (subst validNF_conj_pre) apply (rule impI)
    apply (rule validNF_ex_pre) subgoal premises pre for bs'
      apply (subst validNF_conj_pre) apply (rule impI)
      apply (subst server_inv_def)
      apply (rule validNF_strengthen_post)
       apply (rule validNF_apply_fst)
       apply (rule validNF_frame)
       apply (rule validNF_weaken_pre[where
            Q="\<lambda>p es. length p = N \<and> (\<forall>i. i < N \<longrightarrow> node_inv (xss ! i, bs' ! i) (p ! i)) \<and> nil\<^sub>e es"])
        prefer 2 subgoal by (auto simp add: nil_event_def)
       apply (rule validNF_apply_idx2)
      unfolding nil_event_def apply (rule tick_node_rule6)
      apply (rule pre)
      subgoal for r' s' es'
        unfolding chop_event_def apply clarify subgoal for es1 es2
          apply (elim disjE)
          subgoal
            apply (intro conjI)
            subgoal using pre by auto
            subgoal apply (rule exI[where x=bs'])
              by (auto simp add: server_inv_def)
            subgoal using pre by auto
            done
          subgoal
            apply (intro conjI)
            subgoal using pre by auto
            subgoal apply (rule exI[where x="bs'[r := True]"])
              apply (intro conjI)
              subgoal unfolding server_inv_def
                apply (rule conjI) apply simp
                apply clarify subgoal for i apply (cases "i = r")
                  subgoal by auto
                  subgoal by auto
                  done
                done
              subgoal by auto
              subgoal by (metis dominates_def nth_list_update pre)
              subgoal by auto
              subgoal by auto
              subgoal unfolding tick_events.simps
                using pre by (auto simp add: tick_events_cong)
              done
            subgoal using pre by auto
            done
          done
        done
      done
    done
  subgoal by auto
  subgoal by auto
  done

lemma sValidNF_Respond:
  "sValidNF (system N data)
    (\<lambda>p es. P (fst p) \<and> snd p = c \<and> nil\<^sub>e es)
    (RESPOND a)
    (\<lambda>p es. P (fst p) \<and> snd p = respond_fun N a c \<and> nil\<^sub>e es)"
  apply (rule sValidNF_weaken_pre[where P="\<lambda>p es. (P (fst p) \<and> snd p = c) \<and> nil\<^sub>e es"])
  apply simp
  apply (rule sValidNF_Some)
  apply (rule system.simps)
  apply (rule validNF_weaken_pre)
  apply (rule validNF_apply_snd[where R="\<lambda>s. P s"])
    apply (rule validNF_respond)
   apply (auto simp add: nil_event_def)
  apply (rule sValidNF_list_strengthen_post)
  prefer 2
   apply (rule sValidNF_list_null)
  by auto

fun sum_tick_events :: "nat \<Rightarrow> bool list \<Rightarrow> bool list \<Rightarrow> nat list list \<Rightarrow> nat \<Rightarrow> nat" where
  "sum_tick_events N bs bs' xss 0 = 0"
| "sum_tick_events N bs bs' xss (Suc i) =
    (if \<not>bs ! i \<and> bs' ! i then sum_tick_events N bs bs' xss i + sum_list (xss ! i)
     else sum_tick_events N bs bs' xss i)"

fun count_tick_events :: "nat \<Rightarrow> bool list \<Rightarrow> bool list \<Rightarrow> nat list list \<Rightarrow> nat \<Rightarrow> nat" where
  "count_tick_events N bs bs' xss 0 = 0"
| "count_tick_events N bs bs' xss (Suc i) =
    (if \<not>bs ! i \<and> bs' ! i then count_tick_events N bs bs' xss i + 1
     else count_tick_events N bs bs' xss i)"

lemma sValidNF_Respond_tick_events:
  assumes "num_received c \<ge> N \<longleftrightarrow> alldone c"
  shows
  "sValidNF_list (system N data)
    (\<lambda>p es. P (fst p) \<and> snd p = c \<and> nil\<^sub>e es)
    (tick_events N bs bs' data i)
    (\<lambda>p es. P (fst p) \<and> snd p = c\<lparr>acc := acc c + sum_tick_events N bs bs' data i,
         num_received := num_received c + count_tick_events N bs bs' data i,
         alldone := alldone c \<or> (\<exists>i'\<le>i. num_received c + count_tick_events N bs bs' data i' = N)\<rparr> \<and> nil\<^sub>e es)"
proof (induction i)
  case 0
  then show ?case
    apply auto
    apply (rule sValidNF_list_strengthen_post) prefer 2
     apply (rule sValidNF_list_null)
    using assms by auto
next
  case (Suc i)
  show ?case
    apply (cases "\<not>bs ! i \<and> bs' ! i")
    subgoal apply auto
      apply (rule sValidNF_list_append)
       apply (rule Suc)
      apply (rule sValidNF_list_single)
      apply (rule sValidNF_strengthen_post)
      prefer 2
      apply (rule sValidNF_Respond)
      apply (auto simp add: respond_fun_def Let_def)
      subgoal premises pre for es
      proof -
        have "num_received c + count_tick_events N bs bs' data (Suc i) = N"
          using pre by auto
        then have "\<exists>i'\<le>Suc i. num_received c + count_tick_events N bs bs' data i' = N"
          by auto
        then show ?thesis
          by auto
      qed
      subgoal premises pre for es
      proof -
        have "num_received c + count_tick_events N bs bs' data (Suc i) \<noteq> N"
          using pre by auto
        then have "(\<exists>i'\<le>i. num_received c + count_tick_events N bs bs' data i' = N) \<longleftrightarrow>
                   (\<exists>i'\<le>Suc i. num_received c + count_tick_events N bs bs' data i' = N)"
          using le_Suc_eq by blast
        then show ?thesis
          by auto
      qed
      done
    subgoal premises pre
    proof -
      have "count_tick_events N bs bs' data (Suc i) = count_tick_events N bs bs' data i"
        using pre by auto
      then have a: "(\<exists>i'\<le>i. num_received c + count_tick_events N bs bs' data i' = N) \<longleftrightarrow>
                 (\<exists>i'\<le>Suc i. num_received c + count_tick_events N bs bs' data i' = N)"
        by (metis le_Suc_eq pl_pl_rels)
      show ?thesis
        apply (auto simp add: pre)
        apply (rule sValidNF_list_strengthen_post)
         prefer 2 apply (rule Suc)
        using a by auto
    qed
    done
qed

lemma sValidNF_Tick:
  assumes "num_received c0 \<ge> N \<longleftrightarrow> alldone c0"
  shows
  "sValidNF (system N data)
    (\<lambda>p es. server_inv N data bs (fst p) \<and> snd p = c0 \<and> nil\<^sub>e es)
    TICK
    (\<lambda>p es. \<exists>bs'. server_inv N data bs' (fst p) \<and> dominates N bs bs' \<and>
        snd p = c0\<lparr>acc := acc c0 + sum_tick_events N bs bs' data N,
                   num_received := num_received c0 + count_tick_events N bs bs' data N,
                   alldone := alldone c0 \<or> (\<exists>i'\<le>N. num_received c0 + count_tick_events N bs bs' data i' = N)\<rparr> \<and> nil\<^sub>e es)"
  apply (rule sValidNF_weaken_pre[where P="\<lambda>p es. (server_inv N data bs (fst p) \<and> snd p = c0) \<and> nil\<^sub>e es"])
  apply simp
  apply (rule sValidNF_Some)
  apply (rule system.simps)
   apply (subst conj_assoc)
  apply (rule tick_rule)
  subgoal for p es
    apply clarify subgoal for bs'
      apply (rule sValidNF_list_strengthen_post) prefer 2
       apply (rule sValidNF_list_weaken_pre[where P="\<lambda>p es. server_inv N data bs' (fst p) \<and> snd p = c0 \<and> nil\<^sub>e es"])
      apply auto[1]
      apply (rule sValidNF_Respond_tick_events[OF assms])
      subgoal for p' es'
        apply (rule exI[where x=bs'])
        by auto
      done
    done
  done

fun system_inv :: "nat \<Rightarrow> nat list list \<Rightarrow> server list \<times> client \<Rightarrow> bool" where
  "system_inv N data (ss, c) =
    (\<exists>bs. server_inv N data bs ss \<and>
          num_received c = sum (\<lambda>i. if bs ! i then 1 else 0) {0 ..< N} \<and>
          acc c = sum (\<lambda>i. if bs ! i then sum_list (data ! i) else 0) {0 ..< N} \<and>
          alldone c = (num_received c \<ge> N))"

lemma dominates_num_received':
  assumes "dominates N bs bs'"
  shows
    "k \<le> N \<Longrightarrow>
     sum (\<lambda>i. if bs ! i then 1 else 0) {0 ..< k} + count_tick_events N bs bs' data k =
     sum (\<lambda>i. if bs' ! i then 1 else 0) {0 ..< k}"
proof (induction k)
  case 0
  then show ?case by auto
next
  case (Suc k)
  show ?case
    apply auto
    subgoal using Suc by auto
    subgoal using Suc by auto
    subgoal using assms(1) unfolding dominates_def
      using Suc by simp
    done
qed

lemma dominates_num_received:
  "dominates N bs bs' \<Longrightarrow>
   sum (\<lambda>i. if bs ! i then 1 else 0) {0 ..< N} + count_tick_events N bs bs' data N =
   sum (\<lambda>i. if bs' ! i then 1 else 0) {0 ..< N}"
  using dominates_num_received' by auto

lemma dominates_acc':
  assumes "dominates N bs bs'"
  shows
    "k \<le> N \<Longrightarrow>
      sum (\<lambda>i. if bs ! i then sum_list (data ! i) else 0) {0 ..< k} + sum_tick_events N bs bs' data k =
      sum (\<lambda>i. if bs' ! i then sum_list (data ! i) else 0) {0 ..< k}"
proof (induction k)
  case 0
  then show ?case by auto
next
  case (Suc k)
  show ?case
    apply auto
    subgoal using Suc by auto
    subgoal using Suc by auto
    subgoal using assms(1) unfolding dominates_def
      using Suc by simp
    done
qed

lemma dominates_acc:
  "dominates N bs bs' \<Longrightarrow>
   sum (\<lambda>i. if bs ! i then sum_list (data ! i) else 0) {0 ..< N} + sum_tick_events N bs bs' data N =
   sum (\<lambda>i. if bs' ! i then sum_list (data ! i) else 0) {0 ..< N}"
  using dominates_acc' by auto

lemma count_tick_events_mono:
  "count_tick_events N bs bs' data i \<le> count_tick_events N bs bs' data (a + i)"
  apply (induction a) by auto

lemma count_tick_events_mono2:
  "i \<le> j \<Longrightarrow> count_tick_events N bs bs' data i \<le> count_tick_events N bs bs' data j"
  using count_tick_events_mono
  by (metis add.commute nat_le_iff_add)

lemma count_tick_events_dense:
  "a \<le> count_tick_events N bs bs' data j \<Longrightarrow> \<exists>i\<le>j. a = count_tick_events N bs bs' data i"
proof (induction j)
  case 0
  then show ?case by auto
next
  case (Suc j)
  have "a \<le> count_tick_events N bs bs' data j + 1"
    using Suc(2) apply (cases "\<not> bs ! j \<and> bs' ! j") by auto
  have "a \<le> count_tick_events N bs bs' data j + 1"
    using Suc(2) apply (cases "\<not> bs ! j \<and> bs' ! j") by auto
  then have "a = count_tick_events N bs bs' data j + 1 \<or> a \<le> count_tick_events N bs bs' data j"
    by auto
  then show ?case
    apply (elim disjE)
    subgoal apply (rule exI[where x="Suc j"])
      by (metis Suc.prems add_diff_cancel_left' add_le_cancel_right count_tick_events.simps(2)
                diff_is_0_eq' le_numeral_extra(4) plus_1_eq_Suc zero_neq_one)
    subgoal using Suc(1)
      by (meson le_SucI)
    done
qed

lemma count_tick_events_dense2:
  assumes "N > num_received c0"
    and "N \<le> num_received c0 + count_tick_events N bs bs' data N"
  shows "\<exists>i\<le>N. N = num_received c0 + count_tick_events N bs bs' data i"
proof -
  have a: "N - num_received c0 \<le> count_tick_events N bs bs' data N"
    using assms by auto
  then obtain i where b: "i \<le> N" "N - num_received c0 = count_tick_events N bs bs' data i"
    using count_tick_events_dense by blast
  then have c: "N = num_received c0 + count_tick_events N bs bs' data i"
    using assms by auto
  show ?thesis
    using b c by auto
qed

lemma count_tick_events_incr:
  "(N \<le> num_received c0 \<or> (\<exists>i'\<le>N. num_received c0 + count_tick_events N bs bs' data i' = N)) \<longleftrightarrow>
   (N \<le> num_received c0 + count_tick_events N bs bs' data N)"
  apply (rule iffI, elim disjE)
  subgoal by auto
  subgoal using count_tick_events_mono2
    by (metis add_left_mono)
  subgoal using count_tick_events_dense2
    by (metis not_le_imp_less)
  done

lemma sValidNF_Tick2:
  "sValidNF (system N data)
    (\<lambda>p es. system_inv N data p \<and> nil\<^sub>e es)
    TICK
    (\<lambda>p es. system_inv N data p \<and> nil\<^sub>e es)"
  apply (rule sValidNF_weaken_pre[where
        P="\<lambda>p es. \<exists>bs c0. (num_received c0 \<ge> N \<longleftrightarrow> alldone c0) \<and>
            num_received c0 = sum (\<lambda>i. if bs ! i then 1 else 0) {0 ..< N} \<and>
            acc c0 = sum (\<lambda>i. if bs ! i then sum_list (data ! i) else 0) {0 ..< N} \<and>
            server_inv N data bs (fst p) \<and>
            snd p = c0 \<and> nil\<^sub>e es"])
  subgoal for p es
    apply (cases p) by auto
  apply (subst sValidNF_exists_pre2) apply (rule allI)
  apply (subst sValidNF_exists_pre2) apply (rule allI)
  apply (subst sValidNF_conj_pre) apply (rule impI)
  apply (subst sValidNF_conj_pre) apply (rule impI)
  apply (subst sValidNF_conj_pre) apply (rule impI)
  subgoal premises pre for bs c0
    apply (rule sValidNF_strengthen_post) prefer 2
     apply (rule sValidNF_Tick[OF pre(1)])
    subgoal for p es
      apply (cases p) subgoal for ss c
        apply clarify subgoal for bs'
          unfolding system_inv.simps
          apply (rule exI[where x=bs'])
          apply (intro conjI)
          subgoal by auto
          subgoal apply (auto simp add: pre(2))
            apply (rule dominates_num_received) by auto
          subgoal apply (auto simp add: pre(3))
            apply (rule dominates_acc) by auto
          subgoal apply simp
            using pre(1) count_tick_events_incr by blast
          done
        done
      done
    done
  done

subsection \<open>Final results\<close>

theorem validNF_init:
  "\<lbrace> \<lambda>c es. c = c0 \<and> es = [] \<rbrace>
     init_impl N data
   \<lbrace> \<lambda>_ c es. c = c0 \<and> es = map (\<lambda>i. QUERY (i, data ! i)) [0 ..< N] \<rbrace>!"
  unfolding init_impl_def
  apply (rule validNF_bind) prefer 2
   apply (rule validNF_return)
  apply (rule validNF_whileLoop[where I="\<lambda>r c es. c = c0 \<and> r \<le> N \<and> es = map (\<lambda>i. QUERY (i, data ! i)) [0 ..< r]" and
                                      R="measure (\<lambda>(r,c). (N - r))"])
  subgoal for c es by auto
  subgoal for r s apply wp by auto
  subgoal by auto
  subgoal for r s es by auto
  done

theorem sValidNF_Query:
  "sValidNF (system N data)
    (\<lambda>p es. p = (ss, c0) \<and> nil\<^sub>e es)
    (QUERY (i, data ! i))
    (\<lambda>p es. p = (ss[i := \<lparr>input = data ! i, index = 0, cursum = 0, returned = False\<rparr>], c0) \<and> nil\<^sub>e es)"
  apply (rule sValidNF_Some)
    apply (rule system.simps)
  apply (rule validNF_weaken_pre)
    apply (rule validNF_apply_fst[where R="\<lambda>s. s = c0"])
    apply (rule validNF_apply_idx[OF query_impl_rule])
  apply (auto simp add: nil_event_def)[1]
  apply auto by (rule sValidNF_list_null)

theorem sValidNF_list_queries:
  assumes "length ss = N"
  shows
  "j \<le> N \<Longrightarrow>
   sValidNF_list (system N data)
    (\<lambda>p es. p = (ss, c0) \<and> nil\<^sub>e es)
      (map (\<lambda>i. QUERY (i, data ! i)) [0..<j])
    (\<lambda>p es. p = (map (\<lambda>i. if i < j then \<lparr>input = data ! i, index = 0, cursum = 0, returned = False\<rparr>
                          else ss ! i) [0..<N], c0) \<and> nil\<^sub>e es)"
proof (induction j)
  case 0
  then show ?case
    using assms apply (auto simp add: map_nth)
    by (rule sValidNF_list_null)
next
  case (Suc j)
  have a: "map (\<lambda>i. QUERY (i, data ! i)) [0..<Suc j] = map (\<lambda>i. QUERY (i, data ! i)) [0..<j] @ [QUERY (j, data ! j)]"
    by auto
  have b: "sValidNF_list (system N data) (\<lambda>p es. p = (ss, c0) \<and> nil\<^sub>e es) (map (\<lambda>i. QUERY (i, data ! i)) [0..<j])
   (\<lambda>p es. p = (map (\<lambda>i. if i < j then \<lparr>input = data ! i, index = 0, cursum = 0, returned = False\<rparr> else ss ! i) [0..<N], c0) \<and>
          nil\<^sub>e es)"
    using Suc by auto
  show ?case
    unfolding a apply (rule sValidNF_list_append)
     apply (rule b)
    apply (rule sValidNF_list_single)
    apply (rule sValidNF_strengthen_post) prefer 2
     apply (rule sValidNF_Query)
    apply auto
    apply (rule nth_equalityI)
     apply auto subgoal for es i
      apply (cases "i = j") by auto
    done
qed

theorem sValidNF_list_queries':
  assumes "length ss = N"
  shows
  "sValidNF_list (system N data)
    (\<lambda>p es. p = (ss, c0) \<and> nil\<^sub>e es)
    (map (\<lambda>i. QUERY (i, data ! i)) [0..<N])
    (\<lambda>p es. p = (map (\<lambda>i. \<lparr>input = data ! i, index = 0, cursum = 0, returned = False\<rparr>) [0..<N], c0) \<and> nil\<^sub>e es)"
proof -
  have a: "sValidNF_list (system N data)
    (\<lambda>p es. p = (ss, c0) \<and> nil\<^sub>e es)
      (map (\<lambda>i. QUERY (i, data ! i)) [0..<N])
    (\<lambda>p es. p = (map (\<lambda>i. if i < N then \<lparr>input = data ! i, index = 0, cursum = 0, returned = False\<rparr>
                          else ss ! i) [0..<N], c0) \<and> nil\<^sub>e es)"
    using sValidNF_list_queries[OF assms, where j=N] by auto
  have b: "map (\<lambda>i. if i < N then \<lparr>input = data ! i, index = 0, cursum = 0, returned = False\<rparr>
                    else ss ! i) [0..<N] = map (\<lambda>i. \<lparr>input = data ! i, index = 0, cursum = 0, returned = False\<rparr>) [0 ..< N]"
    apply (rule nth_equalityI)
    by auto
  show ?thesis
    using a b by auto
qed

fun init_state :: "nat \<Rightarrow> server list \<times> client \<Rightarrow> bool" where
  "init_state N (ss, c) \<longleftrightarrow> length ss = N \<and> c = \<lparr>num_received = 0, acc = 0, alldone = False\<rparr>"

theorem sValidNF_init:
  assumes "length ss = N"
  shows
  "sValidNF (system N data)
    (\<lambda>p es. p = (ss, c0) \<and> nil\<^sub>e es)
     INIT
    (\<lambda>p es. p = (map (\<lambda>i. \<lparr>input = data ! i, index = 0, cursum = 0, returned = False\<rparr>) [0 ..< N], c0) \<and> nil\<^sub>e es)"
  apply (rule sValidNF_Some)
    apply (rule system.simps)
  apply (rule validNF_weaken_pre)
    apply (rule validNF_apply_snd[where R="\<lambda>s. s = ss"])
    apply (rule validNF_init)
   apply (auto simp add: nil_event_def)
  using sValidNF_list_queries'[OF assms] unfolding nil_event_def by auto

theorem sValidNF_init_inv:
  assumes "N > 0"
  shows
  "sValidNF (system N data)
    (\<lambda>p es. init_state N p \<and> nil\<^sub>e es)
     INIT
    (\<lambda>p es. system_inv N data p \<and> nil\<^sub>e es)"
  apply (rule sValidNF_weaken_pre[where P="\<lambda>p es. \<exists>ss c. init_state N (ss, c) \<and> p = (ss, c) \<and> nil\<^sub>e es"])
   apply auto[1]
  apply (subst sValidNF_exists_pre2) apply clarify
  apply (subst sValidNF_exists_pre2) apply clarify
  apply (subst sValidNF_conj_pre) apply clarify
  subgoal premises pre for ss c
    apply (rule sValidNF_strengthen_post)
     prefer 2 apply (rule sValidNF_init)
    using pre apply auto[1]
    subgoal for p es
      apply auto apply (rule exI[where x="map (\<lambda>i. False) [0..<N]"])
      using pre assms by (auto simp add: server_inv_def)
    done
  done

theorem system_inv_sum:
  assumes "system_inv N data (ss, c)"
    and "alldone c"
  shows "acc c = sum (\<lambda>i. sum_list (data ! i)) {0 ..< N}"
proof -
  obtain bs where a: "server_inv N data bs ss"
    "num_received c = sum (\<lambda>i. if bs ! i then 1 else 0) {0 ..< N}"
    "acc c = sum (\<lambda>i. if bs ! i then sum_list (data ! i) else 0) {0 ..< N}"
    "alldone c = (num_received c \<ge> N)"
    using assms by auto
  have b: "(\<forall>i<j. bs ! i) \<longleftrightarrow> sum (\<lambda>i. if bs ! i then 1 else 0) {0 ..< j} \<ge> j" for j
    apply (induction j)
    apply auto using not_less_less_Suc_eq by auto
  have c: "\<forall>i<N. bs ! i"
    using a(2,4) assms(2) b by auto
  show ?thesis
    using a(3) c by auto
qed

theorem system_inv_all':
  assumes "N > 0"
  shows
  "sValidNF_list (system N data)
    (\<lambda>p es. init_state N p \<and> nil\<^sub>e es)
    (INIT # replicate n TICK)
    (\<lambda>p es. system_inv N data p \<and> nil\<^sub>e es)"
  apply (rule sValidNF_list_cons)
  apply (rule sValidNF_init_inv[OF assms])
  apply (induction n)
  subgoal apply auto by (rule sValidNF_list_null)
  subgoal for n
    apply auto apply (rule sValidNF_list_cons)
     apply (rule sValidNF_Tick2)
    by auto
  done

theorem system_inv_all:
  assumes "N > 0"
  shows
  "sValidNF_list (system N data)
    (\<lambda>p es. init_state N p \<and> nil\<^sub>e es)
    (INIT # replicate n TICK)
    (\<lambda>p es. (alldone (snd p) \<longrightarrow> acc (snd p) = sum (\<lambda>i. sum_list (data ! i)) {0 ..< N}) \<and> nil\<^sub>e es)"
  apply (rule sValidNF_list_strengthen_post)
  prefer 2 apply (rule system_inv_all'[OF assms])
  using system_inv_sum by auto

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
paragraph \<open>Galois Equivalence\<close>
theory Transport_Compositions_Generic_Galois_Equivalence
  imports
    Transport_Compositions_Generic_Galois_Connection
begin

context transport_comp
begin

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

lemma galois_equivalenceI:
  assumes "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "((\<le>\<^bsub>L1\<^esub>) \<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "rel_equivalence_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>) \<epsilon>\<^sub>1"
  and "transitive (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R2\<^esub>)) l2"
  and "((\<le>\<^bsub>R2\<^esub>) \<unlhd> (\<le>\<^bsub>L2\<^esub>)) r2 l2"
  and "rel_equivalence_on (in_field (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>) \<eta>\<^sub>2"
  and "transitive (\<le>\<^bsub>L2\<^esub>)"
  and "middle_compatible_codom"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro galois_equivalenceI galois_connection_left_rightI
    flip.galois_prop_left_rightI)
  (auto intro!: preorder_on_in_field_if_transitive_if_rel_equivalence_on
    intro: rel_equivalence_on_if_le_pred_if_rel_equivalence_on
      inflationary_on_if_le_pred_if_inflationary_on
      in_field_if_in_dom in_field_if_in_codom)

lemma galois_equivalenceI':
  assumes "((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L1\<^esub>)) r1"
  and "((\<le>\<^bsub>L1\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "((\<le>\<^bsub>R1\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>L1\<^esub>)) r1 l1"
  and "inflationary_on (in_dom (\<le>\<^bsub>L1\<^esub>)) (\<le>\<^bsub>L1\<^esub>) \<eta>\<^sub>1"
  and "rel_equivalence_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>) \<epsilon>\<^sub>1"
  and "transitive (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R2\<^esub>)) l2"
  and "((\<le>\<^bsub>L2\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "((\<le>\<^bsub>R2\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>L2\<^esub>)) r2 l2"
  and "rel_equivalence_on (in_field (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>) \<eta>\<^sub>2"
  and "inflationary_on (in_dom (\<le>\<^bsub>R2\<^esub>)) (\<le>\<^bsub>R2\<^esub>) \<epsilon>\<^sub>2"
  and "transitive (\<le>\<^bsub>L2\<^esub>)"
  and "middle_compatible_dom"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro galois.galois_equivalenceI galois_connection_left_rightI'
    flip.galois_prop_left_rightI')
  (auto elim!: rel_equivalence_onE
    intro!: preorder_on_in_field_if_transitive_if_rel_equivalence_on
    intro: inflationary_on_if_le_pred_if_inflationary_on
      in_field_if_in_dom)

corollary galois_equivalence_if_galois_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "preorder_on (in_field (\<le>\<^bsub>R1\<^esub>)) (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "preorder_on (in_field (\<le>\<^bsub>L2\<^esub>)) (\<le>\<^bsub>L2\<^esub>)"
  and "middle_compatible_codom"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro galois_equivalenceI)
  (auto intro!: t2.rel_equivalence_on_unit_if_reflexive_on_if_galois_equivalence
      flip.t2.rel_equivalence_on_unit_if_reflexive_on_if_galois_equivalence
    intro: reflexive_on_if_le_pred_if_reflexive_on
      in_field_if_in_dom in_field_if_in_codom)

corollary galois_equivalence_if_order_equivalenceI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R1\<^esub>)) l1 r1"
  and "transitive (\<le>\<^bsub>R1\<^esub>)"
  and "((\<le>\<^bsub>L2\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R2\<^esub>)) l2 r2"
  and "transitive (\<le>\<^bsub>L2\<^esub>)"
  and "middle_compatible_codom"
  shows "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro galois_equivalenceI')
  (auto elim!: rel_equivalence_onE
    intro!: t1.half_galois_prop_left_left_right_if_transitive_if_deflationary_on_if_mono_wrt_rel
      flip.t1.half_galois_prop_left_left_right_if_transitive_if_deflationary_on_if_mono_wrt_rel
      t2.half_galois_prop_right_left_right_if_transitive_if_inflationary_on_if_mono_wrt_rel
      flip.t2.half_galois_prop_right_left_right_if_transitive_if_inflationary_on_if_mono_wrt_rel
      rel_comp_comp_le_assms_if_in_codom_rel_comp_comp_leI
      preorder_on_in_field_if_transitive_if_rel_equivalence_on
    intro: deflationary_on_if_le_pred_if_deflationary_on
      inflationary_on_if_le_pred_if_inflationary_on
      in_field_if_in_dom in_field_if_in_codom)

end

end


section \<open>Additions to Lars Noschinski's Graph Library\<close>
theory More_Graph_Theory
  imports Graph_Theory.Graph_Theory
begin

lemma vwalkE2:
  assumes "vwalk p G"
  obtains u where "p = [u]" "u \<in> verts G"
    | u v es where "p = u # v # es" "(u,v) \<in> arcs_ends G" "vwalk (v # es) G"
  by (metis assms list.sel(1) vwalkE vwalk_consE vwalk_singleton vwalk_to_vpath.cases)

lemma (in wf_digraph) reachable_vwalk_conv2:
  "u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v \<longleftrightarrow> (u = v \<and> u \<in> verts G \<or> (\<exists>vs. vwalk (u # vs @ [v]) G))"
  unfolding reachable_vwalk_conv
  apply (rule iffI)
   apply (elim exE conjE, erule vwalkE2, (simp; fail),
      metis last.simps last_snoc list.distinct(1) list.sel(1) rev_exhaust vwalk_Cons_Cons)
  apply force
  done

context pre_digraph
begin

definition
  "scc_graph = \<lparr>
    verts = sccs_verts,
    arcs = {(x, y). \<exists>a \<in> x. \<exists>b \<in> y. x \<noteq> y \<and> x \<in> sccs_verts \<and> y \<in> sccs_verts \<and> a \<rightarrow> b},
    tail = fst,
    head = snd
  \<rparr>"

interpretation scc_digraph: loopfree_digraph scc_graph
  by standard (auto simp: scc_graph_def)

lemmas scc_digraphI = scc_digraph.loopfree_digraph_axioms

end

context wf_digraph
begin

interpretation scc_digraph: loopfree_digraph scc_graph
  by (rule scc_digraphI)

lemma scc_graph_edgeE:
  assumes \<open>x \<rightarrow>\<^bsub>scc_graph\<^esub> y\<close> obtains a b where
    "a \<in> x" "b \<in> y" "a \<rightarrow> b" "x \<in> sccs_verts" "y \<in> sccs_verts" "x \<noteq> y"
    using assms by (force simp: scc_graph_def dest!: in_arcs_imp_in_arcs_ends)

lemma same_sccI:
  assumes "S \<in> sccs_verts" "x \<in> S" "x \<rightarrow>\<^sup>* y" "y \<rightarrow>\<^sup>* x"
  shows "y \<in> S"
  using assms by (auto simp: in_sccs_verts_conv_reachable)

lemma scc_graph_reachable1E:
  assumes \<open>x \<rightarrow>\<^sup>+\<^bsub>scc_graph\<^esub> y\<close> obtains a b where
    "x \<in> sccs_verts " "y \<in> sccs_verts " "x \<noteq> y" "a \<in> x" "b \<in> y" "a \<rightarrow>\<^sup>+ b"
  using assms
proof (atomize_elim, induction)
  case (base y)
  then show ?case
    by (auto elim!: scc_graph_edgeE)
next
  case (step y z)
  then obtain a b where IH: "x \<in> sccs_verts" "y \<in> sccs_verts" "a \<in> x" "b \<in> y" "a \<rightarrow>\<^sup>+ b" "x \<noteq> y"
    by auto
  from \<open>y \<rightarrow>\<^bsub>scc_graph\<^esub> z\<close> obtain b' c where *:
    "b' \<in> y" "c \<in> z" "b' \<rightarrow> c" "y \<in> sccs_verts" "z \<in> sccs_verts"
    by (elim scc_graph_edgeE)
  with \<open>b \<in> y\<close> have "b \<rightarrow>\<^sup>* b'"
    by (simp add: in_sccs_verts_conv_reachable)
  with \<open>b' \<rightarrow> c\<close> \<open>a \<rightarrow>\<^sup>+ b\<close> have "a \<rightarrow>\<^sup>+ c"
    using reachable1_reachable_trans by blast
  moreover have "x \<noteq> z"
  proof (rule ccontr, simp)
    assume "x = z"
    with \<open>a \<in> x\<close> \<open>c \<in> z\<close> \<open>x \<in> _\<close> have "c \<rightarrow>\<^sup>* a"
      by (simp add: in_sccs_verts_conv_reachable)
    with \<open>b \<rightarrow>\<^sup>* b'\<close> \<open>b' \<rightarrow> c\<close> have "b \<rightarrow>\<^sup>* a" \<comment> \<open>XXX: This should really be \<open>by simp\<close>\<close>
      by (meson reachable_adj_trans reachable_trans)
    with IH have "b \<in> x"
      by - (rule same_sccI, auto)
    with sccs_verts_disjoint IH show False
      by auto
  qed
  ultimately show ?case
    using IH * by auto
qed

end

locale dag = wf_digraph +
  assumes acyclic: "x \<rightarrow>\<^sup>+ x \<Longrightarrow> False"

locale fin_dag = fin_digraph + dag

context wf_digraph
begin

interpretation scc_digraph: loopfree_digraph scc_graph
  by (rule scc_digraphI)

interpretation scc_digraph: dag scc_graph
  by standard (auto elim: scc_graph_reachable1E)

lemmas scc_digraphI = scc_digraph.dag_axioms

end

context fin_digraph
begin

interpretation scc_digraph: dag scc_graph
  thm scc_digraphI
  by (rule scc_digraphI)

interpretation scc_digraph: fin_dag scc_graph
  apply standard
  unfolding scc_graph_def
  subgoal finite_verts
    by (simp add: finite_sccs_verts)
  subgoal finite_arcs
    using finite_sccs_verts
    by - (rule finite_subset[where B = "{(x, y). x \<in> sccs_verts \<and> y \<in> sccs_verts}"], auto)
  done

lemmas scc_digraphI = scc_digraph.fin_dag_axioms

end

end


section {* Verification condition generator *}

theory VCG
  imports While "$AFP/KAT_and_DRA/SingleSorted/KAT_Models" "$ISABELLE_HOME/src/HOL/Eisbach/Eisbach"
begin

no_notation comp_op ("n_" [90] 91)
  and test_operator  ("t_" [100] 101)
  and floor ("\<lfloor>_\<rfloor>")
  and ceiling ("\<lceil>_\<rceil>")
  and Set.image (infixr "`" 90)

notation inf (infixl "\<sqinter>" 60)

(***********************************************************************************************)

text {* \emph{hoare} tactic *}

named_theorems hl_rules

method hoare_init uses simp =
  ((subst simp | subst fst_conv | subst snd_conv)+)?

method hoare_step uses simp hl =
  (hoare_init simp: simp, (assumption | rule subset_refl | rule mono_rules | rule hl hl_rules | rule allI | rule ballI))

method hoare_ind uses simp hl =
  (hoare_step simp: simp hl: hl; (hoare_ind simp: simp hl: hl)?)+

method hoare uses simp hl =
  (hoare_init simp: simp; (hoare_ind simp: simp hl: hl)?)

method hl_aux uses rule =
  (rule allI, rule rule; ((erule_tac x=u in allE)+, assumption))

(***********************************************************************************************)

text {* Classic Hoare logic *}

definition ht :: "'a set \<Rightarrow> 'a rel \<Rightarrow> 'a set \<Rightarrow> bool" where
  "ht P x Q \<equiv> \<lfloor>P\<rfloor>;x \<subseteq> x;\<lfloor>Q\<rfloor>"

lemma ht_true: "ht P x UNIV"
  by (auto simp: ht_def seq_def)

lemma hl_false [intro]: "ht {} x Q"
  by (auto simp: ht_def seq_def test_def)

lemma hl_abort [hl_rules]: "ht P abort Q"
  by (auto simp: ht_def abort_def seq_def)

lemma hl_skip [hl_rules]: "P \<subseteq> Q \<Longrightarrow> ht P skip Q"
  by (auto simp: ht_def skip_def seq_def test_def)

lemma hl_graph [hl_rules]: "P \<subseteq> {s. f s \<in> Q} \<Longrightarrow> ht P (graph f) Q"
  by (auto simp: ht_def graph_def seq_def test_def)

lemma hl_assign [hl_rules]: "P \<subseteq> subst Q z_upd t \<Longrightarrow> ht P (assign z_upd t) Q"
  by (auto simp: assign_def subst_def intro!: hl_graph)

lemma hl_assign_aux [hl_rules]: "\<forall>z. P z \<subseteq> subst (Q z) z_upd t \<Longrightarrow> \<forall>z. ht (P z) (assign z_upd t) (Q z)"
  by (auto simp: assign_def subst_def intro!: hl_graph)

lemma hl_seq [hl_rules]: "ht R y Q \<Longrightarrow> ht P x R \<Longrightarrow> ht P (x; y) Q"
  by (force simp: ht_def seq_def)

lemma hl_seq_aux [hl_rules]: "\<forall>u. ht (R u) (y u) (Q u) \<Longrightarrow> \<forall>u. ht (P u) (x u) (R u) \<Longrightarrow> \<forall>u. ht (P u) (x u; y u) (Q u)"
  by (hl_aux rule: hl_seq)

lemma hl_split: "ht P x {t. Q t} \<Longrightarrow> ht P x {t. Q' t} \<Longrightarrow> ht P x {t. Q t \<and> Q' t}"
  by (force simp: ht_def seq_def test_def)

lemma hl_split_aux: "\<forall>u. ht (P u) x {t. (Q u) t} \<Longrightarrow> \<forall>u. ht (P u) x {t. Q' u t} \<Longrightarrow> \<forall>u. ht (P u) x {t. Q u t \<and> Q' u t}"
  by (hl_aux rule: hl_split)

lemma hl_cassic_cond : "ht (b \<sqinter> P) x Q \<Longrightarrow> ht (-b \<sqinter> P) y Q \<Longrightarrow> ht P (cond b x y) Q"
  by (fastforce simp: ht_def cond_def seq_def test_def)

lemma hl_cond [hl_rules]: "P \<subseteq> (P' \<union> - b) \<inter> (P'' \<union> b)  \<Longrightarrow> ht P' x Q \<Longrightarrow> ht P'' y Q \<Longrightarrow> ht P (cond b x y) Q"
  by (fastforce simp: ht_def cond_def seq_def)

lemma hl_cond_aux [hl_rules]: "\<forall>u. P u \<subseteq> (P' u \<union> - b) \<inter> (P'' u \<union> b)  \<Longrightarrow> \<forall>u. ht (P' u) x (Q u) \<Longrightarrow> \<forall>u. ht (P'' u) y (Q u) \<Longrightarrow> \<forall>u. ht (P u) (cond b x y) (Q u)"
  by (hl_aux rule: hl_cond)

lemma hl_while: "ht (b \<sqinter> i) x i \<Longrightarrow> ht i (cwhile b x) (-b \<sqinter> i)"
proof (simp add: ht_def cwhile_def seq_def)
  assume "\<lfloor>b \<sqinter> i\<rfloor> O x \<subseteq> x O \<lfloor>i\<rfloor>"
  hence "\<lfloor>i\<rfloor> O (\<lfloor>b\<rfloor> O x)\<^sup>* \<subseteq> (\<lfloor>b\<rfloor> O x)\<^sup>* O \<lfloor>i\<rfloor>"
    by (force intro!: rel_kat.star_sim2)
  thus "\<lfloor>i\<rfloor> O (\<lfloor>b\<rfloor> O x)\<^sup>* O \<lfloor>-b\<rfloor> \<subseteq> ((\<lfloor>b\<rfloor> O x)\<^sup>* O \<lfloor>-b\<rfloor>) O \<lfloor>-b \<sqinter> i\<rfloor>"
    by auto
qed

(***********************************************************************************************)

text {* Weakening / Strengthening / Consequence Rules *}

lemma hl_pre: "P \<le> P' \<Longrightarrow> ht P' x Q \<Longrightarrow> ht P x Q"
  by (fastforce simp: ht_def le_fun_def seq_def test_def)

lemma hl_post: "Q' \<le> Q \<Longrightarrow> ht P x Q' \<Longrightarrow> ht P x Q"
  by (fastforce simp: ht_def le_fun_def seq_def test_def)

lemma hl_post_aux: "\<forall>u. Q' u \<le> Q u \<Longrightarrow> \<forall>u. ht (P u) x (Q' u) \<Longrightarrow> \<forall>u. ht (P u) x (Q u)"
  by (fastforce simp: ht_def le_fun_def seq_def test_def)

lemma hl_classic: "P \<le> P' \<Longrightarrow> Q' \<le> Q \<Longrightarrow> ht P' x Q' \<Longrightarrow> ht P x Q"
  by (fastforce simp: ht_def le_fun_def seq_def)

lemma hl_conseq: "\<forall>z. ht (P' z) c (Q' z) \<Longrightarrow> \<forall>s. s \<in> P \<longrightarrow> (\<exists>z. s \<in> P' z \<and> (Q' z \<subseteq> Q)) \<Longrightarrow> ht P c Q"
  by (force simp: ht_def seq_def)

lemma hl_kleymann: "\<forall>z. ht (P' z) x (Q' z) \<Longrightarrow> \<forall>s t. (\<forall>z. s \<in> P' z \<longrightarrow> t \<in> Q' z) \<longrightarrow> (\<forall>z. s \<in> P z \<longrightarrow> t \<in> Q z) \<Longrightarrow> ht (P z) x (Q z)"
 by (fastforce simp: apre_def seq_def ht_def)

lemma hl_kleymann_aux: "\<forall>z. ht (P' z) x (Q' z) \<Longrightarrow> \<forall>s t. (\<forall>z. s \<in> P' z \<longrightarrow> t \<in> Q' z) \<longrightarrow> (\<forall>z. s \<in> P z \<longrightarrow> t \<in> Q z) \<Longrightarrow> \<forall>z. ht (P z) x (Q z)"
 by (hl_aux rule: hl_kleymann)

lemma hl_for [hl_rules]: "\<forall>s. m_upd(\<lambda>_. m s) s = s \<Longrightarrow>
  ht P (assign j_upd n) (subst Q m_upd j \<inter> {s. j s \<le> m s}) \<Longrightarrow>
  ht ({s. j s < m s} \<inter> subst Q m_upd j) x (subst (subst Q m_upd j \<inter> {s. j s \<le> m s}) j_upd (\<lambda>s. j s + 1)) \<Longrightarrow>
  ht P (cfor (j_upd, j) n (m_upd, m) x) Q"
  apply (rule hl_post [where Q'="(-{s. j s < m s} \<inter> (subst Q m_upd j \<inter> {s. j s \<le> m s}))"])
  apply (subgoal_tac "-{s. j s < m s} \<inter> (subst Q m_upd j \<inter> {s. j s \<le> m s}) = {s. j s = m s} \<inter> subst Q m_upd j")
  apply (force simp: subst_def)
  apply force
  apply (hoare simp: cfor_def hl: hl_while)
  apply (subgoal_tac "{s. j s < m s} \<inter> (subst Q m_upd j \<inter> {s. j s \<le> m s}) = {s. j s < m s} \<inter> subst Q m_upd j")
  apply force+
done

(***********************************************************************************************)

text {* Blocks / Procedures / Recursive Calls *}

lemma hl_dyn [hl_rules]: "\<forall>s \<in> P. ht P (g s) Q \<Longrightarrow> ht P (\<lceil>g\<rceil>) Q"
  by (fastforce simp: ht_def seq_def dyn_def)

lemma hl_local_inv: "\<forall>s s'. z (z_upd (\<lambda>_. z s) s') = z s \<Longrightarrow> P \<le> {s. z s = u} \<Longrightarrow> ht P (loc_block (z_upd, z) t x) {s. z s = u}"
  by (auto simp: block_def loc_block_def graph_def dyn_def seq_def ht_def)

lemma hl_block: "\<forall>s. ht P x {t. f s t \<in> Q} \<Longrightarrow> ht P (block x f) Q"
  by (hoare simp: block_def hl: ballI) force

lemma hl_loc_block: "\<forall>s. ht P (\<langle>\<lambda>s. z_upd (\<lambda>_. t s) s\<rangle>; x) {t. z_upd s t \<in> Q} \<Longrightarrow> ht P (loc_block (z_upd, z) t x) Q"
  by (auto simp: loc_block_def intro: hl_block)

lemma hl_fun_block_inv: "\<forall>s s'. y (y_upd (\<lambda>_. y s) s') = y s \<Longrightarrow> P \<le> {s. y s = u} \<Longrightarrow> ht P (fun_call z_upd (R, (y_upd, y))) {s. y s = u }"
  by (auto simp: block_def loc_block_def graph_def dyn_def seq_def ht_def fun_call_def)

lemma hl_fun_block: "\<forall>s. ht P R {t. y_upd (\<lambda>_. y s) (z_upd (\<lambda>_. y t) t) \<in> Q} \<Longrightarrow> ht P (fun_call z_upd (R, (y_upd, y))) Q"
  by (auto simp: fun_call_def intro: hl_block)

lemma hl_Sup: "\<forall>x \<in> X. \<forall>z. ht (P z) (x z) (Q z) \<Longrightarrow> \<forall>z. ht (P z) (Sup X z) (Q z)"
  by (fastforce simp: ht_def seq_def)

lemma hl_rec_dep: "mono f \<Longrightarrow> (\<And>x. \<forall>z. ht (P z) (x z) (Q z) \<Longrightarrow> \<forall>z. ht (P z) (f x z) (Q z)) \<Longrightarrow> \<forall>z. ht (P z) (lfp f z) (Q z)"
  apply (erule lfp_ordinal_induct [where f=f], assumption)
  by (force intro!: hl_Sup)

lemma hl_rec_aux [hl_rules]: "mono f \<Longrightarrow> (\<And>x. \<forall>z. ht (P z) x (Q z) \<Longrightarrow> \<forall>z. ht (P z) (f x) (Q z)) \<Longrightarrow> \<forall>z. ht (P z) (lfp f) (Q z)"
  apply (erule lfp_ordinal_induct [where f=f], simp)
  by (fastforce simp: ht_def seq_def)

lemma hl_rec [hl_rules]: "mono f \<Longrightarrow> (\<And>x. \<forall>z. ht (P z) x (Q z) \<Longrightarrow> \<forall>z. ht (P z) (f x) (Q z)) \<Longrightarrow> ht (P z) (lfp f) (Q z)"
  apply (drule hl_rec_aux)
prefer 2
  apply (erule_tac x=z in allE)
  apply assumption
apply simp
done

(***********************************************************************************************)

text {* Annotated programs *}

lemma hl_awhile [hl_rules]: "P \<subseteq> i \<Longrightarrow> -b \<inter> i \<subseteq> Q \<Longrightarrow> ht (b \<sqinter> i) x i \<Longrightarrow> ht P (awhile i b x) Q"
  apply (rule hl_conseq)
  by (hoare simp: awhile_def hl: allI hl_while) force

lemma hl_apre_classic: "P \<le> P' \<Longrightarrow> ht P' x Q \<Longrightarrow> ht P (apre P' x) Q"
  apply (rule hl_pre, assumption)
  by (hoare simp: apre_def)

lemma hl_apre_kleymann [hl_rules]: "ht P' x Q' \<Longrightarrow> \<forall>s t. (s \<in> P' \<longrightarrow> t \<in> Q') \<longrightarrow> (s \<in> P \<longrightarrow> t \<in> Q) \<Longrightarrow> ht P (apre P x) Q"
  by (force simp add: apre_def seq_def ht_def)

lemma hl_apre_kleymann_aux [hl_rules]: "\<forall>z. ht (P' z) x (Q' z) \<Longrightarrow> \<forall>s t. (\<forall>z. s \<in> P' z \<longrightarrow> t \<in> Q' z) \<longrightarrow> (\<forall>z. s \<in> P z \<longrightarrow> t \<in> Q z) \<Longrightarrow> \<forall>z. ht (P z) (apre_aux P x) (Q z)"
  by (force simp add: apre_aux_def seq_def ht_def)

lemma hl_apost_classic [hl_rules]: "Q' \<le> Q \<Longrightarrow> ht P x Q' \<Longrightarrow> ht P (apost x Q') Q"
  by (hoare simp: apost_def hl: hl_apre_kleymann) force

lemma hl_aprog_classic : "P \<le> P' \<Longrightarrow> Q' \<le> Q \<Longrightarrow> ht P' x Q' \<Longrightarrow> ht P (aprog P' x Q') Q"
  apply (rule hl_classic, assumption+)
  by (hoare simp: aprog_def)

lemma hl_aprog_kleymann_aux [hl_rules]: "\<forall>z. ht (P' z) x (Q' z) \<Longrightarrow> \<forall>s t. (\<forall>z. s \<in> P' z \<longrightarrow> t \<in> Q' z) \<longrightarrow> (\<forall>z. s \<in> P z \<longrightarrow> t \<in> Q z) \<Longrightarrow> \<forall>z. Q z \<le> Q'' z \<Longrightarrow> \<forall>z. ht (P z) (aprog_aux P x Q) (Q'' z)"
  apply (simp add: aprog_aux_def)
  apply (rule hl_post_aux)
  apply assumption
  by (force simp add: aprog_aux_def seq_def ht_def)

(***********************************************************************************************)

text {* When using hoare, rules should be applied in the following order *}

declare
  hl_local_inv [hl_rules]
  hl_loc_block [hl_rules]
  hl_fun_block_inv [hl_rules]
  hl_fun_block [hl_rules]
  hl_block [hl_rules]

declare subst_def [simp]

method hoare_split uses simp hl =
  (hoare_init simp: simp; (rule hl_split)+; (hoare_ind simp: simp hl: hl)?)

end


(*  Title:      ZF/Constructible/WFrec.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section\<open>Relativized Well-Founded Recursion\<close>

theory WFrec imports Wellorderings begin

subsection\<open>General Lemmas\<close>

(*Many of these might be useful in WF.thy*)

lemma apply_recfun2:
    "\<lbrakk>is_recfun(r,a,H,f); \<langle>x,i\<rangle>:f\<rbrakk> \<Longrightarrow> i = H(x, restrict(f,r-``{x}))"
apply (frule apply_recfun)
 apply (blast dest: is_recfun_type fun_is_rel)
apply (simp add: function_apply_equality [OF _ is_recfun_imp_function])
done

text\<open>Expresses \<open>is_recfun\<close> as a recursion equation\<close>
lemma is_recfun_iff_equation:
     "is_recfun(r,a,H,f) \<longleftrightarrow>
           f \<in> r -`` {a} \<rightarrow> range(f) \<and>
           (\<forall>x \<in> r-``{a}. f`x = H(x, restrict(f, r-``{x})))"
apply (rule iffI)
 apply (simp add: is_recfun_type apply_recfun Ball_def vimage_singleton_iff,
        clarify)
apply (simp add: is_recfun_def)
apply (rule fun_extension)
  apply assumption
 apply (fast intro: lam_type, simp)
done

lemma is_recfun_imp_in_r: "\<lbrakk>is_recfun(r,a,H,f); \<langle>x,i\<rangle> \<in> f\<rbrakk> \<Longrightarrow> \<langle>x, a\<rangle> \<in> r"
by (blast dest: is_recfun_type fun_is_rel)

lemma trans_Int_eq:
      "\<lbrakk>trans(r); \<langle>y,x\<rangle> \<in> r\<rbrakk> \<Longrightarrow> r -`` {x} \<inter> r -`` {y} = r -`` {y}"
by (blast intro: transD)

lemma is_recfun_restrict_idem:
     "is_recfun(r,a,H,f) \<Longrightarrow> restrict(f, r -`` {a}) = f"
apply (drule is_recfun_type)
apply (auto simp add: Pi_iff subset_Sigma_imp_relation restrict_idem)
done

lemma is_recfun_cong_lemma:
  "\<lbrakk>is_recfun(r,a,H,f); r = r'; a = a'; f = f';
      \<And>x g. \<lbrakk><x,a'> \<in> r'; relation(g); domain(g) \<subseteq> r' -``{x}\<rbrakk>
             \<Longrightarrow> H(x,g) = H'(x,g)\<rbrakk>
   \<Longrightarrow> is_recfun(r',a',H',f')"
apply (simp add: is_recfun_def)
apply (erule trans)
apply (rule lam_cong)
apply (simp_all add: vimage_singleton_iff Int_lower2)
done

text\<open>For \<open>is_recfun\<close> we need only pay attention to functions
      whose domains are initial segments of \<^term>\<open>r\<close>.\<close>
lemma is_recfun_cong:
  "\<lbrakk>r = r'; a = a'; f = f';
      \<And>x g. \<lbrakk><x,a'> \<in> r'; relation(g); domain(g) \<subseteq> r' -``{x}\<rbrakk>
             \<Longrightarrow> H(x,g) = H'(x,g)\<rbrakk>
   \<Longrightarrow> is_recfun(r,a,H,f) \<longleftrightarrow> is_recfun(r',a',H',f')"
apply (rule iffI)
txt\<open>Messy: fast and blast don't work for some reason\<close>
apply (erule is_recfun_cong_lemma, auto)
apply (erule is_recfun_cong_lemma)
apply (blast intro: sym)+
done

subsection\<open>Reworking of the Recursion Theory Within \<^term>\<open>M\<close>\<close>

lemma (in M_basic) is_recfun_separation':
    "\<lbrakk>f \<in> r -`` {a} \<rightarrow> range(f); g \<in> r -`` {b} \<rightarrow> range(g);
        M(r); M(f); M(g); M(a); M(b)\<rbrakk>
     \<Longrightarrow> separation(M, \<lambda>x. \<not> (\<langle>x, a\<rangle> \<in> r \<longrightarrow> \<langle>x, b\<rangle> \<in> r \<longrightarrow> f ` x = g ` x))"
apply (insert is_recfun_separation [of r f g a b])
apply (simp add: vimage_singleton_iff)
done

text\<open>Stated using \<^term>\<open>trans(r)\<close> rather than
      \<^term>\<open>transitive_rel(M,A,r)\<close> because the latter rewrites to
      the former anyway, by \<open>transitive_rel_abs\<close>.
      As always, theorems should be expressed in simplified form.
      The last three M-premises are redundant because of \<^term>\<open>M(r)\<close>,
      but without them we'd have to undertake
      more work to set up the induction formula.\<close>
lemma (in M_basic) is_recfun_equal [rule_format]:
    "\<lbrakk>is_recfun(r,a,H,f);  is_recfun(r,b,H,g);
       wellfounded(M,r);  trans(r);
       M(f); M(g); M(r); M(x); M(a); M(b)\<rbrakk>
     \<Longrightarrow> \<langle>x,a\<rangle> \<in> r \<longrightarrow> \<langle>x,b\<rangle> \<in> r \<longrightarrow> f`x=g`x"
apply (frule_tac f=f in is_recfun_type)
apply (frule_tac f=g in is_recfun_type)
apply (simp add: is_recfun_def)
apply (erule_tac a=x in wellfounded_induct, assumption+)
txt\<open>Separation to justify the induction\<close>
 apply (blast intro: is_recfun_separation')
txt\<open>Now the inductive argument itself\<close>
apply clarify
apply (erule ssubst)+
apply (simp (no_asm_simp) add: vimage_singleton_iff restrict_def)
apply (rename_tac x1)
apply (rule_tac t="\<lambda>z. H(x1,z)" in subst_context)
apply (subgoal_tac "\<forall>y \<in> r-``{x1}. \<forall>z. \<langle>y,z\<rangle>\<in>f \<longleftrightarrow> \<langle>y,z\<rangle>\<in>g")
 apply (blast intro: transD)
apply (simp add: apply_iff)
apply (blast intro: transD sym)
done

lemma (in M_basic) is_recfun_cut:
    "\<lbrakk>is_recfun(r,a,H,f);  is_recfun(r,b,H,g);
       wellfounded(M,r); trans(r);
       M(f); M(g); M(r); \<langle>b,a\<rangle> \<in> r\<rbrakk>
      \<Longrightarrow> restrict(f, r-``{b}) = g"
apply (frule_tac f=f in is_recfun_type)
apply (rule fun_extension)
apply (blast intro: transD restrict_type2)
apply (erule is_recfun_type, simp)
apply (blast intro: is_recfun_equal transD dest: transM)
done

lemma (in M_basic) is_recfun_functional:
     "\<lbrakk>is_recfun(r,a,H,f);  is_recfun(r,a,H,g);
       wellfounded(M,r); trans(r); M(f); M(g); M(r)\<rbrakk> \<Longrightarrow> f=g"
apply (rule fun_extension)
apply (erule is_recfun_type)+
apply (blast intro!: is_recfun_equal dest: transM)
done

text\<open>Tells us that \<open>is_recfun\<close> can (in principle) be relativized.\<close>
lemma (in M_basic) is_recfun_relativize:
  "\<lbrakk>M(r); M(f); \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))\<rbrakk>
   \<Longrightarrow> is_recfun(r,a,H,f) \<longleftrightarrow>
       (\<forall>z[M]. z \<in> f \<longleftrightarrow>
        (\<exists>x[M]. \<langle>x,a\<rangle> \<in> r \<and> z = <x, H(x, restrict(f, r-``{x}))>))"
apply (simp add: is_recfun_def lam_def)
apply (safe intro!: equalityI)
   apply (drule equalityD1 [THEN subsetD], assumption)
   apply (blast dest: pair_components_in_M)
  apply (blast elim!: equalityE dest: pair_components_in_M)
 apply (frule transM, assumption)
 apply simp
 apply blast
apply (subgoal_tac "is_function(M,f)")
 txt\<open>We use \<^term>\<open>is_function\<close> rather than \<^term>\<open>function\<close> because
      the subgoal's easier to prove with relativized quantifiers!\<close>
 prefer 2 apply (simp add: is_function_def)
apply (frule pair_components_in_M, assumption)
apply (simp add: is_recfun_imp_function function_restrictI)
done

lemma (in M_basic) is_recfun_restrict:
     "\<lbrakk>wellfounded(M,r); trans(r); is_recfun(r,x,H,f); \<langle>y,x\<rangle> \<in> r;
       M(r); M(f);
       \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))\<rbrakk>
       \<Longrightarrow> is_recfun(r, y, H, restrict(f, r -`` {y}))"
apply (frule pair_components_in_M, assumption, clarify)
apply (simp (no_asm_simp) add: is_recfun_relativize restrict_iff
           trans_Int_eq)
apply safe
  apply (simp_all add: vimage_singleton_iff is_recfun_type [THEN apply_iff])
  apply (frule_tac x=xa in pair_components_in_M, assumption)
  apply (frule_tac x=xa in apply_recfun, blast intro: transD)
  apply (simp add: is_recfun_type [THEN apply_iff]
                   is_recfun_imp_function function_restrictI)
apply (blast intro: apply_recfun dest: transD)
done

lemma (in M_basic) restrict_Y_lemma:
   "\<lbrakk>wellfounded(M,r); trans(r); M(r);
       \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g));  M(Y);
       \<forall>b[M].
           b \<in> Y \<longleftrightarrow>
           (\<exists>x[M]. \<langle>x,a1\<rangle> \<in> r \<and>
            (\<exists>y[M]. b = \<langle>x,y\<rangle> \<and> (\<exists>g[M]. is_recfun(r,x,H,g) \<and> y = H(x,g))));
          \<langle>x,a1\<rangle> \<in> r; is_recfun(r,x,H,f); M(f)\<rbrakk>
       \<Longrightarrow> restrict(Y, r -`` {x}) = f"
apply (subgoal_tac "\<forall>y \<in> r-``{x}. \<forall>z. \<langle>y,z\<rangle>:Y \<longleftrightarrow> \<langle>y,z\<rangle>:f")
 apply (simp (no_asm_simp) add: restrict_def)
 apply (thin_tac "rall(M,P)" for P)+  \<comment> \<open>essential for efficiency\<close>
 apply (frule is_recfun_type [THEN fun_is_rel], blast)
apply (frule pair_components_in_M, assumption, clarify)
apply (rule iffI)
 apply (frule_tac y="\<langle>y,z\<rangle>" in transM, assumption)
 apply (clarsimp simp add: vimage_singleton_iff is_recfun_type [THEN apply_iff]
                           apply_recfun is_recfun_cut)
txt\<open>Opposite inclusion: something in f, show in Y\<close>
apply (frule_tac y="\<langle>y,z\<rangle>" in transM, assumption)
apply (simp add: vimage_singleton_iff)
apply (rule conjI)
 apply (blast dest: transD)
apply (rule_tac x="restrict(f, r -`` {y})" in rexI)
apply (simp_all add: is_recfun_restrict
                     apply_recfun is_recfun_type [THEN apply_iff])
done

text\<open>For typical applications of Replacement for recursive definitions\<close>
lemma (in M_basic) univalent_is_recfun:
     "\<lbrakk>wellfounded(M,r); trans(r); M(r)\<rbrakk>
      \<Longrightarrow> univalent (M, A, \<lambda>x p.
              \<exists>y[M]. p = \<langle>x,y\<rangle> \<and> (\<exists>f[M]. is_recfun(r,x,H,f) \<and> y = H(x,f)))"
apply (simp add: univalent_def)
apply (blast dest: is_recfun_functional)
done

text\<open>Proof of the inductive step for \<open>exists_is_recfun\<close>, since
      we must prove two versions.\<close>
lemma (in M_basic) exists_is_recfun_indstep:
    "\<lbrakk>\<forall>y. \<langle>y, a1\<rangle> \<in> r \<longrightarrow> (\<exists>f[M]. is_recfun(r, y, H, f));
       wellfounded(M,r); trans(r); M(r); M(a1);
       strong_replacement(M, \<lambda>x z.
              \<exists>y[M]. \<exists>g[M]. pair(M,x,y,z) \<and> is_recfun(r,x,H,g) \<and> y = H(x,g));
       \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))\<rbrakk>
      \<Longrightarrow> \<exists>f[M]. is_recfun(r,a1,H,f)"
apply (drule_tac A="r-``{a1}" in strong_replacementD)
  apply blast
 txt\<open>Discharge the "univalent" obligation of Replacement\<close>
 apply (simp add: univalent_is_recfun)
txt\<open>Show that the constructed object satisfies \<open>is_recfun\<close>\<close>
apply clarify
apply (rule_tac x=Y in rexI)
txt\<open>Unfold only the top-level occurrence of \<^term>\<open>is_recfun\<close>\<close>
apply (simp (no_asm_simp) add: is_recfun_relativize [of concl: _ a1])
txt\<open>The big iff-formula defining \<^term>\<open>Y\<close> is now redundant\<close>
apply safe
 apply (simp add: vimage_singleton_iff restrict_Y_lemma [of r H _ a1])
txt\<open>one more case\<close>
apply (simp (no_asm_simp) add: Bex_def vimage_singleton_iff)
apply (drule_tac x1=x in spec [THEN mp], assumption, clarify)
apply (rename_tac f)
apply (rule_tac x=f in rexI)
apply (simp_all add: restrict_Y_lemma [of r H])
txt\<open>FIXME: should not be needed!\<close>
apply (subst restrict_Y_lemma [of r H])
apply (simp add: vimage_singleton_iff)+
apply blast+
done

text\<open>Relativized version, when we have the (currently weaker) premise
      \<^term>\<open>wellfounded(M,r)\<close>\<close>
lemma (in M_basic) wellfounded_exists_is_recfun:
    "\<lbrakk>wellfounded(M,r);  trans(r);
       separation(M, \<lambda>x. \<not> (\<exists>f[M]. is_recfun(r, x, H, f)));
       strong_replacement(M, \<lambda>x z.
          \<exists>y[M]. \<exists>g[M]. pair(M,x,y,z) \<and> is_recfun(r,x,H,g) \<and> y = H(x,g));
       M(r);  M(a);
       \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))\<rbrakk>
      \<Longrightarrow> \<exists>f[M]. is_recfun(r,a,H,f)"
apply (rule wellfounded_induct, assumption+, clarify)
apply (rule exists_is_recfun_indstep, assumption+)
done

lemma (in M_basic) wf_exists_is_recfun [rule_format]:
    "\<lbrakk>wf(r);  trans(r);  M(r);
       strong_replacement(M, \<lambda>x z.
         \<exists>y[M]. \<exists>g[M]. pair(M,x,y,z) \<and> is_recfun(r,x,H,g) \<and> y = H(x,g));
       \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g))\<rbrakk>
      \<Longrightarrow> M(a) \<longrightarrow> (\<exists>f[M]. is_recfun(r,a,H,f))"
apply (rule wf_induct, assumption+)
apply (frule wf_imp_relativized)
apply (intro impI)
apply (rule exists_is_recfun_indstep)
      apply (blast dest: transM del: rev_rallE, assumption+)
done

subsection\<open>Relativization of the ZF Predicate \<^term>\<open>is_recfun\<close>\<close>

definition
  M_is_recfun :: "[i\<Rightarrow>o, [i,i,i]\<Rightarrow>o, i, i, i] \<Rightarrow> o" where
   "M_is_recfun(M,MH,r,a,f) \<equiv>
     \<forall>z[M]. z \<in> f \<longleftrightarrow>
            (\<exists>x[M]. \<exists>y[M]. \<exists>xa[M]. \<exists>sx[M]. \<exists>r_sx[M]. \<exists>f_r_sx[M].
               pair(M,x,y,z) \<and> pair(M,x,a,xa) \<and> upair(M,x,x,sx) \<and>
               pre_image(M,r,sx,r_sx) \<and> restriction(M,f,r_sx,f_r_sx) \<and>
               xa \<in> r \<and> MH(x, f_r_sx, y))"

definition
  is_wfrec :: "[i\<Rightarrow>o, [i,i,i]\<Rightarrow>o, i, i, i] \<Rightarrow> o" where
   "is_wfrec(M,MH,r,a,z) \<equiv>
      \<exists>f[M]. M_is_recfun(M,MH,r,a,f) \<and> MH(a,f,z)"

definition
  wfrec_replacement :: "[i\<Rightarrow>o, [i,i,i]\<Rightarrow>o, i] \<Rightarrow> o" where
   "wfrec_replacement(M,MH,r) \<equiv>
        strong_replacement(M,
             \<lambda>x z. \<exists>y[M]. pair(M,x,y,z) \<and> is_wfrec(M,MH,r,x,y))"

lemma (in M_basic) is_recfun_abs:
     "\<lbrakk>\<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g));  M(r); M(a); M(f);
         relation2(M,MH,H)\<rbrakk>
      \<Longrightarrow> M_is_recfun(M,MH,r,a,f) \<longleftrightarrow> is_recfun(r,a,H,f)"
apply (simp add: M_is_recfun_def relation2_def is_recfun_relativize)
apply (rule rall_cong)
apply (blast dest: transM)
done

lemma M_is_recfun_cong [cong]:
     "\<lbrakk>r = r'; a = a'; f = f';
       \<And>x g y. \<lbrakk>M(x); M(g); M(y)\<rbrakk> \<Longrightarrow> MH(x,g,y) \<longleftrightarrow> MH'(x,g,y)\<rbrakk>
      \<Longrightarrow> M_is_recfun(M,MH,r,a,f) \<longleftrightarrow> M_is_recfun(M,MH',r',a',f')"
by (simp add: M_is_recfun_def)

lemma (in M_basic) is_wfrec_abs:
     "\<lbrakk>\<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g));
         relation2(M,MH,H);  M(r); M(a); M(z)\<rbrakk>
      \<Longrightarrow> is_wfrec(M,MH,r,a,z) \<longleftrightarrow>
          (\<exists>g[M]. is_recfun(r,a,H,g) \<and> z = H(a,g))"
by (simp add: is_wfrec_def relation2_def is_recfun_abs)

text\<open>Relating \<^term>\<open>wfrec_replacement\<close> to native constructs\<close>
lemma (in M_basic) wfrec_replacement':
  "\<lbrakk>wfrec_replacement(M,MH,r);
     \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(H(x,g));
     relation2(M,MH,H);  M(r)\<rbrakk>
   \<Longrightarrow> strong_replacement(M, \<lambda>x z. \<exists>y[M].
                pair(M,x,y,z) \<and> (\<exists>g[M]. is_recfun(r,x,H,g) \<and> y = H(x,g)))"
by (simp add: wfrec_replacement_def is_wfrec_abs)

lemma wfrec_replacement_cong [cong]:
     "\<lbrakk>\<And>x y z. \<lbrakk>M(x); M(y); M(z)\<rbrakk> \<Longrightarrow> MH(x,y,z) \<longleftrightarrow> MH'(x,y,z);
         r=r'\<rbrakk>
      \<Longrightarrow> wfrec_replacement(M, \<lambda>x y. MH(x,y), r) \<longleftrightarrow>
          wfrec_replacement(M, \<lambda>x y. MH'(x,y), r')"
by (simp add: is_wfrec_def wfrec_replacement_def)

end