(*  Title:       Inductive definition of Hoare logic for total correctness
    Author:      Tobias Nipkow, 2001/2006
    Maintainer:  Tobias Nipkow
*)

theory HoareTotal imports Hoare Termi begin

subsection\<open>Hoare logic for total correctness\<close>

text\<open>
Now that we have termination, we can define
total validity, \<open>\<Turnstile>\<^sub>t\<close>, as partial validity and guaranteed termination:\<close>

definition
 hoare_tvalid :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<Turnstile>\<^sub>t {(1_)}/ (_)/ {(1_)}" 50) where
  "\<Turnstile>\<^sub>t {P}c{Q} \<longleftrightarrow> \<Turnstile> {P}c{Q} \<and> (\<forall>s. P s \<longrightarrow> c\<down>s)"

text\<open>Proveability of Hoare triples in the proof system for total
correctness is written \<open>\<turnstile>\<^sub>t {P}c{Q}\<close> and defined
inductively. The rules for \<open>\<turnstile>\<^sub>t\<close> differ from those for
\<open>\<turnstile>\<close> only in the one place where nontermination can arise: the
@{term While}-rule.\<close>

inductive
  thoare :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<turnstile>\<^sub>t ({(1_)}/ (_)/ {(1_)})" 50)
where
  Do:  "\<turnstile>\<^sub>t {\<lambda>s. (\<forall>t \<in> f s. P t) \<and> f s \<noteq> {}} Do f {P}"
| Semi: "\<lbrakk> \<turnstile>\<^sub>t {P}c{Q}; \<turnstile>\<^sub>t {Q}d{R} \<rbrakk> \<Longrightarrow> \<turnstile>\<^sub>t {P} c;d {R}"
| If: "\<lbrakk> \<turnstile>\<^sub>t {\<lambda>s. P s \<and> b s}c{Q}; \<turnstile>\<^sub>t {\<lambda>s. P s \<and> ~b s}d{Q}  \<rbrakk> \<Longrightarrow>
      \<turnstile>\<^sub>t {P} IF b THEN c ELSE d {Q}"
| While:
  "\<lbrakk>wf r;  \<forall>s'. \<turnstile>\<^sub>t {\<lambda>s. P s \<and> b s \<and> s' = s} c {\<lambda>s. P s \<and> (s,s') \<in> r}\<rbrakk>
   \<Longrightarrow> \<turnstile>\<^sub>t {P} WHILE b DO c {\<lambda>s. P s \<and> \<not>b s}"
| Conseq: "\<lbrakk> \<forall>s. P' s \<longrightarrow> P s; \<turnstile>\<^sub>t {P}c{Q}; \<forall>s. Q s \<longrightarrow> Q' s  \<rbrakk> \<Longrightarrow>
           \<turnstile>\<^sub>t {P'}c{Q'}"

| Local: "(!!s. P s \<Longrightarrow> P' s (f s)) \<Longrightarrow> \<forall>p. \<turnstile>\<^sub>t {P' p} c {Q o (g p)} \<Longrightarrow>
        \<turnstile>\<^sub>t {P} LOCAL f;c;g {Q}"

text\<open>\noindent The@{term While}- rule is like the one for partial
correctness but it requires additionally that with every execution of
the loop body a wellfounded relation (@{prop"wf r"}) on the state
space decreases.

The soundness theorem\<close>

(* Tried to use this lemma to simplify the soundness proof.
   But "\<turnstile>\<^sub>t {P}c{Q} \<Longrightarrow> (!s. P s \<longrightarrow> c\<down>s)" is not provable because too weak
lemma total_implies_partial: "\<turnstile>\<^sub>t {P} c {Q} \<Longrightarrow> \<turnstile> {P} c {Q}"
apply(erule thoare.induct)
      apply(rule hoare.intros)
        apply (clarify) apply assumption
      apply(rule hoare.intros)
      apply blast
     apply(blast intro:hoare.intros)
    apply(blast intro:hoare.intros)
   defer
   apply(blast intro:hoare.intros)
  apply(blast intro:hoare.intros)
apply(rule hoare.intros)
apply(rule hoare_relative_complete)
apply(unfold hoare_valid_def)
apply(clarify)
apply(erule allE, erule conjE)
apply(drule hoare_sound)
apply(unfold hoare_valid_def)
apply(blast)
done
*)

theorem "\<turnstile>\<^sub>t {P}c{Q}  \<Longrightarrow>  \<Turnstile>\<^sub>t {P}c{Q}"
apply(unfold hoare_tvalid_def hoare_valid_def)
apply(erule thoare.induct)
      apply blast
     apply blast
    apply clarsimp
   defer
   apply blast
 apply(rule conjI)
  apply clarify
  apply(erule allE)
  apply clarify
  apply(erule allE, erule allE, erule impE, erule asm_rl)
  apply simp
  apply(erule mp)
  apply(simp)
 apply blast
apply(rule conjI)
 apply(rule allI)
 apply(erule wf_induct)
 apply clarify
 apply(drule unfold_while[THEN iffD1])
 apply (simp split: if_split_asm)
 apply blast
apply(rule allI)
apply(erule wf_induct)
apply clarify
apply(case_tac "b x")
 apply (blast intro: termi.WhileTrue)
apply (erule termi.WhileFalse)
done
(*>*)

text\<open>\noindent In the @{term While}-case we perform a
local proof by wellfounded induction over the given relation @{term r}.

The completeness proof proceeds along the same lines as the one for partial
correctness. First we have to strengthen our notion of weakest precondition
to take termination into account:\<close>

definition
 wpt :: "com \<Rightarrow> assn \<Rightarrow> assn" ("wp\<^sub>t") where
  "wp\<^sub>t c Q = (\<lambda>s. wp c Q s \<and> c\<down>s)"

lemmas wp_defs = wp_def wpt_def

lemma [simp]: "wp\<^sub>t (c\<^sub>1;c\<^sub>2) R = wp\<^sub>t c\<^sub>1 (wp\<^sub>t c\<^sub>2 R)"
apply(unfold wp_defs)
apply(rule ext)
apply blast
done

lemma [simp]:
 "wp\<^sub>t (IF b THEN c\<^sub>1 ELSE c\<^sub>2) Q = (\<lambda>s. wp\<^sub>t (if b s then c\<^sub>1 else c\<^sub>2) Q s)"
apply(unfold wp_defs)
apply(rule ext)
apply auto
done

lemma [simp]: "wp\<^sub>t (LOCAL f;c;g) Q = (\<lambda>s. wp\<^sub>t c (Q o (g s)) (f s))"
apply(unfold wp_defs)
apply(rule ext)
apply auto
done

inductive_cases [elim!]: "WHILE b DO c \<down> s"

lemma wp_is_pre[rule_format]: "\<turnstile>\<^sub>t {wp\<^sub>t c Q} c {Q}"
apply (induct c arbitrary: Q)
     apply simp_all
     apply(blast intro:thoare.Do thoare.Conseq)
    apply(blast intro:thoare.Semi thoare.Conseq)
   apply(blast intro:thoare.If thoare.Conseq)
  defer
 apply(fastforce intro!: thoare.Local)
apply(rename_tac b c Q)
apply(rule weaken_post)
 apply(rule_tac b=b and c=c in thoare.While)
  apply(rule_tac b=b and c=c in wf_termi)
 defer
 apply (simp add:wp_defs unfold_while)
apply(rule allI)
apply(rule strengthen_pre)
 prefer 2
 apply fast
apply(clarsimp simp add: wp_defs)
apply(blast intro:exec.intros)
done

text\<open>\noindent The @{term While}-case is interesting because we now have to furnish a
suitable wellfounded relation. Of course the execution of the loop
body directly yields the required relation.
The actual completeness theorem follows directly, in the same manner
as for partial correctness.\<close>

theorem "\<Turnstile>\<^sub>t {P}c{Q} \<Longrightarrow> \<turnstile>\<^sub>t {P}c{Q}"
apply (rule strengthen_pre[OF _ wp_is_pre])
apply(unfold hoare_tvalid_def hoare_valid_def wp_defs)
apply blast
done

end


section "Various Utilities"

theory utils
  imports Main
    "HOL-Library.Monad_Syntax"
    "HOL-Library.LaTeXsugar"
begin

subsection "Syntactic Sugar"

text "This theory contains definition and Lemmas that could be in the standard library."

abbreviation todo ("???") where "??? \<equiv> undefined"

abbreviation eqsome :: "'a option \<Rightarrow> 'a \<Rightarrow> bool" (infixr "\<triangleq>" 69) where
  "x \<triangleq> y \<equiv> x = Some y"

abbreviation orElse :: "'a option \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "orElse" 70) where
  "x orElse y \<equiv> case x of Some a \<Rightarrow> a | None \<Rightarrow> y"

text "A definition that is not automatically expanded:"
definition Def (infix "::=" 50) where
"x ::= y \<equiv> x = y"

definition DefSome (infix "::\<triangleq>" 50) where
"x ::\<triangleq> y \<equiv> y = Some x"

subsection "Logic"

lemma iffI2: "\<lbrakk>A \<Longrightarrow> B; \<not>A \<Longrightarrow> \<not>B\<rbrakk> \<Longrightarrow> A \<longleftrightarrow> B"
  by auto

lemma if_cases:
  "\<lbrakk>c \<Longrightarrow> P t; \<not>c \<Longrightarrow> P f\<rbrakk> \<Longrightarrow>  P (if c then t else f)"
  by auto

lemma subset_h1: "X \<subseteq> Y \<Longrightarrow> \<forall>x. x\<in>X \<longrightarrow> x\<in>Y"
  by blast

lemma rewrite_and_implies:
  shows "a \<and> b \<longrightarrow> c \<longleftrightarrow> a \<longrightarrow> b \<longrightarrow> c"
  by auto

lemma flip: "(\<not>Q \<Longrightarrow> \<not>P) \<Longrightarrow> P \<longrightarrow> Q"
  by auto

lemma exists_cases1:
  shows "(\<exists>x. (x = A \<longrightarrow> P x) \<and> (x \<noteq> A \<longrightarrow> Q x))
    \<longleftrightarrow>  (P A) \<or> (\<exists>x. x \<noteq> A \<and> Q x)"
  by auto

lemma exists_cases2:
  shows "(\<exists>x. (x \<noteq> A \<longrightarrow> Q x) \<and> (x = A \<longrightarrow> P x))
    \<longleftrightarrow>  (P A) \<or> (\<exists>x. x \<noteq> A \<and> Q x)"
  by auto

lemma exists_nat_split: "(\<exists>n::nat. P n) \<longleftrightarrow> (P 0 \<or> (\<exists>n. P (Suc n)))"
  using zero_induct by blast

subsection "Lists"

lemma append_eq_conv_conj2:
  "(xs = ys @ zs) \<longleftrightarrow> (take (length ys) xs = ys \<and> (drop (length ys) xs) = zs)"  for xs ys zs
  by (metis append_eq_conv_conj)

lemma cons_eq_conv_conj:
  "(xs = y # ys) \<longleftrightarrow> (xs \<noteq> [] \<and> y = hd xs \<and> ys = tl xs)"  for xs ys zs
  by force

lemma hd_drop_conv_nth2:  "\<lbrakk>i<length xs; a = hd (drop i xs)\<rbrakk> \<Longrightarrow> xs ! i = a"
  by (simp add: hd_drop_conv_nth)

lemma eq_tl: "\<lbrakk>xs \<noteq> []; \<And>a as. xs = a#as \<Longrightarrow> drop i ys = as\<rbrakk> \<Longrightarrow> drop i ys = tl xs"
  by (cases xs, auto)

lemma nth_append_second:
  "i \<ge> length xs \<Longrightarrow> (xs@ys)!i = ys!(i - length xs)"
  by (auto simp add:  nth_append split: if_splits)

lemma nth_cons_tail:
  "i > 0 \<Longrightarrow> (x#xs)!i = xs!(i - 1)"
  by (auto simp add:  nth_Cons split: nat.splits)

lemma nth_append_first:
  "i < length xs \<Longrightarrow> (xs@ys)!i = xs!i"
  by (auto simp add:  nth_append split: if_splits)

lemma show_appendEqH:
  "\<lbrakk>n \<le> length ys; length xs \<ge> n; take n xs = take n ys; drop n xs = zs\<rbrakk> \<Longrightarrow> xs = (take n ys) @ zs"
  by (metis append_take_drop_id)

lemma nth_drop_if:
"drop n xs ! i = (if n \<le> length xs then xs ! (n + i) else [] ! i)"
  by auto

definition "in_sequence xs x y \<equiv> \<exists>i j. i<j \<and> j<length xs \<and> xs!i = x \<and> xs!j=y "

lemma in_sequence_nil[simp]: "in_sequence [] = (\<lambda>x y. False)"
  apply (rule ext)+
  by (auto simp add: in_sequence_def)

lemma in_sequence_cons:
  "in_sequence (x # xs) a b \<longleftrightarrow> (x=a \<and> b\<in>set xs \<or> in_sequence xs a b)"
  apply (auto simp add: in_sequence_def)
    apply (metis (no_types, lifting) Suc_diff_eq_diff_pred Suc_less_eq Suc_pred gr_implies_not_zero not_gr_zero nth_Cons' zero_less_diff)
   apply (metis Suc_mono in_set_conv_nth nth_Cons_0 nth_Cons_Suc zero_less_Suc)
  by (meson Suc_mono nth_Cons_Suc)

lemma in_sequence_append:
  "in_sequence (xs @ ys) a b \<longleftrightarrow> (a\<in>set xs \<and> b\<in>set ys \<or> in_sequence xs a b \<or> in_sequence ys a b)"
proof (induct xs)
  case Nil
  then show ?case
    by auto
next
  case (Cons x xs)
  have "in_sequence ((x#xs) @ ys) a b
      \<longleftrightarrow> x = a \<and> b \<in> set (xs@ys) \<or> in_sequence (xs@ys) a b"
    by (auto simp add: in_sequence_cons)

  also have "... \<longleftrightarrow> x = a \<and> b \<in> set (xs@ys) \<or> (a\<in>set xs \<and> b\<in>set ys \<or> in_sequence xs a b \<or> in_sequence ys a b)"
    using Cons by auto

  also have "... \<longleftrightarrow> (a\<in>set (x#xs) \<and> b\<in>set ys \<or> in_sequence (x#xs) a b \<or> in_sequence ys a b)"
    by (auto simp add: in_sequence_cons)

  finally show ?case by simp
qed

lemma in_sequence_in1: "in_sequence xs x y \<Longrightarrow> x\<in>set xs"
  by (metis in_sequence_def in_set_conv_nth less_imp_le less_le_trans)

lemma in_sequence_in2: "in_sequence xs x y \<Longrightarrow> y\<in>set xs"
  by (metis in_sequence_def nth_mem)

definition "before_in_list xs x y \<equiv> \<exists>i j. i < j \<and> j < length xs \<and> xs!i=x \<and> xs!j=y"

lemma before_in_list_def2:
  "before_in_list xs x y \<longleftrightarrow> (\<exists>xsa xsb. xs = xsa@xsb \<and> x\<in>set xsa \<and> y\<in>set xsb)"
  unfolding before_in_list_def
proof (intro iffI  conjI; elim exE conjE)

  show "\<exists>xsa xsb. xs = xsa @ xsb \<and> x \<in> set xsa \<and> y \<in> set xsb"
    if c0: "i < j"
      and c1: "j < length xs"
      and c2: "xs ! i = x"
      and c3: "xs ! j = y"
    for  i j
  proof (intro exI conjI)

    show "xs = take j xs @ drop j xs"
      by simp

    show "x \<in> set (take j xs)"
      using c0 c1 c2 in_set_conv_nth by fastforce
    show " y \<in> set (drop j xs)"
      by (metis Cons_nth_drop_Suc c1 c3 list.set_intros(1))
  qed

  show "\<exists>i j. i < j \<and> j < length xs \<and> xs ! i = x \<and> xs ! j = y"
    if c0: "xs = xsa @ xsb"
      and c1: "x \<in> set xsa"
      and c2: "y \<in> set xsb"
    for  xsa xsb
  proof -
    from c1 obtain i where "xsa ! i = x" and "i < length xsa"
      by (meson in_set_conv_nth)
    from c2 obtain j where "xsb ! j = y" and "j < length xsb"
      by (meson in_set_conv_nth)
    show ?thesis
    proof (intro exI conjI)
      show "i < length xsa +j"
        by (simp add: \<open>i < length xsa\<close> add.commute trans_less_add2)
      show "length xsa + j < length xs"
        by (simp add: \<open>j < length xsb\<close> c0)
      show " xs ! i = x"
        by (simp add: \<open>i < length xsa\<close> \<open>xsa ! i = x\<close> c0 nth_append_first)
      show "xs ! (length xsa + j) = y"
        by (simp add: \<open>xsb ! j = y\<close> c0)
    qed
  qed
qed

lemma before_in_list_cons:
  "before_in_list (x#xs) a b \<longleftrightarrow> (if x = a then b\<in>set xs else before_in_list xs a b )"
proof (auto simp add: before_in_list_def2)

  show "b \<in> set xs"
    if c0: "x = a"
      and c1: "a # xs = xsa @ xsb"
      and c2: "a \<in> set xsa"
      and c3: "b \<in> set xsb"
    for  xsa xsb
    using that by (metis Un_iff empty_iff empty_set list.sel(3) set_append tl_append2)

  show "\<exists>xsa xsb. a # xs = xsa @ xsb \<and> a \<in> set xsa \<and> b \<in> set xsb"
    if c0: "x = a"
      and c1: "b \<in> set xs"
  proof (intro exI conjI)
    show "a # xs = [a] @ xs" by simp
  qed (auto simp add: c1)

  show "\<exists>xsa xsb. xs = xsa @ xsb \<and> a \<in> set xsa \<and> b \<in> set xsb"
    if c0: "x \<noteq> a"
      and c1: "x # xs = xsa @ xsb"
      and c2: "a \<in> set xsa"
      and c3: "b \<in> set xsb"
    for  xsa xsb
  proof (intro exI conjI)
    show "xs = tl xsa @ xsb"
      by (metis c1 c2 equals0D list.sel(3) set_empty tl_append2)
    show "a \<in> set (tl xsa)"
      by (metis c0 c1 c2 hd_append list.collapse list.sel(1) set_ConsD tl_Nil)
  qed (simp add: c3)

  show "\<exists>xsaa xsba. x # xsa @ xsb = xsaa @ xsba \<and> a \<in> set xsaa \<and> b \<in> set xsba"
    if c0: "x \<noteq> a"
      and c1: "xs = xsa @ xsb"
      and c2: "a \<in> set xsa"
      and c3: "b \<in> set xsb"
    for  xsa xsb
  proof (intro exI conjI)
    show "x # xsa @ xsb = (x#xsa) @ xsb" by simp
  qed(auto simp add: that)
qed

lemma before_in_list_contains_l: "before_in_list cs x y \<Longrightarrow> x\<in>set cs"
  by (metis before_in_list_def dual_order.strict_trans in_set_conv_nth)

lemma  before_in_list_contains_r: "before_in_list cs x y \<Longrightarrow> y\<in>set cs"
  by (metis before_in_list_def in_set_conv_nth)

lemma before_in_list_empty[simp]: "\<not>before_in_list [] x y"
  by (simp add: before_in_list_def)

subsection "Math"

lemma sumSplit:
  fixes f :: "nat \<Rightarrow> nat"
  shows "(\<Sum>i<x+y . f i) = (\<Sum>i<x . f i) + (\<Sum>i<y . f (x+i))"
  by (induct y, auto)

subsection "Least"

lemma LeastI2:
  "\<lbrakk>x = (LEAST x::nat. P x); P y\<rbrakk> \<Longrightarrow> P x"
  by (simp add: LeastI)

lemma usePropertyOfLeast:
  fixes x :: "'a :: wellorder"
  assumes wellDefined: "Q x"
    and weakerProperty: "\<And>x. Q x \<Longrightarrow> P x"
  shows "P (LEAST x. Q x)"
  using LeastI weakerProperty wellDefined by auto

lemma showIsLeast:
  fixes x :: "'a :: wellorder"
  assumes "P x"
    and "\<And>y. P y \<Longrightarrow> x \<le> y"
  shows "x = (LEAST x. P x)"
  using Least_equality assms(1) assms(2) by auto

lemma nth_secondHalf_eq:
  assumes "i\<ge>length xs"
    and "length xs = length ys"
  shows "(xs@zs)!i = (ys@zs)!i"
  using assms by (auto simp add: nth_append)

subsection "Maximum of a set of nats"

definition max_natset :: "nat set \<Rightarrow> nat" where
  "max_natset S \<equiv> if S = {} then 0 else Suc (Max S)"

lemma max_natset_empty: "max_natset S = 0 \<longleftrightarrow> S = {}"
  by (simp add: max_natset_def)

lemma max_natset_Collect_Suc:
  assumes "max_natset {x. P x} = Suc i"
    and "finite {x. P x}"
  shows "P i"
    and "\<And>j. P j \<Longrightarrow> j\<le>i"
  using assms  by (auto simp add: max_natset_def  split: if_splits,
      insert Max_in, blast)

lemma show_max_natset_smaller:
  assumes "i \<in> S"
    and "finite S"
    and "\<And>j. j\<in>S' \<Longrightarrow> j < i"
  shows "max_natset S' < max_natset S"
  using assms by (auto simp add: max_natset_def,
   metis Max_gr_iff Max_in all_not_in_conv bounded_nat_set_is_finite)

lemma show_max_natset_smaller_Collect:
  assumes "P i"
    and "finite {i. P i}"
    and "\<And>j. P' j \<Longrightarrow> j < i"
  shows "max_natset {i. P' i} < max_natset {i. P i}"
  by (rule show_max_natset_smaller,
      insert assms, force+)

subsection "Induction over greatest and smallest elements"

lemma finiteH:
  "finite {x::nat. 0 < x \<and> x < A \<and> P x}"
  by simp

text "Like @{thm[mode=Rule] less_induct}, but reversed with an upper bound.
We only need it for natural numbers, but it could probably be generalized.
"
lemma greater_induct [case_names greater]:
  assumes  step: "\<And>x. \<lbrakk>\<And>y. \<lbrakk>y > x; y < bound\<rbrakk> \<Longrightarrow> P y\<rbrakk> \<Longrightarrow> P x"
  shows "P (a::nat)"
proof (induct "bound - a" arbitrary: a  rule: less_induct)
  case less
  show "P a"
  proof (rule step)
    show "P y" if "a < y" and "y < bound" for y
    proof (rule less)

      show "bound - y < bound - a"
        using diff_less_mono2 dual_order.strict_trans that by blast
    qed
  qed
qed

lemma exists_greatest:
  assumes example: "P j"
    and bounded: "\<And>j. P j \<Longrightarrow> j \<le> bound"
  shows "\<exists>j::nat. P j \<and> (\<forall>j'. P j' \<longrightarrow> j' \<le> j)"
  using example proof (induct "bound - j" arbitrary: j)
  case 0
  with bounded
  have "j = bound"
    by force
  then show ?case
    using "0.prems" bounded by blast
next
  case (Suc i)
  then show ?case
    by (metis bounded bounded_Max_nat)
qed

lemma exists_greatest':
  assumes example: "\<exists>j. P j"
    and bounded: "\<exists>bound. \<forall>j. P j \<longrightarrow> j \<le> bound"
  shows "\<exists>j::nat. P j \<and> (\<forall>j'. P j' \<longrightarrow> j' \<le> j)"
  using bounded example exists_greatest by auto

lemma split_take:
  assumes "ys = drop i xs"
  shows "xs = take i xs @ ys"
  by (simp add: assms)

lemma use_Greatest:
  assumes "\<exists>x. P x"
    and "\<exists>bound. \<forall>x. P x \<longrightarrow> x \<le> bound"
  shows "P (GREATEST x::nat. P x)
\<and> (\<forall>y. P y \<longrightarrow> y \<le> (GREATEST x::nat. P x))"
  using GreatestI_nat Greatest_le_nat assms by auto

lemma use_Greatest2:
  assumes "P x"
    and "\<forall>x. P x \<longrightarrow> x \<le> bound"
  shows "P (GREATEST x::nat. P x)
\<and> (\<forall>y. P y \<longrightarrow> y \<le> (GREATEST x::nat. P x))"
  by (rule use_Greatest, insert assms, auto)

lemma Greatest_smaller:
  assumes "\<exists>x::nat. P x"
    and "\<exists>bound. \<forall>x. P x \<longrightarrow> x \<le> bound"
    and "\<And>y. P y \<Longrightarrow> y < x"
  shows "Greatest P < x"
  using assms
  using GreatestI_nat by auto

lemma Greatest_bigger:
  fixes P :: "nat \<Rightarrow> bool"
  assumes "P y"
    and "\<exists>bound. \<forall>x. P x \<longrightarrow> x \<le> bound"
    and "x < y"
  shows "x < Greatest P"
proof -
  from \<open>P y\<close> have "\<exists>x. P x" by auto

  from use_Greatest[OF \<open>\<exists>x. P x\<close> \<open>\<exists>bound. \<forall>x. P x \<longrightarrow> x \<le> bound\<close>] assms
  show "x < Greatest P"
    by auto
qed

text "Like @{thm[mode=Rule] less_induct}, but reversed with an upper bound.
We only need it for natural numbers, but it could probably be generalized.
"
lemma greater_induct2 [case_names bounded greater]:
  assumes "a < bound"
    and  step: "\<And>x. \<lbrakk>\<And>y. \<lbrakk>y > x; y < bound\<rbrakk> \<Longrightarrow> P y; x < bound\<rbrakk> \<Longrightarrow> P x"
  shows "P (a::nat)"
  using `a < bound`
proof (induct "bound - a" arbitrary: a  rule: less_induct)
  case less
  show "P a"
  proof (rule step)
    show "P y" if "a < y" and "y < bound" for y
    proof (rule less)

      show "bound - y < bound - a"
        using diff_less_mono2 dual_order.strict_trans that by blast

      show " y < bound"
        by (simp add: that(2))
    qed

    show "a < bound"
      using less.prems by auto

  qed
qed

definition "is_bounded S bound \<equiv> \<forall>x\<in>S. x < bound"

lemma use_is_bounded:
  assumes "is_bounded S bound" and "x \<in> S"
  shows "x < bound"
  using assms is_bounded_def by blast

lemma min_set_induct[consumes 1, induct set: is_bounded, case_names empty step[not_empty bounded IH]]:
  fixes S :: "nat set"
  assumes bounded: "is_bounded S bound"
    and empty: "P {}"
    and step: "\<And>S. \<lbrakk>S \<noteq> {}; is_bounded S bound; (\<And>S'. \<lbrakk>S' \<noteq> {} \<Longrightarrow> Inf S' > Inf S; is_bounded S' bound\<rbrakk> \<Longrightarrow> P S')\<rbrakk> \<Longrightarrow> P S"
  shows "P S"
  using bounded
proof (induct "if S = {} then 0 else bound - (Inf S)" arbitrary: S rule: less_induct)
  case less
  show ?case
  proof (cases "S = {}")
    case True
    then show ?thesis
      by (simp add: empty)
  next
    case False
    show ?thesis
    proof (rule step)

      from ` S \<noteq> {}` obtain x where "x \<in> S"
        by blast

      moreover have "x < bound"
        using calculation less.prems use_is_bounded by blast

      ultimately have "Inf S < bound"
        by (meson False Inf_nat_def1 is_bounded_def less.prems)

      show "S \<noteq> {}"
        by (simp add: False)
      show "is_bounded S bound"
        using less.prems by blast

      show "P S'"
        if  c1: "S' \<noteq> {} \<Longrightarrow> Inf S < Inf S'"
          and c2: "is_bounded S' bound"
        for  S'
      proof (rule less)
        show "(if S' = {} then 0 else bound - Inf S') < (if S = {} then 0 else bound - Inf S)"
          by (auto simp add:  \<open>Inf S < bound\<close> \<open>S \<noteq> {}\<close> c1 diff_less_mono2)

        show "is_bounded S' bound"
          using c2 by blast
      qed
    qed
  qed
qed

lemma forward_induct[case_names zero step[given broken bound]]:
  assumes init: "Q 0"
    and step: "\<And>i::nat. \<lbrakk>Q i; \<not>Q (Suc i);  i < bound\<rbrakk> \<Longrightarrow> \<exists>j>i. Q j "
  shows "\<exists>i\<ge>bound. Q i"
proof (rule ccontr, clarsimp)
  assume "\<forall>i\<ge>bound. \<not> Q i"
  hence bounded: "\<forall>y. Q y \<longrightarrow> y < bound"
    using not_le_imp_less by blast
  hence bounded2: "\<forall>y. Q y \<longrightarrow> y \<le> bound - 1"
    by auto

  from use_Greatest2[OF init bounded2]
  have "Q (GREATEST x. Q x)"
    and  "(\<forall>y. Q y \<longrightarrow> y \<le> (GREATEST x. Q x))"
    by auto

  from `Q (GREATEST x. Q x)`
  have "(GREATEST x. Q x) < bound"
    by (simp add: bounded)

  obtain i
    where "Q i"
      and "\<forall>j>i. \<not>Q j"
      and "i < bound"
    using \<open>(GREATEST x. Q x) < bound\<close> \<open>Q (GREATEST x. Q x) \<and> (\<forall>y. Q y \<longrightarrow> y \<le> (GREATEST x. Q x))\<close> leD by auto

  have "\<exists>j>i. Q j"
    using `Q i`
  proof (rule step)

    show "i < bound" using `i < bound` .

    show "\<not> Q (Suc i)"
      by (simp add: \<open>\<forall>j>i. \<not> Q j\<close>)
  qed

  thus False
    using \<open>\<forall>j>i. \<not> Q j\<close> by blast
qed

lemma show_Inf_smaller:
  assumes "(i::nat) \<in> S"
    and "\<And>i'. i'\<in>S' \<Longrightarrow> i < i'"
    and "S' \<noteq> {}"
  shows "Inf S < Inf S'"
  by (metis Inf_nat_def1 assms(1) assms(2) assms(3) bdd_above_bot cInf_less_iff empty_iff)

subsection "Well orders"

text "All types have an implicit well order that can be used when deterministically picking an
arbitrary element from a set."

definition some_well_order :: "'a rel" where
 "some_well_order \<equiv> (SOME ord. well_order ord)"

lemma some_well_order_is_well_order: "well_order some_well_order"
  by (metis someI_ex some_well_order_def well_ordering)

lemma some_well_order_is_linear_order: "linear_order some_well_order"
  using some_well_order_is_well_order well_order_on_def by blast

lemma some_well_order_is_wo_rel: "wo_rel some_well_order"
  using some_well_order_is_well_order well_order_on_Well_order wo_rel_def by blast

lemma some_well_order_includes_all: "S \<subseteq> Field some_well_order"
  using some_well_order_is_well_order well_order_on_Field by fastforce

definition firstValue :: "'a \<Rightarrow> ('b \<Rightarrow> 'a option) \<Rightarrow> 'a" where
"firstValue d m \<equiv> if m = Map.empty then d else
  let maxK = wo_rel.minim some_well_order (dom m) in
  the (m maxK)
  "

lemma firstValue_in_ran:
  assumes "finite (dom m)"
and not_default: "firstValue d m \<noteq> d"
shows "firstValue d m \<in> Map.ran m"
  using not_default proof (auto simp add: firstValue_def )
  assume "m \<noteq> Map.empty"
  have "(wo_rel.minim some_well_order (dom m)) \<in> dom m"
    by (simp add: \<open>m \<noteq> Map.empty\<close> some_well_order_includes_all some_well_order_is_wo_rel wo_rel.minim_in)

  from this
  show "the (m (wo_rel.minim some_well_order (dom m))) \<in> ran m"
    by (meson domIff option.exhaust_sel ranI)
qed

subsection "Option Type"

text "We define some nicer syntax for working with options and maps."

lemma option_bind_def:
"(x \<bind> f) = (case x of None \<Rightarrow> None | Some a \<Rightarrow> f a)"
  by (metis bind.bind_lunit bind_eq_None_conv option.case_eq_if option.exhaust_sel)

definition map_chain ::  "('a \<rightharpoonup> 'b) \<Rightarrow> ('b \<rightharpoonup> 'c) \<Rightarrow> 'a \<rightharpoonup> 'c" (infixr "\<ggreater>" 54) where
"(f \<ggreater> g) \<equiv> \<lambda>x. f x \<bind> g"

definition map_map ::  "('a \<rightharpoonup> 'b) \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow> 'a \<rightharpoonup> 'c" where
"(map_map f g) \<equiv> \<lambda>x. map_option g (f x)"

lemma dom_map_chain:
"dom (f \<ggreater> g) = {x | x y z. f x \<triangleq> y \<and> g y \<triangleq> z}"
  by (auto simp add: map_chain_def option_bind_def split: option.splits)

lemma dom_map_map[simp]:
"dom (map_map f g) = dom f"
  by (auto simp add: map_map_def)

lemma map_map_apply_eq_some[simp]:
"(map_map f g x \<triangleq> z) \<longleftrightarrow> (\<exists>y. f x \<triangleq> y \<and> g y = z)"
  by (auto simp add: map_map_def split: option.splits)

lemma map_map_apply_eq_none[simp]:
"(map_map f g x = None) \<longleftrightarrow> (f x = None)"
  by (auto simp add: map_map_def split: option.splits)

lemma map_map_apply:
"map_map f g x = (case f x of None \<Rightarrow> None | Some y \<Rightarrow> Some (g y))"
  by (auto simp add: map_map_def split: option.splits)

definition is_reverse :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> bool" where
"is_reverse f_in f_out \<equiv>
  (\<forall>x y. ((f_in x) \<triangleq> y) \<longrightarrow> (f_out y = x))
  \<and> (\<forall>x.  (f_in (f_out x)) \<triangleq> x)"

lemma is_reverse_1:
  assumes "is_reverse f_in f_out"
    and "f_in x \<triangleq> y"
  shows "f_out y = x"
  by (meson assms is_reverse_def)

lemma is_reverse_2:
  assumes "is_reverse f_in f_out"
  shows "f_in (f_out x) \<triangleq> x"
  by (meson assms is_reverse_def)

lemma is_reverse_combine:
  assumes is_rev: "is_reverse C_in C_out"
    and is_rev': "is_reverse C_in' C_out'"
    shows "is_reverse (C_in' \<ggreater> C_in) (C_out' \<circ> C_out)"
  by (smt bind_eq_Some_conv comp_apply is_rev is_rev' is_reverse_def map_chain_def)

lemma is_reverse_trivial: "is_reverse Some id"
  by (simp add: is_reverse_def)

subsection "Almost the Same"

text "Sometimes we want to express that two maps or relations are almost
the same (just on a subset)."

definition "map_same_on Cs op op' \<equiv> \<forall>c\<in>Cs. op c = op' c"
definition "rel_same_on Cs hb hb' \<equiv> \<forall>x\<in>Cs.\<forall>y\<in>Cs. (x,y)\<in>hb \<longleftrightarrow> (x,y)\<in>hb'"

lemma map_same_on_trivial[simp]:
"map_same_on Cs x x"
  by (simp add: map_same_on_def)

lemma rel_same_on_trivial[simp]:
"rel_same_on Cs x x"
  by (simp add: rel_same_on_def)

definition
"is_from x initial S \<equiv> if S = {} then x = initial else x \<in> S"

lemma is_from_exists:
  assumes "\<exists>x. x\<in>S"
  shows "is_from x initial S \<longleftrightarrow> x \<in> S"
  by (metis assms empty_iff is_from_def)

lemma is_from_not_initial:
  assumes "x\<noteq> initial"
  shows "is_from x initial S \<longleftrightarrow> x \<in> S"
  by (metis assms empty_iff is_from_def)

subsection "Minimums and Maximums"

text "A finite set with an acyclic order has minimal elements."

lemma exists_min_wf:
  assumes wf: "wf r"
    and "P x"
  shows "\<exists>x. P x \<and> (\<forall>y. P y \<longrightarrow> (y,x)\<notin>r)"
  by (metis assms mem_Collect_eq wf_eq_minimal)

lemma exists_max_wf:
  assumes wf: "wf (r\<inverse>)"
    and "P x"
  shows "\<exists>x. P x \<and> (\<forall>y. P y \<longrightarrow> (x,y)\<notin>r)"
  by (metis assms converse.intros exists_min_wf)

lemma exists_min_wf':
  assumes wf: "wf r"
    and "trans r"
    and "P x"
  shows "\<exists>x'. P x' \<and> (x = x' \<or> (x',x)\<in>r)  \<and> (\<forall>y. P y \<longrightarrow> (y,x')\<notin>r)"
proof -

  from exists_min_wf[OF wf, where P="\<lambda>x'. P x' \<and> (x = x' \<or> (x',x)\<in>r)"]
  obtain x'
    where "P x'"
      and "x = x' \<or> (x', x) \<in> r"
      and "\<forall>y. P y \<and> (x = y \<or> (y, x) \<in> r) \<longrightarrow> (y, x') \<notin> r"
    using `P x` by blast

  have "\<forall>y. P y \<longrightarrow> (y,x')\<notin>r"
    by (metis \<open>\<forall>y. P y \<and> (x = y \<or> (y, x) \<in> r) \<longrightarrow> (y, x') \<notin> r\<close> \<open>x = x' \<or> (x', x) \<in> r\<close> `trans r` transD)

  thus ?thesis
    using \<open>P x'\<close> \<open>x = x' \<or> (x', x) \<in> r\<close> by blast
qed

lemma exists_max_wf':
  assumes wf: "wf (r\<inverse>)"
    and "trans r"
    and "P x"
  shows "\<exists>x'. P x' \<and> (x = x' \<or> (x,x')\<in>r)  \<and> (\<forall>y. P y \<longrightarrow> (x',y)\<notin>r)"
  using assms exists_min_wf' by fastforce

lemma exists_min:
  assumes fin: "finite S"
    and nonempty: "x\<in>S"
    and acyclic: "acyclic r"
  shows "\<exists>x. x\<in>S \<and> (\<forall>y\<in>S. (y,x)\<notin>r)"
proof -
  have "wf (Restr r S)"
  proof (rule finite_acyclic_wf)
    show "finite (Restr r S)"
      using fin by simp
    show "acyclic (Restr r S)"
      using acyclic by (meson Int_lower1 acyclic_subset)
  qed

  show ?thesis
    by (smt IntI \<open>wf (Restr r S)\<close> mem_Sigma_iff nonempty wfE_min)
qed

lemma exists_min_wellorder:
  fixes P :: "'a::wellorder \<Rightarrow> bool"
  assumes  nonempty: "P x"
  shows "\<exists>x. P x \<and> (\<forall>y. P y \<longrightarrow> x \<le> y)"
  by (meson LeastI nonempty wellorder_Least_lemma(2))

text "A finite set with an acyclic order has maximal elements."

lemma exists_max:
  assumes fin: "finite S"
    and nonempty: "x\<in>S"
    and acyclic: "acyclic r"
  shows "\<exists>x. x\<in>S \<and> (\<forall>y\<in>S. \<not>(x,y)\<in>r)"
proof -

  have "\<exists>x. x\<in>S \<and> (\<forall>y\<in>S. \<not>(y,x)\<in>r\<inverse>)"
    using fin nonempty
  proof (rule exists_min)
    show "acyclic (r\<inverse>)"
      by (simp add: acyclic)
  qed
  thus ?thesis
    by simp
qed

lemma ex_least_nat_le':
  fixes n:: "'a::wellorder"
assumes "P n"
shows"\<exists>k\<le>n. (\<forall>i<k. \<not> P i) \<and> P k"
  by (rule exI[where x="LEAST k. P k"],
     blast intro: Least_le `P n` LeastI_ex dest: not_less_Least)

lemma ex_least_nat_le'':
  fixes P:: "'a::wellorder \<Rightarrow> bool"
assumes "Ex P"
shows"\<exists>k. (\<forall>i<k. \<not> P i) \<and> P k"
  using assms ex_least_nat_le' by blast

subsection "Maps"

lemma ran_empty_iff[simp] :"(ran F = {}) \<longleftrightarrow> F = Map.empty"
  by (metis  empty_iff option.exhaust_sel ranI ran_empty)

lemma eq_map_empty[simp] :"(M = Map.empty) \<longleftrightarrow> (\<forall>x. M x = None)"
  by (rule fun_eq_iff)

definition
"map_update_all s_callOrigin localCalls tx \<equiv>  s_callOrigin ++ (Map.map_of (map (\<lambda>c. (c, tx)) localCalls))"

lemma map_update_all_empty[simp]: "map_update_all co [] t = co"
  by (simp add: map_update_all_def)

lemma map_update_all_get:
"map_update_all co cs tx c = (if c\<in>set cs then Some tx else co c)"
 using split_list by (auto simp add: map_update_all_def map_add_def  dest: map_of_SomeD split: option.splits, fastforce)

lemma map_update_all_None:
"map_update_all m xs y x = None \<longleftrightarrow> (x\<notin>set xs \<and> m x = None)"
  by (induct xs, auto simp add: map_update_all_def)

lemma map_update_all_Some_same:
"map_update_all m xs y x \<triangleq> y \<longleftrightarrow> (x\<in>set xs \<or> m x \<triangleq> y)"
  by (induct xs, auto simp add: map_update_all_def)

lemma map_update_all_Some_other:
  assumes "y' \<noteq> y"
  shows "map_update_all m xs y x \<triangleq> y' \<longleftrightarrow> (x\<notin>set xs \<and> m x \<triangleq> y')"
  using assms  by (induct xs, auto simp add: map_update_all_def)

lemma map_of_None: "map_of xs x = None \<longleftrightarrow> (\<forall>y. (x,y)\<notin>set xs)"
  by (induct xs, auto)
lemma map_of_Some: "\<lbrakk>distinct (map fst xs)\<rbrakk> \<Longrightarrow>  map_of xs x = Some y \<longleftrightarrow> ((x,y)\<in>set xs)"
  by (induct xs, auto, (metis map_of_eq_None_iff map_of_is_SomeI option.simps(3)))

lemma restrict_map_noop: "dom m \<subseteq> S \<Longrightarrow> m |` S = m"
   using domIff by (auto simp add: restrict_map_def intro!: ext, force)

lemma restrict_map_noop2[simp]: "m |` dom m = m"
  by (simp add: restrict_map_noop)

subsection "Sets"

lemma Set_fillter_insert[simp]:
"Set.filter f (insert x S) = (if f x then {x} else {}) \<union> Set.filter f S"
  by (auto simp add: Set.filter_def)

lemma Set_filter_empty[simp]:
"Set.filter f {} = {}"
  by (auto simp add: Set.filter_def)

lemma domExists_simp: "x \<in> dom f \<longleftrightarrow> (\<exists>y. f x \<triangleq> y)"
  by (auto)

lemma in_dom:
  assumes "S \<subseteq> dom T" and "x \<in> S"
  shows "\<exists>y. T x \<triangleq> y"
  using assms by blast

lemma in_img_simp: "y\<in>f`S \<longleftrightarrow> (\<exists>x\<in>S. f x = y)"
  by auto

subsection "Relations"

definition restrict_relation :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a rel" (infixl "|r"  110)
  where "r |r A \<equiv> Restr r A" \<comment> \<open>This is a definition because Restr is just an abbreviation
                                 and does not behave well when using methods like auto.\<close>

definition downwardsClosure :: "'a set \<Rightarrow> 'a rel \<Rightarrow> 'a set"  (infixr "\<down>" 100)  where
  "S \<down> R \<equiv> S \<union> {x | x y . (x,y)\<in>R \<and> y\<in>S}"

lemma downwardsClosure_in:
  "x \<in> S \<down> R \<longleftrightarrow> (x\<in>S \<or> (\<exists>y\<in>S. (x,y)\<in>R))"
  by (auto simp add: downwardsClosure_def)

lemma downwardsClosure_subset:
  "S \<down> R \<subseteq> S \<union> fst ` R"
  by (auto simp add: downwardsClosure_in Domain.DomainI fst_eq_Domain)

lemma restrict_relation_noop: "Field r \<subseteq> S \<Longrightarrow> r |r S = r"
  by (auto simp add: restrict_relation_def FieldI1 FieldI2 subset_h1)

lemma infinite_if_mappable_to_nat:
  assumes mapping: "\<And>n::nat. \<exists>x\<in>S. f x \<ge> n"
  shows "infinite S"
proof auto
  assume "finite S"
  hence "finite (f ` S)"
    by force

  define m where "m \<equiv> Max (f ` S)"

  from mapping[where n="Suc m"] obtain x where
    "x\<in>S" and "f x \<ge> Suc m"
    by auto

  have "f x \<in> (f ` S)"
    using \<open>x \<in> S\<close> by blast

  have "f x > m"
    using Suc_le_eq \<open>Suc m \<le> f x\<close> by blast
  hence "f x > Max (f ` S)"
    using m_def by blast
  thus False
    using Max_ge \<open>f x \<in> f ` S\<close> \<open>finite (f ` S)\<close> leD by blast
qed

subsection "Paths in Relations"

text "A list can be a path in a relation where subsequent elements are in relation."

definition is_path
  where "is_path path r \<equiv> (\<forall>i<length path - 1. (path!i, path!(Suc i))\<in>r)"

lemma is_path_empty[simp]:
  shows "is_path [] r"
  by (auto simp add: is_path_def)

lemma is_path_single[simp]:
  shows "is_path [x] r"
  by (auto simp add: is_path_def)

lemma is_path_cons:
  shows "is_path (x#y#xs) r \<longleftrightarrow> (x,y)\<in>r \<and> is_path (y#xs) r"
  using less_Suc_eq_0_disj by (auto simp add: is_path_def)

lemma is_path_cons2:
  shows "is_path (x#xs) r \<longleftrightarrow> (xs = [] \<or> (x,hd xs)\<in>r \<and> is_path xs r)"
  by (metis is_path_cons is_path_single list.collapse)

lemma is_path_append:
  assumes "xs \<noteq> []" and "ys \<noteq> []"
  shows
"is_path (xs@ys) r \<longleftrightarrow> is_path xs r \<and> (last xs, hd ys)\<in>r \<and> is_path ys r"
  using assms by (induct xs, auto simp add: is_path_cons2)

lemma is_path_trans_cl:
  shows "(x,y)\<in>r\<^sup>+ \<longleftrightarrow> (\<exists>path. length path > 1 \<and> is_path path r \<and> hd path = x \<and> last path = y)"
proof
  show "\<exists>path. 1 < length path \<and> is_path path r \<and> hd path = x \<and> last path = y" if "(x, y) \<in> r\<^sup>+"
    using that
  proof (induct)
    case (base y)
    show ?case
    proof (intro conjI exI)
      show "hd [x,y] = x" by simp
      show "last [x, y] = y" by simp
      show "1 < length [x, y]" by simp
      show "is_path [x, y] r" by (auto simp add: is_path_def base)
    qed
  next
    case (step y z)
    from this
    obtain path
      where "1 < length path"
        and "is_path path r"
        and "hd path = x"
        and "last path = y"
      by blast

    have "path \<noteq> []"
      using \<open>1 < length path\<close> by auto

    show ?case
    proof (intro conjI exI)
      show "hd (path @ [z]) = x" using `hd path = x` `path \<noteq> []` by simp
      show "1 < length (path @ [z])"  using \<open>1 < length path\<close> by auto
      show "is_path (path @ [z]) r" using `is_path path r` `(y, z) \<in> r` apply (auto simp add: is_path_def nth_append)
        by (metis Suc_lessI \<open>last path = y\<close> \<open>path \<noteq> []\<close> diff_Suc_1 last_conv_nth)

      show "last (path @ [z]) = z" by simp
    qed
  qed

next
  assume "\<exists>path. 1 < length path \<and> is_path path r \<and> hd path = x \<and> last path = y"
  from this obtain path
    where "1 < length path"
      and "is_path path r"
      and "hd path = x"
      and "last path = y"
    by blast

  thus "(x, y) \<in> r\<^sup>+"
  proof (induct path arbitrary: x y rule: rev_induct)
    case Nil
    then show ?case by simp
  next
    case (snoc e path x y)
    show ?case
    proof (cases "1 < length path")
      case True
      have "(x, last path) \<in> r\<^sup>+"
        using `1 < length path`
      proof (rule snoc.hyps)
        show "is_path path r"
          by (metis True is_path_append less_numeral_extra(2) list.size(3) not_Cons_self2 snoc.prems(2))
        show "hd path = x"
          using True dual_order.strict_trans snoc.prems(3) by fastforce
        show "last path = last path" ..
      qed

      from `is_path (path @ [e]) r`
      have "(last path, e) \<in> r"
        by (metis One_nat_def True is_path_append length_greater_0_conv list.sel(1) not_Cons_self2 order.strict_trans zero_less_Suc)

      show "(x, y) \<in> r\<^sup>+"
        using \<open>(last path, e) \<in> r\<close> \<open>(x, last path) \<in> r\<^sup>+\<close> `last (path @ [e]) = y` by auto
    next
      assume "\<not> 1 < length path"
      hence "length path \<le> 1" by simp
      hence "length path = 1"
        using less_Suc_eq snoc.prems(1) by auto

      hence "(x,y)\<in>r"
        by (metis One_nat_def append_is_Nil_conv diff_Suc_1 hd_conv_nth is_path_def last_snoc length_append_singleton less_Suc_eq not_Cons_self nth_append_length snoc.prems(2) snoc.prems(3) snoc.prems(4))

      thus "(x, y) \<in> r\<^sup>+"
        by simp
    qed
  qed
qed

lemma acyclic_path:
"acyclic r \<longleftrightarrow> (\<nexists>path. length path > 1 \<and> is_path path r \<and> hd path = last path)"
  by (auto simp add: acyclic_def is_path_trans_cl)

lemma acyclic_union_disjoint:
  assumes "acyclic r"
    and "acyclic s"
    and "snd ` s \<inter> fst ` r = {}"
  shows "acyclic (r \<union> s)"
proof (auto simp add:  acyclic_path)
  fix path
  assume a0: "is_path path (r \<union> s)"
    and a1: "Suc 0 < length path"
    and a2: "hd path = last path"

  have all_following_in_s:
    "(path!j, path!Suc j)\<in>s"
    if "(path!i, path!Suc i)\<in>s"
      and "j\<ge>i"
      and "j < length path - 1"
      and "i < length path - 1"
    for i j
    using that
  proof (induct "j-i" arbitrary: j)
    case 0
    then show ?case
      using `(path!i, path!Suc i)\<in>s`
      by auto
  next
    case (Suc n)
    have [simp]: "Suc (j - 1) = j"
      using Suc.hyps(2) by auto

    have [simp]: "Suc (j - Suc 0) = j"
      using Suc.hyps(2) by auto

    have "(path ! (j - 1), path ! Suc (j - 1)) \<in> s"
    proof (rule Suc.hyps)
      show "n = j - 1 - i"
        using Suc.hyps(2) by auto
      show "i \<le> j - 1"
        using Suc.hyps(2) by linarith
      show "j - 1 < length path - 1"
        using Suc.prems less_imp_diff_less by blast
      show " i < length path - 1"
        using that by blast
      show " (path ! i, path ! Suc i) \<in> s"
        by (simp add: that)
    qed
    hence "path ! j \<in> snd ` s"
      by (simp add: rev_image_eqI)

    have "(path ! j, path ! Suc j) \<notin> r"
    proof (rule ccontr, simp)
      assume "(path ! j, path ! Suc j) \<in> r"
      hence "path ! j \<in> fst ` r"
        using image_iff by fastforce

      with \<open>snd ` s \<inter> fst ` r = {}\<close> \<open>path ! j \<in> snd ` s\<close>
      show False  by auto
    qed

    thus "(path ! j, path ! Suc j) \<in> s"
      by (meson Suc.prems Un_iff a0 is_path_def)
  qed

  have "(path!0, path!1)\<in>r"
  proof (rule ccontr)
    assume "(path ! 0, path ! 1) \<notin> r "
    hence "(path ! 0, path ! 1) \<in> s"
      by (metis One_nat_def Un_iff a0 a1 is_path_def zero_less_diff)
    have "is_path path s"
      apply (auto simp add: is_path_def)
      by (metis One_nat_def \<open>(path ! 0, path ! 1) \<in> s\<close> a1 all_following_in_s less_Suc0 not_le_imp_less not_less_iff_gr_or_eq zero_less_diff)
    thus False
      using `acyclic s`
      by (metis One_nat_def a1 a2 acyclic_path)
  qed

  obtain i
    where "i < length path - 1"
      and "(path!i, path!Suc i)\<notin>r"
    apply (atomize_elim, rule ccontr)
    using `acyclic r` apply (auto simp add: acyclic_path)
    by (metis One_nat_def a1 a2 is_path_def)

  hence "(path!i, path!Suc i)\<in>s"
    by (meson Un_iff a0 is_path_def)

  hence "(path!(length path - 2),path!(Suc ((length path - 2))))\<in>s"
  proof (rule all_following_in_s)
    show " i \<le> length path - 2"
      using \<open>i < length path - 1\<close> by linarith
    show "length path - 2 < length path - 1"
      by (simp add: a1 diff_less_mono2)
    show "i < length path - 1"
      using \<open>i < length path - 1\<close> by blast
  qed

  have "hd path \<in> fst ` r"
    by (metis One_nat_def \<open>(path ! 0, path ! 1) \<in> r\<close> a1 fst_conv hd_conv_nth image_iff list.size(3) not_one_less_zero)

  have "last path \<in> snd ` s"
    by (metis One_nat_def Suc_diff_Suc \<open>(path ! (length path - 2), path ! Suc (length path - 2)) \<in> s\<close> a1 image_iff last_conv_nth list.size(3) not_one_less_zero numeral_2_eq_2 snd_conv)

  from `hd path = last path` \<open>snd ` s \<inter> fst ` r = {}\<close>
  show "False"
    using \<open>hd path \<in> fst ` r\<close> \<open>last path \<in> snd ` s\<close>  by auto
qed

lemma acyclic_empty[simp]: "acyclic {}"
  by (simp add: wf_acyclic)

lemma acyclic_prod: "acyclic (A \<times> B) \<longleftrightarrow> A \<inter> B = {}"
  apply (auto simp add: acyclic_def)
  by (metis (no_types, lifting) SigmaD1 SigmaD2 disjoint_iff_not_equal tranclE)

lemma imp_assoc:
  shows "(a \<longrightarrow> (b \<longrightarrow> c)) \<longleftrightarrow> (b \<longrightarrow> (a \<longrightarrow> c))"
  by auto

lemma imp_assoc_elem:
  shows "(a \<longrightarrow> (x \<in> S \<longrightarrow> c)) \<longleftrightarrow> (x \<in> S \<longrightarrow> (a \<longrightarrow> c))"
  by auto

lemma rel_eqI:
  assumes lr: "\<And>x y. (x,y) \<in> A \<Longrightarrow> (x,y) \<in> B"
    and rl: "\<And>x y. (x,y) \<in> B \<Longrightarrow> (x,y) \<in> A"
  shows "A = B"
  using lr rl by auto

lemma min_nat_induct[case_names step[bound hyp]]:
  fixes P :: "nat \<Rightarrow> bool"
  assumes "\<And>i. \<lbrakk>i<bound; \<And>j. j < i \<Longrightarrow> P j  \<rbrakk> \<Longrightarrow> P i"
  shows "\<forall>i<bound. P i"
  by (metis assms dual_order.strict_trans infinite_descent0 nat_neq_iff not_less_zero)

lemma fix_smallest_induct:
  assumes "P x"
and step: "\<And>x (i::nat). \<lbrakk>P x; \<And>j. j<i \<Longrightarrow> Q x j; \<not>Q x i; i < bound\<rbrakk> \<Longrightarrow> \<exists>x'. (\<forall>j\<le>i. Q x' j) \<and> P x'"
shows "\<exists>x'. (\<forall>i<bound. Q x' i) \<and> P x'"
proof (rule ccontr)
  assume a: "\<nexists>x'. (\<forall>i<bound. Q x' i) \<and> P x'  "

  obtain i x_i
    where i1: "P x_i"
      and i2: "\<forall>j<i. Q x_i j"
      and i3: "\<not>Q x_i i"
    by (metis a `P x` nat_less_induct)

  define indexes where "indexes \<equiv> {i. \<exists>x_i. P x_i \<and> (\<forall>j<i. Q x_i j) \<and> \<not>Q x_i i }"

  have "\<exists>i_max. i_max \<in> indexes \<and> (\<forall>y\<in>indexes. (i_max, y) \<notin> {(x,y). x < y})"
  proof (rule exists_max)
    show "finite indexes"
    proof (rule finite_subset)
      show "indexes \<subseteq> {i. i\<le>bound}"
        apply (auto simp add: indexes_def)
        by (metis (no_types, lifting) a dual_order.strict_trans le_eq_less_or_eq less_SucI not_less_eq_eq)
      show "finite {i. i \<le> bound}" by force
    qed
    show "acyclicP ((<) :: nat \<Rightarrow> nat => bool)"
      by (simp add: wf_acyclic wf_less)

    show "i \<in> indexes"
      using i1 i2 i3 by (auto simp add: indexes_def )
  qed

  from this obtain i_max
    where "i_max \<in> indexes"
      and "(\<forall>y\<in>indexes. (i_max, y) \<notin> {(x,y). x < y})"
    by blast

  from this
  obtain  x_i_max
    where "P x_i_max"
      and "\<forall>j<i_max. Q x_i_max j"
      and "\<not>Q x_i_max i_max"
    by (auto simp add: indexes_def)

  from `(\<forall>y\<in>indexes. (i_max, y) \<notin> {(x,y). x < y})`
  have i_max_max: "\<forall>i'>i_max. \<forall>x'. \<not>(P x' \<and> (\<forall>j<i'. Q x' j) \<and> \<not>Q x' i')"
    by (auto simp add: indexes_def)

  have "\<exists>x'. (\<forall>j\<le>i_max. Q x' j) \<and> P x' "
    using `P x_i_max`
  proof (rule step)
    show "\<And>j. j < i_max \<Longrightarrow> Q x_i_max j"
      by (simp add: \<open>\<forall>j<i_max. Q x_i_max j\<close>)
    show "\<not> Q x_i_max i_max"
      by (simp add: \<open>\<not> Q x_i_max i_max\<close>)
    show "i_max < bound"
      by (metis \<open>P x_i_max\<close> \<open>\<forall>j<i_max. Q x_i_max j\<close> a dual_order.strict_trans linorder_neqE_nat)
  qed

  with i_max_max
  show False
    by (auto, smt a min_nat_induct not_le_imp_less)
qed

text "Case distinctions with different number of cases"

lemma cases_3[case_names case1 case2 case3]:
  assumes "A \<Longrightarrow> P"
    and "B \<Longrightarrow> P"
    and "\<not>A \<Longrightarrow> \<not>B \<Longrightarrow> P"
  shows "P"
  using assms by auto

lemma cases_4[case_names case1 case2 case3 case4]:
  assumes "A \<Longrightarrow> P"
    and "B \<Longrightarrow> P"
    and "C \<Longrightarrow> P"
    and "\<not>A \<Longrightarrow> \<not>B \<Longrightarrow> \<not>C \<Longrightarrow> P"
  shows "P"
  using assms by auto

lemma cases_5[case_names case1 case2 case3 case4 case5]:
  assumes "A \<Longrightarrow> P"
    and "B \<Longrightarrow> P"
    and "C \<Longrightarrow> P"
    and "D \<Longrightarrow> P"
    and "\<not>A \<Longrightarrow> \<not>B \<Longrightarrow> \<not>C \<Longrightarrow> \<not>D \<Longrightarrow> P"
  shows "P"
  using assms by auto

lemma iffToImp: "P \<longleftrightarrow> Q \<Longrightarrow> Q \<longrightarrow> P"
  by sat

subsection \<open>Sums over Maps\<close>

definition sum_map :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a\<times>'b \<Rightarrow> 'c::comm_monoid_add) \<Rightarrow> 'c" where
"sum_map m f \<equiv> sum (\<lambda>x. f (x, the (m x))) (dom m)"

syntax
  "_sum_map" :: "pttrn => 'a set => 'b => 'b"    ("(3\<Sum>_\<leftarrow>\<^sub>m_. _)" [0, 51, 10] 10)
translations \<comment> \<open>Beware of argument permutation!\<close>
  "\<Sum>x\<leftarrow>\<^sub>mS. b" == "CONST sum_map S (\<lambda>x. b)"

lemma sum_map_empty:
"(\<Sum>x\<leftarrow>\<^sub>mMap.empty. f x) = 0"
  by (auto simp add: sum_map_def)

lemma sum_map_insert:
  assumes "finite (dom m)"
and "x \<notin> dom m"
shows "(\<Sum>x\<leftarrow>\<^sub>m(m(x\<mapsto>y)). f x) = f (x,y) + (\<Sum>x\<leftarrow>\<^sub>mm. f x)"
  using assms by (auto simp add: sum_map_def, smt `x \<notin> dom m` sum.cong)

lemma sum_map_insert':
  assumes "finite (dom m)"
shows "(\<Sum>x\<leftarrow>\<^sub>m(m(x\<mapsto>y)). f x) = f (x,y) + (\<Sum>x\<leftarrow>\<^sub>m(m(x := None)). f x)"
  using assms by (auto simp add: sum_map_def)
   (smt DiffD2 option.sel singletonI sum.cong sum.insert_remove)

end


theory Incredible_Propositional imports
  Abstract_Rules_To_Incredible
  Propositional_Formulas
begin

text \<open>Our concrete interpretation with propositional logic will cover conjunction and implication
  as well as constant symbols. The type for variables will be @{typ string}.\<close>

datatype prop_funs = "and" | imp | Const "string"

text \<open>The rules are introduction and elimination of conjunction and implication.\<close>
datatype prop_rule = andI | andE | impI | impE

definition prop_rules :: "prop_rule stream"
  where "prop_rules = cycle [andI, andE, impI, impE]"

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

text \<open>Just some short notation.\<close>
abbreviation X :: "(string,'a) pform"
  where "X \<equiv> Var ''X''"
abbreviation Y :: "(string,'a) pform"
  where "Y \<equiv> Var ''Y''"

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

fun consequent :: "prop_rule \<Rightarrow> (string, prop_funs) pform list"
  where "consequent andI = [Fun and [X, Y]]"
  | "consequent andE = [X, Y]"
  | "consequent impI = [Fun imp [X, Y]]"
  | "consequent impE = [Y]"

fun antecedent :: "prop_rule \<Rightarrow> ((string,prop_funs) pform,string) antecedent list"
  where "antecedent andI = [plain_ant X, plain_ant Y]"
  | "antecedent andE = [plain_ant (Fun and [X, Y])]"
  | "antecedent impI = [Antecedent {|X|} Y {}]"
  | "antecedent impE = [plain_ant (Fun imp [X, Y]), plain_ant X]"

interpretation propositional: Abstract_Rules
  "curry (SOME f. bij f):: nat \<Rightarrow> string \<Rightarrow> string"
  "\<lambda>_. id"
  "\<lambda>_. {}"
  "closed :: (string, prop_funs) pform \<Rightarrow> bool"
  subst
  "\<lambda>_. {}"
  "\<lambda>_. id"
  "Var undefined"
  antecedent
  consequent
  prop_rules
proof
  show "\<forall>xs\<in>sset prop_rules. consequent xs \<noteq> []"
    unfolding prop_rules_def
    using consequent.elims by blast
next
  show "\<forall>xs\<in>sset prop_rules. \<Union>((\<lambda>_. {}) ` set (consequent xs)) = {}"
    by clarsimp
next
  fix i' r i ia
  assume "r \<in> sset prop_rules"
    and "ia < length (antecedent r)"
    and "i' < length (antecedent r)"
  then show "a_fresh (antecedent r ! ia) \<inter> a_fresh (antecedent r ! i') = {} \<or> ia = i'"
    by (cases i'; auto)
next
  fix p
  show "{} \<union> \<Union>((\<lambda>_. {}) ` fset (a_hyps p)) \<subseteq> a_fresh p"  by clarsimp
qed

end


(*  Title:      HOL/Cardinals/Fun_More.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

More on injections, bijections and inverses.
*)

section {* More on Injections, Bijections and Inverses *}

theory Fun_More
imports Main
begin

subsection {* Purely functional properties *}

(* unused *)
(*1*)lemma notIn_Un_bij_betw2:
assumes NIN: "b \<notin> A" and NIN': "b' \<notin> A'" and
        BIJ: "bij_betw f A A'"
shows "bij_betw f (A \<union> {b}) (A' \<union> {b'}) = (f b = b')"
proof
  assume "f b = b'"
  thus "bij_betw f (A \<union> {b}) (A' \<union> {b'})"
  using assms notIn_Un_bij_betw[of b A f A'] by auto
next
  assume *: "bij_betw f (A \<union> {b}) (A' \<union> {b'})"
  hence "f b \<in> A' \<union> {b'}"
  unfolding bij_betw_def by auto
  moreover
  {assume "f b \<in> A'"
   then obtain b1 where 1: "b1 \<in> A" and 2: "f b1 = f b" using BIJ
   by (auto simp add: bij_betw_def)
   hence "b = b1" using *
   by (auto simp add: bij_betw_def inj_on_def)
   with 1 NIN have False by auto
  }
  ultimately show "f b = b'" by blast
qed

(* unused *)
(*1*)lemma bij_betw_ball:
assumes BIJ: "bij_betw f A B"
shows "(\<forall>b \<in> B. phi b) = (\<forall>a \<in> A. phi(f a))"
using assms unfolding bij_betw_def inj_on_def by blast

(* unused *)
(*1*)lemma bij_betw_diff_singl:
assumes BIJ: "bij_betw f A A'" and IN: "a \<in> A"
shows "bij_betw f (A - {a}) (A' - {f a})"
proof-
  let ?B = "A - {a}"   let ?B' = "A' - {f a}"
  have "f a \<in> A'" using IN BIJ unfolding bij_betw_def by blast
  hence "a \<notin> ?B \<and> f a \<notin> ?B' \<and> A = ?B \<union> {a} \<and> A' = ?B' \<union> {f a}"
  using IN by blast
  thus ?thesis using notIn_Un_bij_betw3[of a ?B f ?B'] BIJ by simp
qed

subsection {* Properties involving finite and infinite sets *}

(*3*)lemma inj_on_image_Pow:
assumes "inj_on f A"
shows "inj_on (image f) (Pow A)"
unfolding Pow_def inj_on_def proof(clarsimp)
  fix X Y assume *: "X \<le> A" and **: "Y \<le> A" and
                 ***: "f ` X = f ` Y"
  show "X = Y"
  proof(auto)
    fix x assume ****: "x \<in> X"
    with *** obtain y where "y \<in> Y \<and> f x = f y" by blast
    with **** * ** assms show "x \<in> Y"
    unfolding inj_on_def by auto
  next
    fix y assume ****: "y \<in> Y"
    with *** obtain x where "x \<in> X \<and> f x = f y" by atomize_elim force
    with **** * ** assms show "y \<in> X"
    unfolding inj_on_def by auto
  qed
qed

(*2*)lemma bij_betw_image_Pow:
assumes "bij_betw f A B"
shows "bij_betw (image f) (Pow A) (Pow B)"
using assms unfolding bij_betw_def
by (auto simp add: inj_on_image_Pow image_Pow_surj)

(* unused *)
(*1*)lemma bij_betw_inv_into_RIGHT:
assumes BIJ: "bij_betw f A A'" and SUB: "B' \<le> A'"
shows "f `((inv_into A f)`B') = B'"
using assms
proof(auto simp add: bij_betw_inv_into_right)
  let ?f' = "(inv_into A f)"
  fix a' assume *: "a' \<in> B'"
  hence "a' \<in> A'" using SUB by auto
  hence "a' = f (?f' a')"
  using BIJ by (auto simp add: bij_betw_inv_into_right)
  thus "a' \<in> f ` (?f' ` B')" using * by blast
qed

(* unused *)
(*1*)lemma bij_betw_inv_into_RIGHT_LEFT:
assumes BIJ: "bij_betw f A A'" and SUB: "B' \<le> A'" and
        IM: "(inv_into A f) ` B' = B"
shows "f ` B = B'"
proof-
  have "f`((inv_into A f)` B') = B'"
  using assms bij_betw_inv_into_RIGHT[of f A A' B'] by auto
  thus ?thesis using IM by auto
qed

(* unused *)
(*2*)lemma bij_betw_inv_into_twice:
assumes "bij_betw f A A'"
shows "\<forall>a \<in> A. inv_into A' (inv_into A f) a = f a"
proof
  let ?f' = "inv_into A f"   let ?f'' = "inv_into A' ?f'"
  have 1: "bij_betw ?f' A' A" using assms
  by (auto simp add: bij_betw_inv_into)
  fix a assume *: "a \<in> A"
  then obtain a' where 2: "a' \<in> A'" and 3: "?f' a' = a"
  using 1 unfolding bij_betw_def by force
  hence "?f'' a = a'"
  using * 1 3 by (auto simp add: bij_betw_inv_into_left)
  moreover have "f a = a'" using assms 2 3
  by (auto simp add: bij_betw_inv_into_right)
  ultimately show "?f'' a = f a" by simp
qed

subsection {* Properties involving Hilbert choice *}

(*1*)lemma bij_betw_inv_into_LEFT:
assumes BIJ: "bij_betw f A A'" and SUB: "B \<le> A"
shows "(inv_into A f)`(f ` B) = B"
using assms unfolding bij_betw_def using inv_into_image_cancel by force

(*1*)lemma bij_betw_inv_into_LEFT_RIGHT:
assumes BIJ: "bij_betw f A A'" and SUB: "B \<le> A" and
        IM: "f ` B = B'"
shows "(inv_into A f) ` B' = B"
using assms bij_betw_inv_into_LEFT[of f A A' B] by fast

subsection {* Other facts *}

(*3*)lemma atLeastLessThan_injective:
assumes "{0 ..< m::nat} = {0 ..< n}"
shows "m = n"
proof-
  {assume "m < n"
   hence "m \<in> {0 ..< n}" by auto
   hence "{0 ..< m} < {0 ..< n}" by auto
   hence False using assms by blast
  }
  moreover
  {assume "n < m"
   hence "n \<in> {0 ..< m}" by auto
   hence "{0 ..< n} < {0 ..< m}" by auto
   hence False using assms by blast
  }
  ultimately show ?thesis by force
qed

(*2*)lemma atLeastLessThan_injective2:
"bij_betw f {0 ..< m::nat} {0 ..< n} \<Longrightarrow> m = n"
using finite_atLeastLessThan[of m] finite_atLeastLessThan[of n]
      card_atLeastLessThan[of m] card_atLeastLessThan[of n]
      bij_betw_iff_card[of "{0 ..< m}" "{0 ..< n}"] by auto

(*2*)lemma atLeastLessThan_less_eq:
"({0..<m} \<le> {0..<n}) = ((m::nat) \<le> n)"
unfolding ivl_subset by arith

(*2*)lemma atLeastLessThan_less_eq2:
assumes "inj_on f {0..<(m::nat)} \<and> f ` {0..<m} \<le> {0..<n}"
shows "m \<le> n"
using assms
using finite_atLeastLessThan[of m] finite_atLeastLessThan[of n]
      card_atLeastLessThan[of m] card_atLeastLessThan[of n]
      card_inj_on_le[of f "{0 ..< m}" "{0 ..< n}"] by fastforce

(* unused *)
(*2*)lemma atLeastLessThan_less_eq3:
"(\<exists>f. inj_on f {0..<(m::nat)} \<and> f ` {0..<m} \<le> {0..<n}) = (m \<le> n)"
using atLeastLessThan_less_eq2
proof(auto)
  assume "m \<le> n"
  hence "inj_on id {0..<m} \<and> id ` {0..<m} \<subseteq> {0..<n}" unfolding inj_on_def by force
  thus "\<exists>f. inj_on f {0..<m} \<and> f ` {0..<m} \<subseteq> {0..<n}" by blast
qed

(* unused *)
(*3*)lemma atLeastLessThan_less:
"({0..<m} < {0..<n}) = ((m::nat) < n)"
proof-
  have "({0..<m} < {0..<n}) = ({0..<m} \<le> {0..<n} \<and> {0..<m} ~= {0..<n})"
  using subset_iff_psubset_eq by blast
  also have "\<dots> = (m \<le> n \<and> m ~= n)"
  using atLeastLessThan_less_eq atLeastLessThan_injective by blast
  also have "\<dots> = (m < n)" by auto
  finally show ?thesis .
qed

end


(*  Title:      HOL/Hoare/ExamplesAbort.thy
    Author:     Tobias Nipkow
    Copyright   1998 TUM
*)

section \<open>Some small examples for programs that may abort\<close>

theory ExamplesAbort
  imports Hoare_Logic_Abort
begin

lemma "VARS x y z::nat
 {y = z & z \<noteq> 0} z \<noteq> 0 \<rightarrow> x := y div z {x = 1}"
by vcg_simp

lemma
 "VARS a i j
 {k <= length a & i < k & j < k} j < length a \<rightarrow> a[i] := a!j {True}"
by vcg_simp

lemma "VARS (a::int list) i
 {True}
 i := 0;
 WHILE i < length a
 INV {i <= length a}
 DO a[i] := 7; i := i+1 OD
 {True}"
by vcg_simp

end


(*<*)
theory LTL
imports
  CIMP_pred
  Infinite_Sequences
begin

(*>*)
section\<open> Linear Temporal Logic \label{sec:ltl}\<close>

text\<open>

To talk about liveness we need to consider infinitary behaviour on
sequences. Traditionally future-time linear temporal logic (LTL) is used to do
this @{cite "MannaPnueli:1991" and "OwickiLamport:1982"}.

The following is a straightforward shallow embedding of the
now-traditional anchored semantics of LTL @{cite "MannaPnueli:1988"}. Some of it is adapted
from the sophisticated TLA development in the AFP due to @{cite [cite_macro=citet] "TLA-AFP"}.

Unlike @{cite [cite_macro=citet] "Lamport:2002"}, include the
next operator, which is convenient for stating rules. Sometimes it allows us to
ignore the system, i.e. to state rules as temporally valid
(LTL-valid) rather than just temporally program valid (LTL-cimp-), in Jackson's terminology.

\<close>

definition state_prop :: "('a \<Rightarrow> bool) \<Rightarrow> 'a seq_pred" ("\<lceil>_\<rceil>") where
  "\<lceil>P\<rceil> = (\<lambda>\<sigma>. P (\<sigma> 0))"

definition "next" :: "'a seq_pred \<Rightarrow> 'a seq_pred" ("\<circle>_" [80] 80) where
  "(\<circle>P) = (\<lambda>\<sigma>. P (\<sigma> |\<^sub>s 1))"

definition always :: "'a seq_pred \<Rightarrow> 'a seq_pred" ("\<box>_" [80] 80) where
  "(\<box>P) = (\<lambda>\<sigma>. \<forall>i. P (\<sigma> |\<^sub>s i))"

definition until :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" (infixr "\<U>" 30) where (* FIXME priority, binds tighter than \<^bold>\<longrightarrow> *)
  "(P \<U> Q) = (\<lambda>\<sigma>. \<exists>i. Q (\<sigma> |\<^sub>s i) \<and> (\<forall>k<i. P (\<sigma> |\<^sub>s k)))"

definition eventually :: "'a seq_pred \<Rightarrow> 'a seq_pred" ("\<diamond>_" [80] 80) where (* FIXME priority, consider making an abbreviation *)
  "(\<diamond>P) = (\<langle>True\<rangle> \<U> P)"

definition release :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" (infixr "\<R>" 30) where (* FIXME priority, dual of Until *)
  "(P \<R> Q) = (\<^bold>\<not>(\<^bold>\<not>P \<U> \<^bold>\<not>Q))"

definition unless :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" (infixr "\<W>" 30) where (* FIXME priority, aka weak until *)
  "(P \<W> Q) = ((P \<U> Q) \<^bold>\<or> \<box>P)"

abbreviation (input)
  pred_always_imp_syn :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" (infixr "\<^bold>\<hookrightarrow>" 25) where
  "P \<^bold>\<hookrightarrow> Q \<equiv> \<box>(P \<^bold>\<longrightarrow> Q)"

lemmas defs =
  state_prop_def
  always_def
  eventually_def
  next_def
  release_def
  unless_def
  until_def

lemma suffix_state_prop[simp]:
  shows "\<lceil>P\<rceil> (\<sigma> |\<^sub>s i) = P (\<sigma> i)"
unfolding defs by simp

lemma alwaysI[intro]:
  assumes "\<And>i. P (\<sigma> |\<^sub>s i)"
  shows "(\<box>P) \<sigma>"
unfolding defs using assms by blast

lemma alwaysD:
  assumes "(\<box>P) \<sigma>"
  shows "P (\<sigma> |\<^sub>s i)"
using assms unfolding defs by blast

lemma alwaysE: "\<lbrakk>(\<box>P) \<sigma>; P (\<sigma> |\<^sub>s i) \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
unfolding defs by blast

lemma always_induct:
  assumes "P \<sigma>"
  assumes "(\<box>(P \<^bold>\<longrightarrow> \<circle>P)) \<sigma>"
  shows "(\<box>P) \<sigma>"
proof(rule alwaysI)
  fix i from assms show "P (\<sigma> |\<^sub>s i)"
    unfolding defs by (induct i) simp_all
qed

lemma seq_comp:
  fixes \<sigma> :: "'a seq"
  fixes P :: "'b seq_pred"
  fixes f :: "'a \<Rightarrow> 'b"
  shows
    "(\<box>P) (f \<circ> \<sigma>) \<longleftrightarrow> (\<box>(\<lambda>\<sigma>. P (f \<circ> \<sigma>))) \<sigma>"
    "(\<diamond>P) (f \<circ> \<sigma>) \<longleftrightarrow> (\<diamond>(\<lambda>\<sigma>. P (f \<circ> \<sigma>))) \<sigma>"
    "(P \<U> Q) (f \<circ> \<sigma>) \<longleftrightarrow> ((\<lambda>\<sigma>. P (f \<circ> \<sigma>)) \<U> (\<lambda>\<sigma>. Q (f \<circ> \<sigma>))) \<sigma>"
    "(P \<W> Q) (f \<circ> \<sigma>) \<longleftrightarrow> ((\<lambda>\<sigma>. P (f \<circ> \<sigma>)) \<W> (\<lambda>\<sigma>. Q (f \<circ> \<sigma>))) \<sigma>"
unfolding defs by simp_all

lemma nextI[intro]:
  assumes "P (\<sigma> |\<^sub>s Suc 0)"
  shows "(\<circle>P) \<sigma>"
using assms unfolding defs by simp

lemma untilE:
  assumes "(P \<U> Q) \<sigma>"
  obtains i where "Q (\<sigma> |\<^sub>s i)" and "\<forall>k<i. P (\<sigma> |\<^sub>s k)"
using assms unfolding until_def by blast

lemma eventuallyI[intro]:
  assumes "P (\<sigma> |\<^sub>s i)"
  shows "(\<diamond>P) \<sigma>"
unfolding eventually_def using assms by blast

lemma eventuallyE[elim]:
  assumes "(\<diamond>P) \<sigma>"
  obtains i where "P (\<sigma> |\<^sub>s i)"
using assms unfolding defs by (blast elim: untilE)

lemma unless_alwaysI:
  assumes "(\<box> P) \<sigma>"
  shows "(P \<W> Q) \<sigma>"
using assms unfolding defs by blast

lemma unless_untilI:
  assumes "Q (\<sigma> |\<^sub>s j)"
  assumes "\<And>i. i < j \<Longrightarrow> P (\<sigma> |\<^sub>s i)"
  shows "(P \<W> Q) \<sigma>"
unfolding defs using assms by blast

lemma always_imp_refl[iff]:
  shows "(P \<^bold>\<hookrightarrow> P) \<sigma>"
unfolding defs by blast

lemma always_imp_trans:
  assumes "(P \<^bold>\<hookrightarrow> Q) \<sigma>"
  assumes "(Q \<^bold>\<hookrightarrow> R) \<sigma>"
  shows "(P \<^bold>\<hookrightarrow> R) \<sigma>"
using assms unfolding defs by blast

lemma always_imp_mp:
  assumes "(P \<^bold>\<hookrightarrow> Q) \<sigma>"
  assumes "P \<sigma>"
  shows "Q \<sigma>"
using assms unfolding defs by (metis suffix_zero)

lemma always_imp_mp_suffix:
  assumes "(P \<^bold>\<hookrightarrow> Q) \<sigma>"
  assumes "P (\<sigma> |\<^sub>s i)"
  shows "Q (\<sigma> |\<^sub>s i)"
using assms unfolding defs by metis

text\<open>

Some basic facts and equivalences, mostly sanity.

\<close>

lemma necessitation:
  "(\<And>s. P s) \<Longrightarrow> (\<box>P) \<sigma>"
  "(\<And>s. P s) \<Longrightarrow> (\<diamond>P) \<sigma>"
  "(\<And>s. P s) \<Longrightarrow> (P \<W> Q) \<sigma>"
  "(\<And>s. Q s) \<Longrightarrow> (P \<U> Q) \<sigma>"
unfolding defs by auto

lemma cong:
  "(\<And>s. P s = P' s) \<Longrightarrow> \<lceil>P\<rceil> = \<lceil>P'\<rceil>"
  "(\<And>\<sigma>. P \<sigma> = P' \<sigma>) \<Longrightarrow> (\<box>P) = (\<box>P')"
  "(\<And>\<sigma>. P \<sigma> = P' \<sigma>) \<Longrightarrow> (\<diamond>P) = (\<diamond>P')"
  "(\<And>\<sigma>. P \<sigma> = P' \<sigma>) \<Longrightarrow> (\<circle>P) = (\<circle>P')"
  "\<lbrakk>\<And>\<sigma>. P \<sigma> = P' \<sigma>; \<And>\<sigma>. Q \<sigma> = Q' \<sigma>\<rbrakk> \<Longrightarrow> (P \<U> Q) = (P' \<U> Q')"
  "\<lbrakk>\<And>\<sigma>. P \<sigma> = P' \<sigma>; \<And>\<sigma>. Q \<sigma> = Q' \<sigma>\<rbrakk> \<Longrightarrow> (P \<W> Q) = (P' \<W> Q')"
unfolding defs by auto

lemma norm[simp]:
  "\<lceil>\<langle>False\<rangle>\<rceil> = \<langle>False\<rangle>"
  "\<lceil>\<langle>True\<rangle>\<rceil> = \<langle>True\<rangle>"
  "(\<^bold>\<not>\<lceil>p\<rceil>) = \<lceil>\<^bold>\<not>p\<rceil>"
  "(\<lceil>p\<rceil> \<^bold>\<and> \<lceil>q\<rceil>) = \<lceil>p \<^bold>\<and> q\<rceil>"
  "(\<lceil>p\<rceil> \<^bold>\<or> \<lceil>q\<rceil>) = \<lceil>p \<^bold>\<or> q\<rceil>"
  "(\<lceil>p\<rceil> \<^bold>\<longrightarrow> \<lceil>q\<rceil>) = \<lceil>p \<^bold>\<longrightarrow> q\<rceil>"
  "(\<lceil>p\<rceil> \<sigma> \<and> \<lceil>q\<rceil> \<sigma>) = \<lceil>p \<^bold>\<and> q\<rceil> \<sigma>"
  "(\<lceil>p\<rceil> \<sigma> \<or> \<lceil>q\<rceil> \<sigma>) = \<lceil>p \<^bold>\<or> q\<rceil> \<sigma>"
  "(\<lceil>p\<rceil> \<sigma> \<longrightarrow> \<lceil>q\<rceil> \<sigma>) = \<lceil>p \<^bold>\<longrightarrow> q\<rceil> \<sigma>"

  "(\<circle>\<langle>False\<rangle>) = \<langle>False\<rangle>"
  "(\<circle>\<langle>True\<rangle>) = \<langle>True\<rangle>"

  "(\<box>\<langle>False\<rangle>) = \<langle>False\<rangle>"
  "(\<box>\<langle>True\<rangle>) = \<langle>True\<rangle>"
  "(\<^bold>\<not>\<box> P) \<sigma> = (\<diamond> (\<^bold>\<not> P)) \<sigma>"
  "(\<box>\<box> P) = (\<box> P)"

  "(\<diamond>\<langle>False\<rangle>) = \<langle>False\<rangle>"
  "(\<diamond>\<langle>True\<rangle>) = \<langle>True\<rangle>"
  "(\<^bold>\<not>\<diamond> P) = (\<box> (\<^bold>\<not> P))"
  "(\<diamond>\<diamond> P) = (\<diamond> P)"

  "(P \<W> \<langle>False\<rangle>) = (\<box> P)"

  "(\<^bold>\<not>(P \<U> Q)) \<sigma> = (\<^bold>\<not>P \<R> \<^bold>\<not>Q) \<sigma>"
  "(\<langle>False\<rangle> \<U> P) = P"
  "(P \<U> \<langle>False\<rangle>) = \<langle>False\<rangle>"
  "(P \<U> \<langle>True\<rangle>) = \<langle>True\<rangle>"
  "(\<langle>True\<rangle> \<U> P) = (\<diamond> P)"
  "(P \<U> (P \<U> Q)) = (P \<U> Q)"

  "(\<^bold>\<not>(P \<R> Q)) \<sigma> = (\<^bold>\<not>P \<U> \<^bold>\<not>Q) \<sigma>"
  "(\<langle>False\<rangle> \<R> P) = (\<box>P)"
  "(P \<R> \<langle>False\<rangle>) = \<langle>False\<rangle>"
  "(\<langle>True\<rangle> \<R> P) = P"
  "(P \<R> \<langle>True\<rangle>) = \<langle>True\<rangle>"
(*
  "(P \<U> (P \<U> Q)) \<sigma> = (P \<U> Q) \<sigma>" FIXME for Release
*)
unfolding defs
apply (auto simp: fun_eq_iff)
apply (metis suffix_plus suffix_zero)
apply (metis suffix_plus suffix_zero)
  apply fastforce
  apply force
apply (metis add.commute add_diff_inverse_nat less_diff_conv2 not_le)
apply (metis add.right_neutral not_less0)
  apply force
  apply fastforce
done

lemma always_conj_distrib: "(\<box>(P \<^bold>\<and> Q)) = (\<box>P \<^bold>\<and> \<box>Q)"
unfolding defs by auto

lemma eventually_disj_distrib: "(\<diamond>(P \<^bold>\<or> Q)) = (\<diamond>P \<^bold>\<or> \<diamond>Q)"
unfolding defs by auto

lemma always_eventually[elim!]:
  assumes "(\<box>P) \<sigma>"
  shows "(\<diamond>P) \<sigma>"
using assms unfolding defs by auto

lemma eventually_imp_conv_disj: "(\<diamond>(P \<^bold>\<longrightarrow> Q)) = (\<diamond>(\<^bold>\<not>P) \<^bold>\<or> \<diamond>Q)"
unfolding defs by auto

lemma eventually_imp_distrib:
  "(\<diamond>(P \<^bold>\<longrightarrow> Q)) = (\<box>P \<^bold>\<longrightarrow> \<diamond>Q)"
unfolding defs by auto

lemma unfold:
  "(\<box> P) \<sigma> = (P \<^bold>\<and> \<circle>\<box>P) \<sigma>"
  "(\<diamond> P) \<sigma> = (P \<^bold>\<or> \<circle>\<diamond>P) \<sigma>"
  "(P \<W> Q) \<sigma> = (Q \<^bold>\<or> (P \<^bold>\<and> \<circle>(P \<W> Q))) \<sigma>"
  "(P \<U> Q) \<sigma> = (Q \<^bold>\<or> (P \<^bold>\<and> \<circle>(P \<U> Q))) \<sigma>"
  "(P \<R> Q) \<sigma> = (Q \<^bold>\<and> (P \<^bold>\<or> \<circle>(P \<R> Q))) \<sigma>"
unfolding defs
apply -
apply (metis (full_types) add.commute add_diff_inverse_nat less_one suffix_plus suffix_zero)
apply (metis (full_types) One_nat_def add.right_neutral add_Suc_right lessI less_Suc_eq_0_disj suffix_plus suffix_zero)

apply auto
  apply fastforce
  apply (metis gr0_conv_Suc nat_neq_iff not_less_eq suffix_zero)
  apply (metis suffix_zero)
  apply force
  using less_Suc_eq_0_disj apply fastforce
  apply (metis gr0_conv_Suc nat_neq_iff not_less0 suffix_zero)

  apply fastforce
  apply (case_tac i; auto)
  apply force
  using less_Suc_eq_0_disj apply force

  apply force
  using less_Suc_eq_0_disj apply fastforce
  apply fastforce
  apply (case_tac i; auto)
done

lemma mono:
  "\<lbrakk>(\<box>P) \<sigma>; \<And>\<sigma>. P \<sigma> \<Longrightarrow>  P' \<sigma>\<rbrakk> \<Longrightarrow> (\<box>P') \<sigma>"
  "\<lbrakk>(\<diamond>P) \<sigma>; \<And>\<sigma>. P \<sigma> \<Longrightarrow>  P' \<sigma>\<rbrakk> \<Longrightarrow> (\<diamond>P') \<sigma>"
  "\<lbrakk>(P \<U> Q) \<sigma>; \<And>\<sigma>. P \<sigma> \<Longrightarrow> P' \<sigma>; \<And>\<sigma>. Q \<sigma> \<Longrightarrow> Q' \<sigma>\<rbrakk> \<Longrightarrow> (P' \<U> Q') \<sigma>"
  "\<lbrakk>(P \<W> Q) \<sigma>; \<And>\<sigma>. P \<sigma> \<Longrightarrow> P' \<sigma>; \<And>\<sigma>. Q \<sigma> \<Longrightarrow> Q' \<sigma>\<rbrakk> \<Longrightarrow> (P' \<W> Q') \<sigma>"
unfolding defs by force+

lemma always_imp_mono:
  "\<lbrakk>(\<box>P) \<sigma>; (P \<^bold>\<hookrightarrow> P') \<sigma>\<rbrakk> \<Longrightarrow> (\<box>P') \<sigma>"
  "\<lbrakk>(\<diamond>P) \<sigma>; (P \<^bold>\<hookrightarrow> P') \<sigma>\<rbrakk> \<Longrightarrow> (\<diamond>P') \<sigma>"
  "\<lbrakk>(P \<U> Q) \<sigma>; (P \<^bold>\<hookrightarrow> P') \<sigma>; (Q \<^bold>\<hookrightarrow> Q') \<sigma>\<rbrakk> \<Longrightarrow> (P' \<U> Q') \<sigma>"
  "\<lbrakk>(P \<W> Q) \<sigma>; (P \<^bold>\<hookrightarrow> P') \<sigma>; (Q \<^bold>\<hookrightarrow> Q') \<sigma>\<rbrakk> \<Longrightarrow> (P' \<W> Q') \<sigma>"
unfolding defs by force+

lemma next_conj_distrib:
  "(\<circle>(P \<^bold>\<and> Q)) = (\<circle>P \<^bold>\<and> \<circle>Q)"
unfolding defs by auto

lemma next_disj_distrib:
  "(\<circle>(P \<^bold>\<or> Q)) = (\<circle>P \<^bold>\<or> \<circle>Q)"
unfolding defs by auto

lemma until_next_distrib:
  "(\<circle>(P \<U> Q)) = (\<circle>P \<U> \<circle>Q)"
unfolding defs by (auto simp: fun_eq_iff)

lemma until_imp_eventually:
  "((P \<U> Q) \<^bold>\<longrightarrow> \<diamond>Q) \<sigma>"
unfolding defs by auto

lemma until_until_disj:
  assumes "(P \<U> Q \<U> R) \<sigma>"
  shows "((P \<^bold>\<or> Q) \<U> R) \<sigma>"
using assms unfolding defs
apply clarsimp
apply (metis (full_types) add_diff_inverse_nat nat_add_left_cancel_less)
done

lemma unless_unless_disj:
  assumes "(P \<W> Q \<W> R) \<sigma>"
  shows "((P \<^bold>\<or> Q) \<W> R) \<sigma>"
using assms unfolding defs
apply auto
 apply (metis add.commute add_diff_inverse_nat leI less_diff_conv2)
apply (metis add_diff_inverse_nat)
done

lemma until_conj_distrib:
  "((P \<^bold>\<and> Q) \<U> R) = ((P \<U> R) \<^bold>\<and> (Q \<U> R))"
unfolding defs
apply (auto simp: fun_eq_iff)
apply (metis dual_order.strict_trans nat_neq_iff)
done

lemma until_disj_distrib:
  "(P \<U> (Q \<^bold>\<or> R)) = ((P \<U> Q) \<^bold>\<or> (P \<U> R))"
unfolding defs by (auto simp: fun_eq_iff)

lemma eventually_until:
  "(\<diamond>P) = (\<^bold>\<not>P \<U> P)"
unfolding defs
apply (auto simp: fun_eq_iff)
apply (case_tac "P (x |\<^sub>s 0)")
 apply blast
apply (drule (1) ex_least_nat_less)
apply (metis le_simps(2))
done

lemma eventually_until_eventually:
  "(\<diamond>(P \<U> Q)) = (\<diamond>Q)"
unfolding defs by force

lemma eventually_unless_until:
  "((P \<W> Q) \<^bold>\<and> \<diamond>Q) = (P \<U> Q)"
unfolding defs by force

lemma eventually_always_imp_always_eventually:
  assumes "(\<diamond>\<box>P) \<sigma>"
  shows "(\<box>\<diamond>P) \<sigma>"
using assms unfolding defs by (metis suffix_commute)

lemma eventually_always_next_stable:
  assumes "(\<diamond>P) \<sigma>"
  assumes "(P \<^bold>\<hookrightarrow> \<circle>P) \<sigma>"
  shows "(\<diamond>\<box>P) \<sigma>"
using assms by (metis (no_types) eventuallyI alwaysD always_induct eventuallyE norm(15))

lemma next_stable_imp_eventually_always:
  assumes "(P \<^bold>\<hookrightarrow> \<circle>P) \<sigma>"
  shows "(\<diamond>P \<^bold>\<longrightarrow> \<diamond>\<box>P) \<sigma>"
using assms eventually_always_next_stable by blast

lemma always_eventually_always:
  "\<diamond>\<box>\<diamond>P = \<box>\<diamond>P"
unfolding defs by (clarsimp simp: fun_eq_iff) (metis add.left_commute semiring_normalization_rules(25))

(* FIXME define "stable", develop more rules for it *)
lemma stable_unless:
  assumes "(P \<^bold>\<hookrightarrow> \<circle>(P \<^bold>\<or> Q)) \<sigma>"
  shows "(P \<^bold>\<hookrightarrow> (P \<W> Q)) \<sigma>"
using assms unfolding defs
apply -
apply (rule ccontr)
apply clarsimp
apply (drule (1) ex_least_nat_less[where P="\<lambda>j. \<not>P (\<sigma> |\<^sub>s i + j)" for i, simplified])
apply clarsimp
apply (metis add_Suc_right le_less less_Suc_eq)
done

lemma unless_induct: \<comment>\<open> Rule \texttt{WAIT} from @{cite [cite_macro=citet] \<open>Fig~3.3\<close> "MannaPnueli:1995"}\<close>
  assumes I: "(I \<^bold>\<hookrightarrow> \<circle>(I \<^bold>\<or> R)) \<sigma>"
  assumes P: "(P \<^bold>\<hookrightarrow> I \<^bold>\<or> R) \<sigma>"
  assumes Q: "(I \<^bold>\<hookrightarrow> Q) \<sigma>"
  shows "(P \<^bold>\<hookrightarrow> Q \<W> R) \<sigma>"
apply (intro alwaysI impI)
apply (erule impE[OF alwaysD[OF P]])
apply (erule disjE)
 apply (rule always_imp_mono(4)[where P=I and Q=R])
   apply (erule mp[OF alwaysD[OF stable_unless[OF I]]])
  apply (simp add: Q alwaysD)
 apply blast
apply (simp add: unfold)
done

subsection\<open> Leads-to and leads-to-via \label{sec:leads-to} \<close>

text\<open>

Most of our assertions will be of the form @{term "A \<^bold>\<longrightarrow> \<diamond>C"} (pronounced ``\<open>A\<close> leads to \<open>C\<close>'')
or @{term "A \<^bold>\<longrightarrow> B \<U> C"} (``\<open>A\<close> leads to \<open>C\<close> via \<open>B\<close>'').

Most of these rules are due to @{cite [cite_macro=citet]
"Jackson:1998"} who used leads-to-via in a sequential setting. Others
are due to @{cite [cite_macro=citet] "MannaPnueli:1991"}.

The leads-to-via connective is similar to the ``ensures'' modality of @{cite [cite_macro=citet] \<open>\S3.4.4\<close> "ChandyMisra:1989"}.

\<close>

abbreviation (input)
  leads_to :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" (infixr "\<^bold>\<leadsto>" 25) where (* FIXME priority *)
  "P \<^bold>\<leadsto> Q \<equiv> P \<^bold>\<hookrightarrow> \<diamond>Q"

lemma leads_to_refl:
  shows "(P \<^bold>\<leadsto> P) \<sigma>"
by (metis (no_types, lifting) necessitation(1) unfold(2))

lemma leads_to_trans:
  assumes "(P \<^bold>\<leadsto> Q) \<sigma>"
  assumes "(Q \<^bold>\<leadsto> R) \<sigma>"
  shows "(P \<^bold>\<leadsto> R) \<sigma>"
using assms unfolding defs by clarsimp (metis semiring_normalization_rules(25))

lemma leads_to_eventuallyE:
  assumes "(P \<^bold>\<leadsto> Q) \<sigma>"
  assumes "(\<diamond>P) \<sigma>"
  shows "(\<diamond>Q) \<sigma>"
using assms unfolding defs by auto

lemma leads_to_mono:
  assumes "(P' \<^bold>\<hookrightarrow> P) \<sigma>"
  assumes "(Q \<^bold>\<hookrightarrow> Q') \<sigma>"
  assumes "(P \<^bold>\<leadsto> Q) \<sigma>"
  shows "(P' \<^bold>\<leadsto> Q') \<sigma>"
using assms unfolding defs by clarsimp blast

lemma leads_to_eventually:
  shows "(P \<^bold>\<leadsto> Q \<^bold>\<longrightarrow> \<diamond>P \<^bold>\<longrightarrow> \<diamond>Q) \<sigma>"
by (metis (no_types, lifting) alwaysI unfold(2))

lemma leads_to_disj:
  assumes "(P \<^bold>\<leadsto> R) \<sigma>"
  assumes "(Q \<^bold>\<leadsto> R) \<sigma>"
  shows "((P \<^bold>\<or> Q) \<^bold>\<leadsto> R) \<sigma>"
using assms unfolding defs by simp

lemma leads_to_leads_to_viaE:
  shows "((P \<^bold>\<hookrightarrow> P \<U> Q) \<^bold>\<longrightarrow> P \<^bold>\<leadsto> Q) \<sigma>"
unfolding defs by clarsimp blast

lemma leads_to_via_concl_weaken:
  assumes "(R \<^bold>\<hookrightarrow> R') \<sigma>"
  assumes "(P \<^bold>\<hookrightarrow> Q \<U> R) \<sigma>"
  shows "(P \<^bold>\<hookrightarrow> Q \<U> R') \<sigma>"
using assms unfolding LTL.defs by force

lemma leads_to_via_trans:
  assumes "(A \<^bold>\<hookrightarrow> B \<U> C) \<sigma>"
  assumes "(C \<^bold>\<hookrightarrow> D \<U> E) \<sigma>"
  shows "(A \<^bold>\<hookrightarrow> (B \<^bold>\<or> D) \<U> E) \<sigma>"
proof(rule alwaysI, rule impI)
  fix i assume "A (\<sigma> |\<^sub>s i)" with assms show "((B \<^bold>\<or> D) \<U> E) (\<sigma> |\<^sub>s i)"
    apply -
    apply (erule alwaysE[where i=i])
    apply clarsimp
    apply (erule untilE)
    apply clarsimp (* suffix *)
    apply (drule (1) always_imp_mp_suffix)
    apply (erule untilE)
    apply clarsimp (* suffix *)
    apply (rule_tac i="ia + iaa" in untilI; simp add: ac_simps)
    apply (metis (full_types) add.assoc leI le_Suc_ex nat_add_left_cancel_less) (* arithmetic *)
    done
qed

lemma leads_to_via_disj: \<comment> \<open> useful for case distinctions \<close>
  assumes "(P \<^bold>\<hookrightarrow> Q \<U> R) \<sigma>"
  assumes "(P' \<^bold>\<hookrightarrow> Q' \<U> R) \<sigma>"
  shows "(P \<^bold>\<or> P' \<^bold>\<hookrightarrow> (Q \<^bold>\<or> Q') \<U> R) \<sigma>"
using assms unfolding defs by (auto 10 0)

lemma leads_to_via_disj': \<comment> \<open> more like a chaining rule \<close>
  assumes "(A \<^bold>\<hookrightarrow> B \<U> C) \<sigma>"
  assumes "(C \<^bold>\<hookrightarrow> D \<U> E) \<sigma>"
  shows "(A \<^bold>\<or> C \<^bold>\<hookrightarrow> (B \<^bold>\<or> D) \<U> E) \<sigma>"
proof(rule alwaysI, rule impI, erule disjE)
  fix i assume "A (\<sigma> |\<^sub>s i)" with assms show "((B \<^bold>\<or> D) \<U> E) (\<sigma> |\<^sub>s i)"
    apply -
    apply (erule alwaysE[where i=i])
    apply clarsimp
    apply (erule untilE)
    apply clarsimp (* suffix *)
    apply (drule (1) always_imp_mp_suffix)
    apply (erule untilE)
    apply clarsimp (* suffix *)
    apply (rule_tac i="ia + iaa" in untilI; simp add: ac_simps)
    apply (metis (full_types) add.assoc leI le_Suc_ex nat_add_left_cancel_less) (* arithmetic *)
    done
next
  fix i assume "C (\<sigma> |\<^sub>s i)" with assms(2) show "((B \<^bold>\<or> D) \<U> E) (\<sigma> |\<^sub>s i)"
    apply -
    apply (erule alwaysE[where i=i])
    apply (simp add: mono)
    done
qed

lemma leads_to_via_stable_augmentation:
  assumes stable: "(P \<^bold>\<and> Q \<^bold>\<hookrightarrow> \<circle>Q) \<sigma>"
  assumes U: "(A \<^bold>\<hookrightarrow> P \<U> C) \<sigma>"
  shows "((A \<^bold>\<and> Q) \<^bold>\<hookrightarrow> P \<U> (C \<^bold>\<and> Q)) \<sigma>"
proof(intro alwaysI impI, elim conjE)
  fix i assume AP: "A (\<sigma> |\<^sub>s i)" "Q (\<sigma> |\<^sub>s i)"
  have "Q (\<sigma> |\<^sub>s (j + i))" if "Q (\<sigma> |\<^sub>s i)" and "\<forall>k<j. P (\<sigma> |\<^sub>s (k + i))" for j
    using that stable by (induct j; force simp: defs)
  with U AP show "(P \<U> (\<lambda>\<sigma>. C \<sigma> \<and> Q \<sigma>)) (\<sigma> |\<^sub>s i)"
    unfolding defs by clarsimp (metis (full_types) add.commute)
qed

lemma leads_to_via_wf:
  assumes "wf R"
  assumes indhyp: "\<And>t. (A \<^bold>\<and> \<lceil>\<delta> \<^bold>= \<langle>t\<rangle>\<rceil> \<^bold>\<hookrightarrow> B \<U> (A \<^bold>\<and> \<lceil>\<delta> \<^bold>\<otimes> \<langle>t\<rangle> \<^bold>\<in> \<langle>R\<rangle>\<rceil> \<^bold>\<or> C)) \<sigma>"
  shows "(A \<^bold>\<hookrightarrow> B \<U> C) \<sigma>"
proof(intro alwaysI impI)
  fix i assume "A (\<sigma> |\<^sub>s i)" with \<open>wf R\<close> show "(B \<U> C) (\<sigma> |\<^sub>s i)"
  proof(induct "\<delta> (\<sigma> i)" arbitrary: i)
    case (less i) with indhyp[where t="\<delta> (\<sigma> i)"] show ?case
      apply -
      apply (drule alwaysD[where i=i])
      apply clarsimp
      apply (erule untilE)
      apply (rename_tac j)
       apply (erule disjE; clarsimp)
       apply (drule_tac x="i + j" in meta_spec; clarsimp)
       apply (erule untilE; clarsimp)
       apply (rename_tac j k)
       apply (rule_tac i="j + k" in untilI)
        apply (simp add: add.assoc)
       apply clarsimp
       apply (metis add.assoc add.commute add_diff_inverse_nat less_diff_conv2 not_le)
      apply auto
      done
  qed
qed

text\<open>

The well-founded response rule due to @{cite [cite_macro=citet] \<open>Fig~1.23: \texttt{WELL} (well-founded response)\<close>"MannaPnueli:2010"},
generalised to an arbitrary set of assertions and sequence predicates.
\<^item> \<open>W1\<close> generalised to be contingent.
\<^item> \<open>W2\<close> is a well-founded set of assertions that by \<open>W1\<close> includes \<open>P\<close>

\<close>

(* FIXME: Does \<open>Is\<close> need to be consistent? *)
lemma leads_to_wf:
  fixes Is :: "('a seq_pred \<times> ('a \<Rightarrow> 'b)) set"
  assumes "wf (R :: 'b rel)"
  assumes W1: "(\<box>(\<^bold>\<exists>\<phi>. \<lceil>\<langle>\<phi>\<in>fst ` Is\<rangle>\<rceil> \<^bold>\<and> (P \<^bold>\<longrightarrow> \<phi>))) \<sigma>"
  assumes W2: "\<forall>(\<phi>, \<delta>)\<in>Is. \<exists>(\<phi>', \<delta>')\<in>insert (Q, \<delta>0) Is. \<forall>t. (\<phi> \<^bold>\<and> \<lceil>\<delta> \<^bold>= \<langle>t\<rangle>\<rceil> \<^bold>\<leadsto> \<phi>' \<^bold>\<and> \<lceil>\<delta>' \<^bold>\<otimes> \<langle>t\<rangle> \<^bold>\<in> \<langle>R\<rangle>\<rceil>) \<sigma>"
  shows "(P \<^bold>\<leadsto> Q) \<sigma>"
proof -
  have "(\<phi> \<^bold>\<and> \<lceil>\<delta> \<^bold>= \<langle>t\<rangle>\<rceil> \<^bold>\<leadsto> Q) \<sigma>" if "(\<phi>, \<delta>) \<in> Is" for \<phi> \<delta> t
    using \<open>wf R\<close> that W2
    apply (induct t arbitrary: \<phi> \<delta>)
    unfolding LTL.defs split_def
    apply clarsimp
    apply (metis (no_types, hide_lams) ab_semigroup_add_class.add_ac(1) fst_eqD snd_conv surjective_pairing)
    done
  with W1 show ?thesis
    apply -
    apply (rule alwaysI)
    apply clarsimp
    apply (erule_tac i=i in alwaysE)
    apply clarsimp
    using alwaysD suffix_state_prop apply blast
    done
qed

subsection\<open>Fairness\<close>

text\<open>

A few renderings of weak fairness. @{cite [cite_macro=citet] "vanGlabbeekHofner:2019"} call this
"response to insistence" as a generalisation of weak fairness.

\<close>

definition weakly_fair :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" where
  "weakly_fair enabled taken = (\<box>enabled \<^bold>\<hookrightarrow> \<diamond>taken)"

lemma weakly_fair_def2:
  shows "weakly_fair enabled taken = \<box>(\<^bold>\<not>\<box>(enabled \<^bold>\<and> \<^bold>\<not>taken))"
unfolding weakly_fair_def by (metis (full_types) always_conj_distrib norm(18))

lemma weakly_fair_def3:
  shows "weakly_fair enabled taken = (\<diamond>\<box>enabled \<^bold>\<longrightarrow> \<box>\<diamond>taken)"
unfolding weakly_fair_def2
apply (clarsimp simp: fun_eq_iff)

unfolding defs (* True, but can we get there deductively? *)
apply auto
apply (metis (full_types) add.left_commute semiring_normalization_rules(25))
done

lemma weakly_fair_def4:
  shows "weakly_fair enabled taken = \<box>\<diamond>(enabled \<^bold>\<longrightarrow> taken)"
using weakly_fair_def2 by force

lemma mp_weakly_fair:
  assumes "weakly_fair enabled taken \<sigma>"
  assumes "(\<box>enabled) \<sigma>"
  shows "(\<diamond>taken) \<sigma>"
using assms unfolding weakly_fair_def using always_imp_mp by blast

lemma always_weakly_fair:
  shows "\<box>(weakly_fair enabled taken) = weakly_fair enabled taken"
unfolding weakly_fair_def by simp

lemma eventually_weakly_fair:
  shows "\<diamond>(weakly_fair enabled taken) = weakly_fair enabled taken"
unfolding weakly_fair_def2 by (simp add: always_eventually_always)

lemma weakly_fair_weaken:
  assumes "(enabled' \<^bold>\<hookrightarrow> enabled) \<sigma>"
  assumes "(taken \<^bold>\<hookrightarrow> taken') \<sigma>"
  shows "(weakly_fair enabled taken \<^bold>\<hookrightarrow>  weakly_fair enabled' taken') \<sigma>"
using assms unfolding weakly_fair_def defs by simp blast

lemma weakly_fair_unless_until:
  shows "(weakly_fair enabled taken \<^bold>\<and> (enabled \<^bold>\<hookrightarrow> enabled \<W> taken)) = (enabled \<^bold>\<hookrightarrow> enabled \<U> taken)"
unfolding defs weakly_fair_def
apply (auto simp: fun_eq_iff)
apply (metis add.right_neutral)
done

lemma stable_leads_to_eventually:
  assumes "(enabled \<^bold>\<hookrightarrow> \<circle>(enabled \<^bold>\<or> taken)) \<sigma>"
  shows "(enabled \<^bold>\<hookrightarrow> (\<box>enabled \<^bold>\<or> \<diamond>taken)) \<sigma>"
using assms unfolding defs
apply -
apply (rule ccontr)
apply clarsimp
apply (drule (1) ex_least_nat_less[where P="\<lambda>j. \<not> enabled (\<sigma> |\<^sub>s i + j)" for i, simplified])
apply clarsimp
apply (metis add_Suc_right leI less_irrefl_nat)
done

lemma weakly_fair_stable_leads_to:
  assumes "(weakly_fair enabled taken) \<sigma>"
  assumes "(enabled \<^bold>\<hookrightarrow> \<circle>(enabled \<^bold>\<or> taken)) \<sigma>"
  shows "(enabled \<^bold>\<leadsto> taken) \<sigma>"
using stable_leads_to_eventually[OF assms(2)] assms(1) unfolding defs weakly_fair_def
by (auto simp: fun_eq_iff)

lemma weakly_fair_stable_leads_to_via:
  assumes "(weakly_fair enabled taken) \<sigma>"
  assumes "(enabled \<^bold>\<hookrightarrow> \<circle>(enabled \<^bold>\<or> taken)) \<sigma>"
  shows "(enabled \<^bold>\<hookrightarrow> enabled \<U> taken) \<sigma>"
using stable_unless[OF assms(2)] assms(1) by (metis (mono_tags) weakly_fair_unless_until)

text\<open>

Similarly for strong fairness. @{cite [cite_macro=citet] "vanGlabbeekHofner:2019"} call this
"response to persistence" as a generalisation of strong fairness.

\<close>

definition strongly_fair :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" where
  "strongly_fair enabled taken = (\<box>\<diamond>enabled \<^bold>\<hookrightarrow> \<diamond>taken)"

lemma strongly_fair_def2:
  "strongly_fair enabled taken = \<box>(\<^bold>\<not>\<box>(\<diamond>enabled \<^bold>\<and> \<^bold>\<not>taken))"
unfolding strongly_fair_def by (metis weakly_fair_def weakly_fair_def2)

lemma strongly_fair_def3:
  "strongly_fair enabled taken = (\<box>\<diamond>enabled \<^bold>\<longrightarrow> \<box>\<diamond>taken)"
unfolding strongly_fair_def2 by (metis (full_types) always_eventually_always weakly_fair_def2 weakly_fair_def3)

lemma always_strongly_fair:
  "\<box>(strongly_fair enabled taken) = strongly_fair enabled taken"
unfolding strongly_fair_def by simp

lemma eventually_strongly_fair:
  "\<diamond>(strongly_fair enabled taken) = strongly_fair enabled taken"
unfolding strongly_fair_def2 by (simp add: always_eventually_always)

lemma strongly_fair_disj_distrib: \<comment> \<open>not true for \<open>weakly_fair\<close>\<close>
  "strongly_fair (enabled1 \<^bold>\<or> enabled2) taken = (strongly_fair enabled1 taken \<^bold>\<and> strongly_fair enabled2 taken)"
unfolding strongly_fair_def defs
apply (auto simp: fun_eq_iff)
  apply blast
  apply blast
  apply (metis (full_types) semiring_normalization_rules(25))
done

lemma strongly_fair_imp_weakly_fair:
  assumes "strongly_fair enabled taken \<sigma>"
  shows "weakly_fair enabled taken \<sigma>"
using assms unfolding strongly_fair_def3 weakly_fair_def3 by (simp add: eventually_always_imp_always_eventually)

lemma always_enabled_weakly_fair_strongly_fair:
  assumes "(\<box>enabled) \<sigma>"
  shows "weakly_fair enabled taken \<sigma> = strongly_fair enabled taken \<sigma>"
using assms by (metis strongly_fair_def3 strongly_fair_imp_weakly_fair unfold(2) weakly_fair_def3)

subsection\<open>Safety and liveness \label{sec:ltl-safety-liveness}\<close>

text\<open>

@{cite [cite_macro=citet] "Sistla:1994"} shows some characterisations
of LTL formulas in terms of safety and liveness. Note his @{term
"(\<U>)"} is actually @{term "(\<W>)"}.

See also @{cite [cite_macro=citet] "ChangMannaPnueli:1992"}.

\<close>

lemma safety_state_prop:
  shows "safety \<lceil>P\<rceil>"
unfolding defs by (rule safety_state_prop)

lemma safety_Next:
  assumes "safety P"
  shows "safety (\<circle>P)"
using assms unfolding defs safety_def
apply clarsimp
apply (metis (mono_tags) One_nat_def list.sel(3) nat.simps(3) stake.simps(2))
done

lemma safety_unless:
  assumes "safety P"
  assumes "safety Q"
  shows "safety (P \<W> Q)"
proof(rule safetyI2)
  fix \<sigma> assume X: "\<exists>\<beta>. (P \<W> Q) (stake i \<sigma> @- \<beta>)" for i
  then show "(P \<W> Q) \<sigma>"
  proof(cases "\<forall>i j. \<exists>\<beta>. P (\<sigma>(i \<rightarrow> j) @- \<beta>)")
    case True
    with \<open>safety P\<close> have "\<forall>i. P (\<sigma> |\<^sub>s i)" unfolding safety_def2 by blast
    then show ?thesis by (blast intro: unless_alwaysI)
  next
    case False
    then obtain k k' where "\<forall>\<beta>. \<not> P (\<sigma>(k \<rightarrow> k') @- \<beta>)" by clarsimp
    then have "\<forall>i u. k + k' \<le> i \<longrightarrow> \<not>P ((stake i \<sigma> @- u) |\<^sub>s k)"
      by (metis add.commute diff_add stake_shift_stake_shift stake_suffix_drop suffix_shift)
    then have "\<forall>i u. k + k' \<le> i \<and> (P \<W> Q) (stake i \<sigma> @- u) \<longrightarrow> (\<exists>m\<le>k. Q ((stake i \<sigma> @- u) |\<^sub>s m) \<and> (\<forall>p<m. P ((stake i \<sigma> @- u) |\<^sub>s p)))"
      unfolding defs using leI by blast
    then have "\<forall>i u. k + k' \<le> i \<and> (P \<W> Q) (stake i \<sigma> @- u) \<longrightarrow> (\<exists>m\<le>k. Q (\<sigma>(m \<rightarrow> i - m) @- u) \<and> (\<forall>p<m. P (\<sigma>(p \<rightarrow> i - p) @- u)))"
      by (metis stake_suffix add_leE nat_less_le order_trans)
    then have "\<forall>i. \<exists>n\<ge>i. \<exists>m\<le>k. \<exists>u. Q (\<sigma>(m \<rightarrow> n - m) @- u) \<and> (\<forall>p<m. P (\<sigma>(p \<rightarrow> n - p) @- u))"
      using X by (metis add.commute le_add1)
    then have "\<exists>m\<le>k. \<forall>i. \<exists>n\<ge>i. \<exists>u. Q (\<sigma>(m \<rightarrow> n - m) @- u) \<and> (\<forall>p<m. P (\<sigma>(p \<rightarrow> n - p) @- u))"
      by (simp add: always_eventually_pigeonhole)
    with \<open>safety P\<close> \<open>safety Q\<close> show "(P \<W> Q) \<sigma>"
        unfolding defs by (metis Nat.le_diff_conv2 add_leE safety_always_eventually)
  qed
qed

lemma safety_always:
  assumes "safety P"
  shows "safety (\<box>P)"
using assms by (metis norm(20) safety_def safety_unless)

lemma absolute_liveness_eventually:
  shows "absolute_liveness P \<longleftrightarrow> (\<exists>\<sigma>. P \<sigma>) \<and> P = \<diamond>P"
unfolding absolute_liveness_def defs
by (metis cancel_comm_monoid_add_class.diff_cancel drop_eq_Nil order_refl shift.simps(1) stake_suffix_id suffix_shift suffix_zero)

lemma stable_always:
  shows "stable P \<longleftrightarrow> (\<exists>\<sigma>. P \<sigma>) \<and> P = \<box>P"
unfolding stable_def defs by (metis suffix_zero)

(* FIXME Sistla's examples of stable properties are boring and follow directly from this lemma.
   FIXME the fairness "type of formulas" follow from the above and the fairness def. *)

text\<open>

To show that @{const \<open>weakly_fair\<close>} is a @{const \<open>fairness\<close>} property requires some constraints on \<open>enabled\<close> and \<open>taken\<close>:
\<^item> it is reasonable to assume they are state formulas
\<^item> \<open>taken\<close> must be satisfiable

\<close>

lemma fairness_weakly_fair:
  assumes "\<exists>s. taken s"
  shows "fairness (weakly_fair \<lceil>enabled\<rceil> \<lceil>taken\<rceil>)"
unfolding fairness_def stable_def absolute_liveness_def weakly_fair_def
using assms
apply auto
   apply (rule_tac x="\<lambda>_ .s" in exI)
   apply fastforce
  apply (simp add: alwaysD)
 apply (rule_tac x="\<lambda>_ .s" in exI)
 apply fastforce
apply (metis (full_types) absolute_liveness_def absolute_liveness_eventually eventually_weakly_fair weakly_fair_def)
done

lemma fairness_strongly_fair:
  assumes "\<exists>s. taken s"
  shows "fairness (strongly_fair \<lceil>enabled\<rceil> \<lceil>taken\<rceil>)"
unfolding fairness_def stable_def absolute_liveness_def strongly_fair_def
using assms
apply auto
   apply (rule_tac x="\<lambda>_ .s" in exI)
   apply fastforce
  apply (simp add: alwaysD)
 apply (rule_tac x="\<lambda>_ .s" in exI)
 apply fastforce
apply (metis (full_types) absolute_liveness_def absolute_liveness_eventually eventually_weakly_fair weakly_fair_def)
done

(*<*)

end
(*>*)


(*  Title:      ZF/Induct/Binary_Trees.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section \<open>Binary trees\<close>

theory Binary_Trees imports ZF begin

subsection \<open>Datatype definition\<close>

consts
  bt :: "i => i"

datatype "bt(A)" =
  Lf | Br ("a \<in> A", "t1 \<in> bt(A)", "t2 \<in> bt(A)")

declare bt.intros [simp]

lemma Br_neq_left: "l \<in> bt(A) ==> Br(x, l, r) \<noteq> l"
  by (induct arbitrary: x r set: bt) auto

lemma Br_iff: "Br(a, l, r) = Br(a', l', r') \<longleftrightarrow> a = a' & l = l' & r = r'"
  \<comment> "Proving a freeness theorem."
  by (fast elim!: bt.free_elims)

inductive_cases BrE: "Br(a, l, r) \<in> bt(A)"
  \<comment> "An elimination rule, for type-checking."

text \<open>
  \medskip Lemmas to justify using @{term bt} in other recursive type
  definitions.
\<close>

lemma bt_mono: "A \<subseteq> B ==> bt(A) \<subseteq> bt(B)"
  apply (unfold bt.defs)
  apply (rule lfp_mono)
    apply (rule bt.bnd_mono)+
  apply (rule univ_mono basic_monos | assumption)+
  done

lemma bt_univ: "bt(univ(A)) \<subseteq> univ(A)"
  apply (unfold bt.defs bt.con_defs)
  apply (rule lfp_lowerbound)
   apply (rule_tac [2] A_subset_univ [THEN univ_mono])
  apply (fast intro!: zero_in_univ Inl_in_univ Inr_in_univ Pair_in_univ)
  done

lemma bt_subset_univ: "A \<subseteq> univ(B) ==> bt(A) \<subseteq> univ(B)"
  apply (rule subset_trans)
   apply (erule bt_mono)
  apply (rule bt_univ)
  done

lemma bt_rec_type:
  "[| t \<in> bt(A);
    c \<in> C(Lf);
    !!x y z r s. [| x \<in> A;  y \<in> bt(A);  z \<in> bt(A);  r \<in> C(y);  s \<in> C(z) |] ==>
    h(x, y, z, r, s) \<in> C(Br(x, y, z))
  |] ==> bt_rec(c, h, t) \<in> C(t)"
  \<comment> \<open>Type checking for recursor -- example only; not really needed.\<close>
  apply (induct_tac t)
   apply simp_all
  done

subsection \<open>Number of nodes, with an example of tail-recursion\<close>

consts  n_nodes :: "i => i"
primrec
  "n_nodes(Lf) = 0"
  "n_nodes(Br(a, l, r)) = succ(n_nodes(l) #+ n_nodes(r))"

lemma n_nodes_type [simp]: "t \<in> bt(A) ==> n_nodes(t) \<in> nat"
  by (induct set: bt) auto

consts  n_nodes_aux :: "i => i"
primrec
  "n_nodes_aux(Lf) = (\<lambda>k \<in> nat. k)"
  "n_nodes_aux(Br(a, l, r)) =
      (\<lambda>k \<in> nat. n_nodes_aux(r) `  (n_nodes_aux(l) ` succ(k)))"

lemma n_nodes_aux_eq:
    "t \<in> bt(A) ==> k \<in> nat ==> n_nodes_aux(t)`k = n_nodes(t) #+ k"
  apply (induct arbitrary: k set: bt)
   apply simp
  apply (atomize, simp)
  done

definition
  n_nodes_tail :: "i => i"  where
  "n_nodes_tail(t) == n_nodes_aux(t) ` 0"

lemma "t \<in> bt(A) ==> n_nodes_tail(t) = n_nodes(t)"
  by (simp add: n_nodes_tail_def n_nodes_aux_eq)

subsection \<open>Number of leaves\<close>

consts
  n_leaves :: "i => i"
primrec
  "n_leaves(Lf) = 1"
  "n_leaves(Br(a, l, r)) = n_leaves(l) #+ n_leaves(r)"

lemma n_leaves_type [simp]: "t \<in> bt(A) ==> n_leaves(t) \<in> nat"
  by (induct set: bt) auto

subsection \<open>Reflecting trees\<close>

consts
  bt_reflect :: "i => i"
primrec
  "bt_reflect(Lf) = Lf"
  "bt_reflect(Br(a, l, r)) = Br(a, bt_reflect(r), bt_reflect(l))"

lemma bt_reflect_type [simp]: "t \<in> bt(A) ==> bt_reflect(t) \<in> bt(A)"
  by (induct set: bt) auto

text \<open>
  \medskip Theorems about @{term n_leaves}.
\<close>

lemma n_leaves_reflect: "t \<in> bt(A) ==> n_leaves(bt_reflect(t)) = n_leaves(t)"
  by (induct set: bt) (simp_all add: add_commute)

lemma n_leaves_nodes: "t \<in> bt(A) ==> n_leaves(t) = succ(n_nodes(t))"
  by (induct set: bt) simp_all

text \<open>
  Theorems about @{term bt_reflect}.
\<close>

lemma bt_reflect_bt_reflect_ident: "t \<in> bt(A) ==> bt_reflect(bt_reflect(t)) = t"
  by (induct set: bt) simp_all

end