section \<open> Symbolic Evaluation of Relational Programs \<close>

theory utp_sym_eval
  imports utp_rel_opsem
begin

text \<open> The following operator applies a variable context $\Gamma$ as an assignment, and composes
  it with a relation $P$ for the purposes of evaluation. \<close>

definition utp_sym_eval :: "'s usubst \<Rightarrow> 's hrel \<Rightarrow> 's hrel" (infixr "\<Turnstile>" 55) where
[upred_defs]: "utp_sym_eval \<Gamma> P = (\<langle>\<Gamma>\<rangle>\<^sub>a ;; P)"

named_theorems symeval

lemma seq_symeval [symeval]: "\<Gamma> \<Turnstile> P ;; Q = (\<Gamma> \<Turnstile> P) ;; Q"
  by (rel_auto)

lemma assigns_symeval [symeval]: "\<Gamma> \<Turnstile> \<langle>\<sigma>\<rangle>\<^sub>a = (\<sigma> \<circ>\<^sub>s \<Gamma>) \<Turnstile> II"
  by (rel_auto)

lemma term_symeval [symeval]: "(\<Gamma> \<Turnstile> II) ;; P = \<Gamma> \<Turnstile> P"
  by (rel_auto)

lemma if_true_symeval [symeval]: "\<lbrakk> \<Gamma> \<dagger> b = true \<rbrakk> \<Longrightarrow> \<Gamma> \<Turnstile> (P \<triangleleft> b \<triangleright>\<^sub>r Q) = \<Gamma> \<Turnstile> P"
  by (simp add: utp_sym_eval_def usubst assigns_r_comp)

lemma if_false_symeval [symeval]: "\<lbrakk> \<Gamma> \<dagger> b = false \<rbrakk> \<Longrightarrow> \<Gamma> \<Turnstile> (P \<triangleleft> b \<triangleright>\<^sub>r Q) = \<Gamma> \<Turnstile> Q"
  by (simp add: utp_sym_eval_def usubst assigns_r_comp)

lemma while_true_symeval [symeval]: "\<lbrakk> \<Gamma> \<dagger> b = true \<rbrakk> \<Longrightarrow> \<Gamma> \<Turnstile> while b do P od = \<Gamma> \<Turnstile> (P ;; while b do P od)"
  by (subst while_unfold, simp add: symeval)

lemma while_false_symeval [symeval]: "\<lbrakk> \<Gamma> \<dagger> b = false \<rbrakk> \<Longrightarrow> \<Gamma> \<Turnstile> while b do P od = \<Gamma> \<Turnstile> II"
  by (subst while_unfold, simp add: symeval)

lemma while_inv_true_symeval [symeval]: "\<lbrakk> \<Gamma> \<dagger> b = true \<rbrakk> \<Longrightarrow> \<Gamma> \<Turnstile> while b invr S do P od = \<Gamma> \<Turnstile> (P ;; while b do P od)"
  by (metis while_inv_def while_true_symeval)

lemma while_inv_false_symeval [symeval]: "\<lbrakk> \<Gamma> \<dagger> b = false \<rbrakk> \<Longrightarrow> \<Gamma> \<Turnstile> while b invr S do P od = \<Gamma> \<Turnstile> II"
  by (metis while_false_symeval while_inv_def)

method sym_eval = (simp add: symeval usubst lit_simps[THEN sym]), (simp del: One_nat_def add: One_nat_def[THEN sym])?

syntax
  "_terminated" :: "logic \<Rightarrow> logic" ("terminated: _" [999] 999)

translations
  "terminated: \<Gamma>" == "\<Gamma> \<Turnstile> II"

text \<open> Below are some theorems linking symbolic evaluation and Hoare logic. \<close>

lemma hoare_symeval_link_1: "\<lbrace>b\<rbrace>P\<lbrace>c\<rbrace>\<^sub>u = (\<forall> s\<^sub>1 s\<^sub>2. `s\<^sub>1 \<dagger> b` \<and> ((s\<^sub>1 \<Turnstile> P) \<sqsubseteq> (s\<^sub>2 \<Turnstile> II)) \<longrightarrow> `s\<^sub>2 \<dagger> c`)"
  by (simp add: utp_sym_eval_def usubst hoare_opsem_link trel.simps)

lemma hoare_symeval_link_2: "\<lbrace>b\<rbrace>P\<lbrace>c\<rbrace>\<^sub>u \<Longrightarrow> `s\<^sub>1 \<dagger> b` \<and> ((s\<^sub>1 \<Turnstile> P) = (s\<^sub>2 \<Turnstile> II)) \<longrightarrow> `s\<^sub>2 \<dagger> c`"
  by (rel_blast)

end


theory Semantics
imports Main
begin

section \<open>The Language\<close>

subsection \<open>Variables and Values\<close>

type_synonym vname = string \<comment> \<open>names for variables\<close>

datatype val
  = Bool bool      \<comment> \<open>Boolean value\<close>
  | Intg int       \<comment> \<open>integer value\<close>

abbreviation "true == Bool True"
abbreviation "false == Bool False"

subsection \<open>Expressions and Commands\<close>

datatype bop = Eq | And | Less | Add | Sub     \<comment> \<open>names of binary operations\<close>

datatype expr
  = Val val                                          \<comment> \<open>value\<close>
  | Var vname                                        \<comment> \<open>local variable\<close>
  | BinOp expr bop expr    ("_ \<guillemotleft>_\<guillemotright> _" [80,0,81] 80)  \<comment> \<open>binary operation\<close>

text \<open>Note: we assume that only type correct expressions are regarded
  as later proofs fail if expressions evaluate to None due to type errors.
  However there is [yet] no typing system\<close>

fun binop :: "bop \<Rightarrow> val \<Rightarrow> val \<Rightarrow> val option"
where "binop Eq v\<^sub>1 v\<^sub>2               = Some(Bool(v\<^sub>1 = v\<^sub>2))"
  | "binop And (Bool b\<^sub>1) (Bool b\<^sub>2)  = Some(Bool(b\<^sub>1 \<and> b\<^sub>2))"
  | "binop Less (Intg i\<^sub>1) (Intg i\<^sub>2) = Some(Bool(i\<^sub>1 < i\<^sub>2))"
  | "binop Add (Intg i\<^sub>1) (Intg i\<^sub>2)  = Some(Intg(i\<^sub>1 + i\<^sub>2))"
  | "binop Sub (Intg i\<^sub>1) (Intg i\<^sub>2)  = Some(Intg(i\<^sub>1 - i\<^sub>2))"

  | "binop bop v\<^sub>1 v\<^sub>2                = Some(Intg(0))"

datatype com
  = Skip
  | LAss vname expr        ("_:=_" [70,70] 70)  \<comment> \<open>local assignment\<close>
  | Seq com com            ("_;;/ _" [61,60] 60)
  | Cond expr com com      ("if '(_') _/ else _" [80,79,79] 70)
  | While expr com         ("while '(_') _" [80,79] 70)

fun fv :: "expr \<Rightarrow> vname set" \<comment> \<open>free variables in an expression\<close>
where
  FVc: "fv (Val V) = {}"
  | FVv: "fv (Var V) = {V}"
  | FVe: "fv (e1 \<guillemotleft>bop\<guillemotright> e2) = fv e1 \<union> fv e2"

subsection \<open>State\<close>

type_synonym state = "vname \<rightharpoonup> val"

text \<open>\<open>interpret\<close> silently assumes type correct expressions,
  i.e. no expression evaluates to None\<close>

fun "interpret" :: "expr \<Rightarrow> state \<Rightarrow> val option" ("\<lbrakk>_\<rbrakk>_")
where Val: "\<lbrakk>Val v\<rbrakk> s = Some v"
  | Var: "\<lbrakk>Var V\<rbrakk> s = s V"
  | BinOp: "\<lbrakk>e\<^sub>1\<guillemotleft>bop\<guillemotright>e\<^sub>2\<rbrakk> s = (case \<lbrakk>e\<^sub>1\<rbrakk> s of None \<Rightarrow> None
    | Some v\<^sub>1 \<Rightarrow> (case \<lbrakk>e\<^sub>2\<rbrakk> s of None \<Rightarrow> None
                           | Some v\<^sub>2 \<Rightarrow> binop bop v\<^sub>1 v\<^sub>2))"

subsection \<open>Small Step Semantics\<close>

inductive red :: "com * state \<Rightarrow> com * state \<Rightarrow> bool"
and red' :: "com \<Rightarrow> state \<Rightarrow> com \<Rightarrow> state \<Rightarrow> bool"
   ("((1\<langle>_,/_\<rangle>) \<rightarrow>/ (1\<langle>_,/_\<rangle>))" [0,0,0,0] 81)
where
  "\<langle>c1,s1\<rangle> \<rightarrow> \<langle>c2,s2\<rangle> == red (c1,s1) (c2,s2)" |
  RedLAss:
  "\<langle>V:=e,s\<rangle> \<rightarrow> \<langle>Skip,s(V:=(\<lbrakk>e\<rbrakk> s))\<rangle>"

  | SeqRed:
  "\<langle>c\<^sub>1,s\<rangle> \<rightarrow> \<langle>c\<^sub>1',s'\<rangle> \<Longrightarrow> \<langle>c\<^sub>1;;c\<^sub>2,s\<rangle> \<rightarrow> \<langle>c\<^sub>1';;c\<^sub>2,s'\<rangle>"

  | RedSeq:
  "\<langle>Skip;;c\<^sub>2,s\<rangle> \<rightarrow> \<langle>c\<^sub>2,s\<rangle>"

  | RedCondTrue:
  "\<lbrakk>b\<rbrakk> s = Some true \<Longrightarrow> \<langle>if (b) c\<^sub>1 else c\<^sub>2,s\<rangle> \<rightarrow> \<langle>c\<^sub>1,s\<rangle>"

  | RedCondFalse:
  "\<lbrakk>b\<rbrakk> s = Some false \<Longrightarrow> \<langle>if (b) c\<^sub>1 else c\<^sub>2,s\<rangle> \<rightarrow> \<langle>c\<^sub>2,s\<rangle>"

  | RedWhileTrue:
  "\<lbrakk>b\<rbrakk> s = Some true \<Longrightarrow> \<langle>while (b) c,s\<rangle> \<rightarrow> \<langle>c;;while (b) c,s\<rangle>"

  | RedWhileFalse:
  "\<lbrakk>b\<rbrakk> s = Some false \<Longrightarrow> \<langle>while (b) c,s\<rangle> \<rightarrow> \<langle>Skip,s\<rangle>"

lemmas red_induct = red.induct[split_format (complete)]

abbreviation reds ::"com \<Rightarrow> state \<Rightarrow> com \<Rightarrow> state \<Rightarrow> bool"
   ("((1\<langle>_,/_\<rangle>) \<rightarrow>*/ (1\<langle>_,/_\<rangle>))" [0,0,0,0] 81) where
  "\<langle>c,s\<rangle> \<rightarrow>* \<langle>c',s'\<rangle> ==  red\<^sup>*\<^sup>* (c,s) (c',s')"

lemma Skip_reds:
  "\<langle>Skip,s\<rangle> \<rightarrow>* \<langle>c',s'\<rangle> \<Longrightarrow> s = s' \<and> c' = Skip"
by(blast elim:converse_rtranclpE red.cases)

lemma LAss_reds:
  "\<langle>V:=e,s\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle> \<Longrightarrow> s' = s(V:=\<lbrakk>e\<rbrakk> s)"
proof(induct "V:=e" s rule:converse_rtranclp_induct2)
  case (step s c'' s'')
  hence "c'' = Skip" and "s'' = s(V:=(\<lbrakk>e\<rbrakk> s))" by(auto elim:red.cases)
  with \<open>\<langle>c'',s''\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle>\<close> show ?case by(auto dest:Skip_reds)
qed

lemma Seq2_reds:
  "\<langle>Skip;;c\<^sub>2,s\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle> \<Longrightarrow> \<langle>c\<^sub>2,s\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle>"
by(induct c=="Skip;;c\<^sub>2" s rule:converse_rtranclp_induct2)(auto elim:red.cases)

lemma Seq_reds:
  assumes "\<langle>c\<^sub>1;;c\<^sub>2,s\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle>"
  obtains s'' where "\<langle>c\<^sub>1,s\<rangle> \<rightarrow>* \<langle>Skip,s''\<rangle>" and "\<langle>c\<^sub>2,s''\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle>"
proof -
  have "\<exists>s''. \<langle>c\<^sub>1,s\<rangle> \<rightarrow>* \<langle>Skip,s''\<rangle> \<and> \<langle>c\<^sub>2,s''\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle>"
  proof -
    { fix c c'
      assume "\<langle>c,s\<rangle> \<rightarrow>* \<langle>c',s'\<rangle>" and "c = c\<^sub>1;;c\<^sub>2" and "c' = Skip"
      hence "\<exists>s''. \<langle>c\<^sub>1,s\<rangle> \<rightarrow>* \<langle>Skip,s''\<rangle> \<and> \<langle>c\<^sub>2,s''\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle>"
      proof(induct arbitrary:c\<^sub>1 rule:converse_rtranclp_induct2)
        case refl thus ?case by simp
      next
        case (step c s c'' s'')
        note IH = \<open>\<And>c\<^sub>1. \<lbrakk>c'' = c\<^sub>1;;c\<^sub>2; c' = Skip\<rbrakk>
          \<Longrightarrow> \<exists>sx. \<langle>c\<^sub>1,s''\<rangle> \<rightarrow>* \<langle>Skip,sx\<rangle> \<and> \<langle>c\<^sub>2,sx\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle>\<close>
        from step
        have "\<langle>c\<^sub>1;;c\<^sub>2,s\<rangle> \<rightarrow> \<langle>c'',s''\<rangle>" by simp
        hence "(c\<^sub>1 = Skip \<and> c'' = c\<^sub>2 \<and> s = s'') \<or>
          (\<exists>c\<^sub>1'. \<langle>c\<^sub>1,s\<rangle> \<rightarrow> \<langle>c\<^sub>1',s''\<rangle> \<and> c'' = c\<^sub>1';;c\<^sub>2)"
          by(auto elim:red.cases)
        thus ?case
        proof
          assume "c\<^sub>1 = Skip \<and> c'' = c\<^sub>2 \<and> s = s''"
          with \<open>\<langle>c'',s''\<rangle> \<rightarrow>* \<langle>c',s'\<rangle>\<close> \<open>c' = Skip\<close>
          show ?thesis by auto
        next
          assume "\<exists>c\<^sub>1'. \<langle>c\<^sub>1,s\<rangle> \<rightarrow> \<langle>c\<^sub>1',s''\<rangle> \<and> c'' = c\<^sub>1';;c\<^sub>2"
          then obtain c\<^sub>1' where "\<langle>c\<^sub>1,s\<rangle> \<rightarrow> \<langle>c\<^sub>1',s''\<rangle>" and "c'' = c\<^sub>1';;c\<^sub>2" by blast
          from IH[OF \<open>c'' = c\<^sub>1';;c\<^sub>2\<close> \<open>c' = Skip\<close>]
          obtain sx where "\<langle>c\<^sub>1',s''\<rangle> \<rightarrow>* \<langle>Skip,sx\<rangle>" and "\<langle>c\<^sub>2,sx\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle>"
            by blast
          from \<open>\<langle>c\<^sub>1,s\<rangle> \<rightarrow> \<langle>c\<^sub>1',s''\<rangle>\<close> \<open>\<langle>c\<^sub>1',s''\<rangle> \<rightarrow>* \<langle>Skip,sx\<rangle>\<close>
          have "\<langle>c\<^sub>1,s\<rangle> \<rightarrow>* \<langle>Skip,sx\<rangle>" by(auto intro:converse_rtranclp_into_rtranclp)
          with \<open>\<langle>c\<^sub>2,sx\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle>\<close> show ?thesis by auto
        qed
      qed }
    with \<open>\<langle>c\<^sub>1;;c\<^sub>2,s\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle>\<close> show ?thesis by simp
  qed
  with that show ?thesis by blast
qed

lemma Cond_True_or_False:
  "\<langle>if (b) c\<^sub>1 else c\<^sub>2,s\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle> \<Longrightarrow> \<lbrakk>b\<rbrakk> s = Some true \<or> \<lbrakk>b\<rbrakk> s = Some false"
by(induct c=="if (b) c\<^sub>1 else c\<^sub>2" s rule:converse_rtranclp_induct2)(auto elim:red.cases)

lemma CondTrue_reds:
  "\<langle>if (b) c\<^sub>1 else c\<^sub>2,s\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle> \<Longrightarrow> \<lbrakk>b\<rbrakk> s = Some true \<Longrightarrow> \<langle>c\<^sub>1,s\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle>"
by(induct c=="if (b) c\<^sub>1 else c\<^sub>2" s rule:converse_rtranclp_induct2)(auto elim:red.cases)

lemma CondFalse_reds:
  "\<langle>if (b) c\<^sub>1 else c\<^sub>2,s\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle> \<Longrightarrow> \<lbrakk>b\<rbrakk> s = Some false \<Longrightarrow> \<langle>c\<^sub>2,s\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle>"
by(induct c=="if (b) c\<^sub>1 else c\<^sub>2" s rule:converse_rtranclp_induct2)(auto elim:red.cases)

lemma WhileFalse_reds:
  "\<langle>while (b) cx,s\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle> \<Longrightarrow> \<lbrakk>b\<rbrakk> s = Some false \<Longrightarrow> s = s'"
proof(induct "while (b) cx" s rule:converse_rtranclp_induct2)
  case step thus ?case by(auto elim:red.cases dest: Skip_reds)
qed

lemma WhileTrue_reds:
  "\<langle>while (b) cx,s\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle> \<Longrightarrow> \<lbrakk>b\<rbrakk> s = Some true
  \<Longrightarrow> \<exists>sx. \<langle>cx,s\<rangle> \<rightarrow>* \<langle>Skip,sx\<rangle> \<and> \<langle>while (b) cx,sx\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle>"
proof(induct "while (b) cx" s rule:converse_rtranclp_induct2)
  case (step s c'' s'')
  hence "c'' = cx;;while (b) cx \<and> s'' = s" by(auto elim:red.cases)
  with \<open>\<langle>c'',s''\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle>\<close> show ?case by(auto dest:Seq_reds)
qed

lemma While_True_or_False:
  "\<langle>while (b) com,s\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle> \<Longrightarrow> \<lbrakk>b\<rbrakk> s = Some true \<or> \<lbrakk>b\<rbrakk> s = Some false"
by(induct c=="while (b) com" s rule:converse_rtranclp_induct2)(auto elim:red.cases)

inductive red_n :: "com \<Rightarrow> state \<Rightarrow> nat \<Rightarrow> com \<Rightarrow> state \<Rightarrow> bool"
   ("((1\<langle>_,/_\<rangle>) \<rightarrow>\<^bsup>_\<^esup> (1\<langle>_,/_\<rangle>))" [0,0,0,0,0] 81)
where red_n_Base: "\<langle>c,s\<rangle> \<rightarrow>\<^bsup>0\<^esup> \<langle>c,s\<rangle>"
     | red_n_Rec: "\<lbrakk>\<langle>c,s\<rangle> \<rightarrow> \<langle>c'',s''\<rangle>; \<langle>c'',s''\<rangle> \<rightarrow>\<^bsup>n\<^esup> \<langle>c',s'\<rangle>\<rbrakk> \<Longrightarrow> \<langle>c,s\<rangle> \<rightarrow>\<^bsup>Suc n\<^esup> \<langle>c',s'\<rangle>"

lemma Seq_red_nE: assumes "\<langle>c\<^sub>1;;c\<^sub>2,s\<rangle> \<rightarrow>\<^bsup>n\<^esup> \<langle>Skip,s'\<rangle>"
  obtains i j s'' where "\<langle>c\<^sub>1,s\<rangle> \<rightarrow>\<^bsup>i\<^esup> \<langle>Skip,s''\<rangle>" and "\<langle>c\<^sub>2,s''\<rangle> \<rightarrow>\<^bsup>j\<^esup> \<langle>Skip,s'\<rangle>"
  and "n = i + j + 1"
proof -
  from \<open>\<langle>c\<^sub>1;;c\<^sub>2,s\<rangle> \<rightarrow>\<^bsup>n\<^esup> \<langle>Skip,s'\<rangle>\<close>
  have "\<exists>i j s''. \<langle>c\<^sub>1,s\<rangle> \<rightarrow>\<^bsup>i\<^esup> \<langle>Skip,s''\<rangle> \<and> \<langle>c\<^sub>2,s''\<rangle> \<rightarrow>\<^bsup>j\<^esup> \<langle>Skip,s'\<rangle> \<and> n = i + j + 1"
  proof(induct "c\<^sub>1;;c\<^sub>2" s n "Skip" s' arbitrary:c\<^sub>1 rule:red_n.induct)
    case (red_n_Rec s c'' s'' n s')
    note IH = \<open>\<And>c\<^sub>1. c'' = c\<^sub>1;;c\<^sub>2
      \<Longrightarrow> \<exists>i j sx. \<langle>c\<^sub>1,s''\<rangle> \<rightarrow>\<^bsup>i\<^esup> \<langle>Skip,sx\<rangle> \<and> \<langle>c\<^sub>2,sx\<rangle> \<rightarrow>\<^bsup>j\<^esup> \<langle>Skip,s'\<rangle> \<and> n = i + j + 1\<close>
    from \<open>\<langle>c\<^sub>1;;c\<^sub>2,s\<rangle> \<rightarrow> \<langle>c'',s''\<rangle>\<close>
    have "(c\<^sub>1 = Skip \<and> c'' = c\<^sub>2 \<and> s = s'') \<or>
      (\<exists>c\<^sub>1'. c'' = c\<^sub>1';;c\<^sub>2 \<and> \<langle>c\<^sub>1,s\<rangle> \<rightarrow> \<langle>c\<^sub>1',s''\<rangle>)"
      by(induct "c\<^sub>1;;c\<^sub>2" _ _ _ rule:red_induct) auto
    thus ?case
    proof
      assume "c\<^sub>1 = Skip \<and> c'' = c\<^sub>2 \<and> s = s''"
      hence "c\<^sub>1 = Skip" and "c'' = c\<^sub>2" and "s = s''" by simp_all
      from \<open>c\<^sub>1 = Skip\<close> have "\<langle>c\<^sub>1,s\<rangle> \<rightarrow>\<^bsup>0\<^esup> \<langle>Skip,s\<rangle>" by(fastforce intro:red_n_Base)
      with \<open>\<langle>c'',s''\<rangle> \<rightarrow>\<^bsup>n\<^esup> \<langle>Skip,s'\<rangle>\<close> \<open>c'' = c\<^sub>2\<close> \<open>s = s''\<close>
      show ?thesis by(rule_tac x="0" in exI) auto
    next
      assume "\<exists>c\<^sub>1'. c'' = c\<^sub>1';;c\<^sub>2 \<and> \<langle>c\<^sub>1,s\<rangle> \<rightarrow> \<langle>c\<^sub>1',s''\<rangle>"
      then obtain c\<^sub>1' where "c'' = c\<^sub>1';;c\<^sub>2" and "\<langle>c\<^sub>1,s\<rangle> \<rightarrow> \<langle>c\<^sub>1',s''\<rangle>" by blast
      from IH[OF \<open>c'' = c\<^sub>1';;c\<^sub>2\<close>] obtain i j sx
        where "\<langle>c\<^sub>1',s''\<rangle> \<rightarrow>\<^bsup>i\<^esup> \<langle>Skip,sx\<rangle>" and "\<langle>c\<^sub>2,sx\<rangle> \<rightarrow>\<^bsup>j\<^esup> \<langle>Skip,s'\<rangle>"
        and "n = i + j + 1" by blast
      from \<open>\<langle>c\<^sub>1,s\<rangle> \<rightarrow> \<langle>c\<^sub>1',s''\<rangle>\<close> \<open>\<langle>c\<^sub>1',s''\<rangle> \<rightarrow>\<^bsup>i\<^esup> \<langle>Skip,sx\<rangle>\<close>
      have "\<langle>c\<^sub>1,s\<rangle> \<rightarrow>\<^bsup>Suc i\<^esup> \<langle>Skip,sx\<rangle>" by(rule red_n.red_n_Rec)
      with \<open>\<langle>c\<^sub>2,sx\<rangle> \<rightarrow>\<^bsup>j\<^esup> \<langle>Skip,s'\<rangle>\<close> \<open>n = i + j + 1\<close> show ?thesis
        by(rule_tac x="Suc i" in exI) auto
    qed
  qed
  with that show ?thesis by blast
qed

lemma while_red_nE:
  "\<langle>while (b) cx,s\<rangle> \<rightarrow>\<^bsup>n\<^esup> \<langle>Skip,s'\<rangle>
  \<Longrightarrow> (\<lbrakk>b\<rbrakk> s = Some false \<and> s = s' \<and> n = 1) \<or>
     (\<exists>i j s''. \<lbrakk>b\<rbrakk> s = Some true \<and> \<langle>cx,s\<rangle> \<rightarrow>\<^bsup>i\<^esup> \<langle>Skip,s''\<rangle> \<and>
                \<langle>while (b) cx,s''\<rangle> \<rightarrow>\<^bsup>j\<^esup> \<langle>Skip,s'\<rangle> \<and> n = i + j + 2)"
proof(induct "while (b) cx" s n "Skip" s' rule:red_n.induct)
  case (red_n_Rec s c'' s'' n s')
  from \<open>\<langle>while (b) cx,s\<rangle> \<rightarrow> \<langle>c'',s''\<rangle>\<close>
  have "(\<lbrakk>b\<rbrakk> s = Some false \<and> c'' = Skip \<and> s'' = s) \<or>
    (\<lbrakk>b\<rbrakk> s = Some true \<and> c'' = cx;;while (b) cx \<and> s'' = s)"
    by(induct "while (b) cx" _ _ _ rule:red_induct) auto
  thus ?case
  proof
    assume "\<lbrakk>b\<rbrakk> s = Some false \<and> c'' = Skip \<and> s'' = s"
    hence "\<lbrakk>b\<rbrakk> s = Some false" and "c'' = Skip" and "s'' = s" by simp_all
    with \<open>\<langle>c'',s''\<rangle> \<rightarrow>\<^bsup>n\<^esup> \<langle>Skip,s'\<rangle>\<close> have "s = s'" and "n = 0"
      by(induct _ _ Skip _ rule:red_n.induct,auto elim:red.cases)
    with \<open>\<lbrakk>b\<rbrakk> s = Some false\<close> show ?thesis by fastforce
  next
    assume "\<lbrakk>b\<rbrakk> s = Some true \<and> c'' = cx;;while (b) cx \<and> s'' = s"
    hence "\<lbrakk>b\<rbrakk> s = Some true" and "c'' = cx;;while (b) cx"
      and "s'' = s" by simp_all
    with \<open>\<langle>c'',s''\<rangle> \<rightarrow>\<^bsup>n\<^esup> \<langle>Skip,s'\<rangle>\<close>
    obtain i j sx where "\<langle>cx,s\<rangle> \<rightarrow>\<^bsup>i\<^esup> \<langle>Skip,sx\<rangle>" and "\<langle>while (b) cx,sx\<rangle> \<rightarrow>\<^bsup>j\<^esup> \<langle>Skip,s'\<rangle>"
      and "n = i + j + 1" by(fastforce elim:Seq_red_nE)
    with \<open>\<lbrakk>b\<rbrakk> s = Some true\<close> show ?thesis by fastforce
  qed
qed

lemma while_red_n_induct [consumes 1, case_names false true]:
  assumes major: "\<langle>while (b) cx,s\<rangle> \<rightarrow>\<^bsup>n\<^esup> \<langle>Skip,s'\<rangle>"
  and IHfalse:"\<And>s.  \<lbrakk>b\<rbrakk> s = Some false \<Longrightarrow> P s s"
  and IHtrue:"\<And>s i j s''. \<lbrakk>  \<lbrakk>b\<rbrakk> s = Some true; \<langle>cx,s\<rangle> \<rightarrow>\<^bsup>i\<^esup> \<langle>Skip,s''\<rangle>;
                            \<langle>while (b) cx,s''\<rangle> \<rightarrow>\<^bsup>j\<^esup> \<langle>Skip,s'\<rangle>; P s'' s'\<rbrakk> \<Longrightarrow> P s s'"
  shows "P s s'"
using major
proof(induct n arbitrary:s rule:nat_less_induct)
  fix n s
  assume IHall:"\<forall>m<n. \<forall>x. \<langle>while (b) cx,x\<rangle> \<rightarrow>\<^bsup>m\<^esup> \<langle>Skip,s'\<rangle> \<longrightarrow> P x s'"
    and  "\<langle>while (b) cx,s\<rangle> \<rightarrow>\<^bsup>n\<^esup> \<langle>Skip,s'\<rangle>"
  from \<open>\<langle>while (b) cx,s\<rangle> \<rightarrow>\<^bsup>n\<^esup> \<langle>Skip,s'\<rangle>\<close>
  have "(\<lbrakk>b\<rbrakk> s = Some false \<and> s = s' \<and> n = 1) \<or>
     (\<exists>i j s''. \<lbrakk>b\<rbrakk> s = Some true \<and> \<langle>cx,s\<rangle> \<rightarrow>\<^bsup>i\<^esup> \<langle>Skip,s''\<rangle> \<and>
                \<langle>while (b) cx,s''\<rangle> \<rightarrow>\<^bsup>j\<^esup> \<langle>Skip,s'\<rangle> \<and> n = i + j + 2)"
    by(rule while_red_nE)
  thus "P s s'"
  proof
    assume "\<lbrakk>b\<rbrakk> s = Some false \<and> s = s' \<and> n = 1"
    hence "\<lbrakk>b\<rbrakk> s = Some false" and "s = s'" by auto
    from IHfalse[OF \<open>\<lbrakk>b\<rbrakk> s = Some false\<close>] have "P s s" .
    with \<open>s = s'\<close> show ?thesis by simp
  next
    assume "\<exists>i j s''. \<lbrakk>b\<rbrakk> s = Some true \<and> \<langle>cx,s\<rangle> \<rightarrow>\<^bsup>i\<^esup> \<langle>Skip,s''\<rangle> \<and>
                      \<langle>while (b) cx,s''\<rangle> \<rightarrow>\<^bsup>j\<^esup> \<langle>Skip,s'\<rangle> \<and> n = i + j + 2"
    then obtain i j s'' where "\<lbrakk>b\<rbrakk> s = Some true"
      and "\<langle>cx,s\<rangle> \<rightarrow>\<^bsup>i\<^esup> \<langle>Skip,s''\<rangle>" and "\<langle>while (b) cx,s''\<rangle> \<rightarrow>\<^bsup>j\<^esup> \<langle>Skip,s'\<rangle>"
      and "n = i + j + 2" by blast
    with IHall have "P s'' s'"
      apply(erule_tac x="j" in allE) apply clarsimp done
    from IHtrue[OF \<open>\<lbrakk>b\<rbrakk> s = Some true\<close> \<open>\<langle>cx,s\<rangle> \<rightarrow>\<^bsup>i\<^esup> \<langle>Skip,s''\<rangle>\<close>
      \<open>\<langle>while (b) cx,s''\<rangle> \<rightarrow>\<^bsup>j\<^esup> \<langle>Skip,s'\<rangle>\<close> this] show ?thesis .
  qed
qed

lemma reds_to_red_n:"\<langle>c,s\<rangle> \<rightarrow>* \<langle>c',s'\<rangle> \<Longrightarrow> \<exists>n. \<langle>c,s\<rangle> \<rightarrow>\<^bsup>n\<^esup> \<langle>c',s'\<rangle>"
by(induct rule:converse_rtranclp_induct2,auto intro:red_n.intros)

lemma red_n_to_reds:"\<langle>c,s\<rangle> \<rightarrow>\<^bsup>n\<^esup> \<langle>c',s'\<rangle> \<Longrightarrow> \<langle>c,s\<rangle> \<rightarrow>* \<langle>c',s'\<rangle>"
by(induct rule:red_n.induct,auto intro:converse_rtranclp_into_rtranclp)

lemma while_reds_induct[consumes 1, case_names false true]:
  "\<lbrakk>\<langle>while (b) cx,s\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle>; \<And>s. \<lbrakk>b\<rbrakk> s = Some false \<Longrightarrow> P s s;
    \<And>s s''. \<lbrakk> \<lbrakk>b\<rbrakk> s = Some true; \<langle>cx,s\<rangle> \<rightarrow>* \<langle>Skip,s''\<rangle>;
             \<langle>while (b) cx,s''\<rangle> \<rightarrow>* \<langle>Skip,s'\<rangle>; P s'' s'\<rbrakk> \<Longrightarrow> P s s'\<rbrakk>
  \<Longrightarrow> P s s'"
apply(drule reds_to_red_n,clarsimp)
apply(erule while_red_n_induct,clarsimp)
by(auto dest:red_n_to_reds)

lemma red_det:
  "\<lbrakk>\<langle>c,s\<rangle> \<rightarrow> \<langle>c\<^sub>1,s\<^sub>1\<rangle>; \<langle>c,s\<rangle> \<rightarrow> \<langle>c\<^sub>2,s\<^sub>2\<rangle>\<rbrakk> \<Longrightarrow> c\<^sub>1 = c\<^sub>2 \<and> s\<^sub>1 = s\<^sub>2"
proof(induct arbitrary:c\<^sub>2 rule:red_induct)
  case (SeqRed c\<^sub>1 s c\<^sub>1' s' c\<^sub>2')
  note IH = \<open>\<And>c\<^sub>2. \<langle>c\<^sub>1,s\<rangle> \<rightarrow> \<langle>c\<^sub>2,s\<^sub>2\<rangle> \<Longrightarrow> c\<^sub>1' = c\<^sub>2 \<and> s' = s\<^sub>2\<close>
  from \<open>\<langle>c\<^sub>1;;c\<^sub>2',s\<rangle> \<rightarrow> \<langle>c\<^sub>2,s\<^sub>2\<rangle>\<close> have "c\<^sub>1 = Skip \<or> (\<exists>cx. c\<^sub>2 = cx;;c\<^sub>2' \<and> \<langle>c\<^sub>1,s\<rangle> \<rightarrow> \<langle>cx,s\<^sub>2\<rangle>)"
    by(fastforce elim:red.cases)
  thus ?case
  proof
    assume "c\<^sub>1 = Skip"
    with \<open>\<langle>c\<^sub>1,s\<rangle> \<rightarrow> \<langle>c\<^sub>1',s'\<rangle>\<close> have False by(fastforce elim:red.cases)
    thus ?thesis by simp
  next
    assume "\<exists>cx. c\<^sub>2 = cx;;c\<^sub>2' \<and> \<langle>c\<^sub>1,s\<rangle> \<rightarrow> \<langle>cx,s\<^sub>2\<rangle>"
    then obtain cx where "c\<^sub>2 = cx;;c\<^sub>2'" and "\<langle>c\<^sub>1,s\<rangle> \<rightarrow> \<langle>cx,s\<^sub>2\<rangle>" by blast
    from IH[OF \<open>\<langle>c\<^sub>1,s\<rangle> \<rightarrow> \<langle>cx,s\<^sub>2\<rangle>\<close>] have "c\<^sub>1' = cx \<and> s' = s\<^sub>2" .
    with \<open>c\<^sub>2 = cx;;c\<^sub>2'\<close> show ?thesis by simp
  qed
qed (fastforce elim:red.cases)+

theorem reds_det:
  "\<lbrakk>\<langle>c,s\<rangle> \<rightarrow>* \<langle>Skip,s\<^sub>1\<rangle>; \<langle>c,s\<rangle> \<rightarrow>* \<langle>Skip,s\<^sub>2\<rangle>\<rbrakk> \<Longrightarrow> s\<^sub>1 = s\<^sub>2"
proof(induct rule:converse_rtranclp_induct2)
  case refl
  from \<open>\<langle>Skip,s\<^sub>1\<rangle> \<rightarrow>* \<langle>Skip,s\<^sub>2\<rangle>\<close> show ?case
    by -(erule converse_rtranclpE,auto elim:red.cases)
next
  case (step c'' s'' c' s')
  note IH = \<open>\<langle>c',s'\<rangle> \<rightarrow>* \<langle>Skip,s\<^sub>2\<rangle> \<Longrightarrow> s\<^sub>1 = s\<^sub>2\<close>
  from step have "\<langle>c'',s''\<rangle> \<rightarrow> \<langle>c',s'\<rangle>"
    by simp
  from \<open>\<langle>c'',s''\<rangle> \<rightarrow>* \<langle>Skip,s\<^sub>2\<rangle>\<close> this have "\<langle>c',s'\<rangle> \<rightarrow>* \<langle>Skip,s\<^sub>2\<rangle>"
    by -(erule converse_rtranclpE,auto elim:red.cases dest:red_det)
  from IH[OF this] show ?thesis .
qed

end


(*  Title:      ZF/UNITY/WFair.thy
    Author:     Sidi Ehmety, Computer Laboratory
    Copyright   1998  University of Cambridge
*)

section\<open>Progress under Weak Fairness\<close>

theory WFair
imports UNITY ZFC
begin

text\<open>This theory defines the operators transient, ensures and leadsTo,
assuming weak fairness. From Misra, "A Logic for Concurrent Programming",
1994.\<close>

definition
  (* This definition specifies weak fairness.  The rest of the theory
    is generic to all forms of fairness.*)
  transient :: "i=>i"  where
  "transient(A) =={F \<in> program. (\<exists>act\<in>Acts(F). A<=domain(act) &
                               act``A \<subseteq> state-A) & st_set(A)}"

definition
  ensures :: "[i,i] => i"       (infixl \<open>ensures\<close> 60)  where
  "A ensures B == ((A-B) co (A \<union> B)) \<inter> transient(A-B)"

consts

  (*LEADS-TO constant for the inductive definition*)
  leads :: "[i, i]=>i"

inductive
  domains
     "leads(D, F)" \<subseteq> "Pow(D)*Pow(D)"
  intros
    Basis:  "[| F \<in> A ensures B;  A \<in> Pow(D); B \<in> Pow(D) |] ==> <A,B>:leads(D, F)"
    Trans:  "[| <A,B> \<in> leads(D, F); <B,C> \<in> leads(D, F) |] ==>  <A,C>:leads(D, F)"
    Union:   "[| S \<in> Pow({A \<in> S. <A, B>:leads(D, F)}); B \<in> Pow(D); S \<in> Pow(Pow(D)) |] ==>
              <\<Union>(S),B>:leads(D, F)"

  monos        Pow_mono
  type_intros  Union_Pow_iff [THEN iffD2] UnionI PowI

definition
  (* The Visible version of the LEADS-TO relation*)
  leadsTo :: "[i, i] => i"       (infixl \<open>\<longmapsto>\<close> 60)  where
  "A \<longmapsto> B == {F \<in> program. <A,B>:leads(state, F)}"

definition
  (* wlt(F, B) is the largest set that leads to B*)
  wlt :: "[i, i] => i"  where
    "wlt(F, B) == \<Union>({A \<in> Pow(state). F \<in> A \<longmapsto> B})"

(** Ad-hoc set-theory rules **)

lemma Int_Union_Union: "\<Union>(B) \<inter> A = (\<Union>b \<in> B. b \<inter> A)"
by auto

lemma Int_Union_Union2: "A \<inter> \<Union>(B) = (\<Union>b \<in> B. A \<inter> b)"
by auto

(*** transient ***)

lemma transient_type: "transient(A)<=program"
by (unfold transient_def, auto)

lemma transientD2:
"F \<in> transient(A) ==> F \<in> program & st_set(A)"
apply (unfold transient_def, auto)
done

lemma stable_transient_empty: "[| F \<in> stable(A); F \<in> transient(A) |] ==> A = 0"
by (simp add: stable_def constrains_def transient_def, fast)

lemma transient_strengthen: "[|F \<in> transient(A); B<=A|] ==> F \<in> transient(B)"
apply (simp add: transient_def st_set_def, clarify)
apply (blast intro!: rev_bexI)
done

lemma transientI:
"[|act \<in> Acts(F); A \<subseteq> domain(act); act``A \<subseteq> state-A;
    F \<in> program; st_set(A)|] ==> F \<in> transient(A)"
by (simp add: transient_def, blast)

lemma transientE:
     "[| F \<in> transient(A);
         !!act. [| act \<in> Acts(F);  A \<subseteq> domain(act); act``A \<subseteq> state-A|]==>P|]
      ==>P"
by (simp add: transient_def, blast)

lemma transient_state: "transient(state) = 0"
apply (simp add: transient_def)
apply (rule equalityI, auto)
apply (cut_tac F = x in Acts_type)
apply (simp add: Diff_cancel)
apply (auto intro: st0_in_state)
done

lemma transient_state2: "state<=B ==> transient(B) = 0"
apply (simp add: transient_def st_set_def)
apply (rule equalityI, auto)
apply (cut_tac F = x in Acts_type)
apply (subgoal_tac "B=state")
apply (auto intro: st0_in_state)
done

lemma transient_empty: "transient(0) = program"
by (auto simp add: transient_def)

declare transient_empty [simp] transient_state [simp] transient_state2 [simp]

(*** ensures ***)

lemma ensures_type: "A ensures B <=program"
by (simp add: ensures_def constrains_def, auto)

lemma ensuresI:
"[|F:(A-B) co (A \<union> B); F \<in> transient(A-B)|]==>F \<in> A ensures B"
apply (unfold ensures_def)
apply (auto simp add: transient_type [THEN subsetD])
done

(* Added by Sidi, from Misra's notes, Progress chapter, exercise 4 *)
lemma ensuresI2: "[| F \<in> A co A \<union> B; F \<in> transient(A) |] ==> F \<in> A ensures B"
apply (drule_tac B = "A-B" in constrains_weaken_L)
apply (drule_tac [2] B = "A-B" in transient_strengthen)
apply (auto simp add: ensures_def transient_type [THEN subsetD])
done

lemma ensuresD: "F \<in> A ensures B ==> F:(A-B) co (A \<union> B) & F \<in> transient (A-B)"
by (unfold ensures_def, auto)

lemma ensures_weaken_R: "[|F \<in> A ensures A'; A'<=B' |] ==> F \<in> A ensures B'"
apply (unfold ensures_def)
apply (blast intro: transient_strengthen constrains_weaken)
done

(*The L-version (precondition strengthening) fails, but we have this*)
lemma stable_ensures_Int:
     "[| F \<in> stable(C);  F \<in> A ensures B |] ==> F:(C \<inter> A) ensures (C \<inter> B)"

apply (unfold ensures_def)
apply (simp (no_asm) add: Int_Un_distrib [symmetric] Diff_Int_distrib [symmetric])
apply (blast intro: transient_strengthen stable_constrains_Int constrains_weaken)
done

lemma stable_transient_ensures: "[|F \<in> stable(A);  F \<in> transient(C); A<=B \<union> C|] ==> F \<in> A ensures B"
apply (frule stable_type [THEN subsetD])
apply (simp add: ensures_def stable_def)
apply (blast intro: transient_strengthen constrains_weaken)
done

lemma ensures_eq: "(A ensures B) = (A unless B) \<inter> transient (A-B)"
by (auto simp add: ensures_def unless_def)

lemma subset_imp_ensures: "[| F \<in> program; A<=B  |] ==> F \<in> A ensures B"
by (auto simp add: ensures_def constrains_def transient_def st_set_def)

(*** leadsTo ***)
lemmas leads_left = leads.dom_subset [THEN subsetD, THEN SigmaD1]
lemmas leads_right = leads.dom_subset [THEN subsetD, THEN SigmaD2]

lemma leadsTo_type: "A \<longmapsto> B \<subseteq> program"
by (unfold leadsTo_def, auto)

lemma leadsToD2:
"F \<in> A \<longmapsto> B ==> F \<in> program & st_set(A) & st_set(B)"
apply (unfold leadsTo_def st_set_def)
apply (blast dest: leads_left leads_right)
done

lemma leadsTo_Basis:
    "[|F \<in> A ensures B; st_set(A); st_set(B)|] ==> F \<in> A \<longmapsto> B"
apply (unfold leadsTo_def st_set_def)
apply (cut_tac ensures_type)
apply (auto intro: leads.Basis)
done
declare leadsTo_Basis [intro]

(* Added by Sidi, from Misra's notes, Progress chapter, exercise number 4 *)
(* [| F \<in> program; A<=B;  st_set(A); st_set(B) |] ==> A \<longmapsto> B *)
lemmas subset_imp_leadsTo = subset_imp_ensures [THEN leadsTo_Basis]

lemma leadsTo_Trans: "[|F \<in> A \<longmapsto> B;  F \<in> B \<longmapsto> C |]==>F \<in> A \<longmapsto> C"
apply (unfold leadsTo_def)
apply (auto intro: leads.Trans)
done

(* Better when used in association with leadsTo_weaken_R *)
lemma transient_imp_leadsTo: "F \<in> transient(A) ==> F \<in> A \<longmapsto> (state-A)"
apply (unfold transient_def)
apply (blast intro: ensuresI [THEN leadsTo_Basis] constrains_weaken transientI)
done

(*Useful with cancellation, disjunction*)
lemma leadsTo_Un_duplicate: "F \<in> A \<longmapsto> (A' \<union> A') ==> F \<in> A \<longmapsto> A'"
by simp

lemma leadsTo_Un_duplicate2:
     "F \<in> A \<longmapsto> (A' \<union> C \<union> C) ==> F \<in> A \<longmapsto> (A' \<union> C)"
by (simp add: Un_ac)

(*The Union introduction rule as we should have liked to state it*)
lemma leadsTo_Union:
    "[|!!A. A \<in> S ==> F \<in> A \<longmapsto> B; F \<in> program; st_set(B)|]
     ==> F \<in> \<Union>(S) \<longmapsto> B"
apply (unfold leadsTo_def st_set_def)
apply (blast intro: leads.Union dest: leads_left)
done

lemma leadsTo_Union_Int:
    "[|!!A. A \<in> S ==>F \<in> (A \<inter> C) \<longmapsto> B; F \<in> program; st_set(B)|]
     ==> F \<in> (\<Union>(S)Int C)\<longmapsto> B"
apply (unfold leadsTo_def st_set_def)
apply (simp only: Int_Union_Union)
apply (blast dest: leads_left intro: leads.Union)
done

lemma leadsTo_UN:
    "[| !!i. i \<in> I ==> F \<in> A(i) \<longmapsto> B; F \<in> program; st_set(B)|]
     ==> F:(\<Union>i \<in> I. A(i)) \<longmapsto> B"
apply (simp add: Int_Union_Union leadsTo_def st_set_def)
apply (blast dest: leads_left intro: leads.Union)
done

(* Binary union introduction rule *)
lemma leadsTo_Un:
     "[| F \<in> A \<longmapsto> C; F \<in> B \<longmapsto> C |] ==> F \<in> (A \<union> B) \<longmapsto> C"
apply (subst Un_eq_Union)
apply (blast intro: leadsTo_Union dest: leadsToD2)
done

lemma single_leadsTo_I:
    "[|!!x. x \<in> A==> F:{x} \<longmapsto> B; F \<in> program; st_set(B) |]
     ==> F \<in> A \<longmapsto> B"
apply (rule_tac b = A in UN_singleton [THEN subst])
apply (rule leadsTo_UN, auto)
done

lemma leadsTo_refl: "[| F \<in> program; st_set(A) |] ==> F \<in> A \<longmapsto> A"
by (blast intro: subset_imp_leadsTo)

lemma leadsTo_refl_iff: "F \<in> A \<longmapsto> A \<longleftrightarrow> F \<in> program & st_set(A)"
by (auto intro: leadsTo_refl dest: leadsToD2)

lemma empty_leadsTo: "F \<in> 0 \<longmapsto> B \<longleftrightarrow> (F \<in> program & st_set(B))"
by (auto intro: subset_imp_leadsTo dest: leadsToD2)
declare empty_leadsTo [iff]

lemma leadsTo_state: "F \<in> A \<longmapsto> state \<longleftrightarrow> (F \<in> program & st_set(A))"
by (auto intro: subset_imp_leadsTo dest: leadsToD2 st_setD)
declare leadsTo_state [iff]

lemma leadsTo_weaken_R: "[| F \<in> A \<longmapsto> A'; A'<=B'; st_set(B') |] ==> F \<in> A \<longmapsto> B'"
by (blast dest: leadsToD2 intro: subset_imp_leadsTo leadsTo_Trans)

lemma leadsTo_weaken_L: "[| F \<in> A \<longmapsto> A'; B<=A |] ==> F \<in> B \<longmapsto> A'"
apply (frule leadsToD2)
apply (blast intro: leadsTo_Trans subset_imp_leadsTo st_set_subset)
done

lemma leadsTo_weaken: "[| F \<in> A \<longmapsto> A'; B<=A; A'<=B'; st_set(B')|]==> F \<in> B \<longmapsto> B'"
apply (frule leadsToD2)
apply (blast intro: leadsTo_weaken_R leadsTo_weaken_L leadsTo_Trans leadsTo_refl)
done

(* This rule has a nicer conclusion *)
lemma transient_imp_leadsTo2: "[| F \<in> transient(A); state-A<=B; st_set(B)|] ==> F \<in> A \<longmapsto> B"
apply (frule transientD2)
apply (rule leadsTo_weaken_R)
apply (auto simp add: transient_imp_leadsTo)
done

(*Distributes over binary unions*)
lemma leadsTo_Un_distrib: "F:(A \<union> B) \<longmapsto> C  \<longleftrightarrow>  (F \<in> A \<longmapsto> C & F \<in> B \<longmapsto> C)"
by (blast intro: leadsTo_Un leadsTo_weaken_L)

lemma leadsTo_UN_distrib:
"(F:(\<Union>i \<in> I. A(i)) \<longmapsto> B)\<longleftrightarrow> ((\<forall>i \<in> I. F \<in> A(i) \<longmapsto> B) & F \<in> program & st_set(B))"
apply (blast dest: leadsToD2 intro: leadsTo_UN leadsTo_weaken_L)
done

lemma leadsTo_Union_distrib: "(F \<in> \<Union>(S) \<longmapsto> B) \<longleftrightarrow>  (\<forall>A \<in> S. F \<in> A \<longmapsto> B) & F \<in> program & st_set(B)"
by (blast dest: leadsToD2 intro: leadsTo_Union leadsTo_weaken_L)

text\<open>Set difference: maybe combine with \<open>leadsTo_weaken_L\<close>??\<close>
lemma leadsTo_Diff:
     "[| F: (A-B) \<longmapsto> C; F \<in> B \<longmapsto> C; st_set(C) |]
      ==> F \<in> A \<longmapsto> C"
by (blast intro: leadsTo_Un leadsTo_weaken dest: leadsToD2)

lemma leadsTo_UN_UN:
    "[|!!i. i \<in> I ==> F \<in> A(i) \<longmapsto> A'(i); F \<in> program |]
     ==> F: (\<Union>i \<in> I. A(i)) \<longmapsto> (\<Union>i \<in> I. A'(i))"
apply (rule leadsTo_Union)
apply (auto intro: leadsTo_weaken_R dest: leadsToD2)
done

(*Binary union version*)
lemma leadsTo_Un_Un: "[| F \<in> A \<longmapsto> A'; F \<in> B \<longmapsto> B' |] ==> F \<in> (A \<union> B) \<longmapsto> (A' \<union> B')"
apply (subgoal_tac "st_set (A) & st_set (A') & st_set (B) & st_set (B') ")
prefer 2 apply (blast dest: leadsToD2)
apply (blast intro: leadsTo_Un leadsTo_weaken_R)
done

(** The cancellation law **)
lemma leadsTo_cancel2: "[|F \<in> A \<longmapsto> (A' \<union> B); F \<in> B \<longmapsto> B'|] ==> F \<in> A \<longmapsto> (A' \<union> B')"
apply (subgoal_tac "st_set (A) & st_set (A') & st_set (B) & st_set (B') &F \<in> program")
prefer 2 apply (blast dest: leadsToD2)
apply (blast intro: leadsTo_Trans leadsTo_Un_Un leadsTo_refl)
done

lemma leadsTo_cancel_Diff2: "[|F \<in> A \<longmapsto> (A' \<union> B); F \<in> (B-A') \<longmapsto> B'|]==> F \<in> A \<longmapsto> (A' \<union> B')"
apply (rule leadsTo_cancel2)
prefer 2 apply assumption
apply (blast dest: leadsToD2 intro: leadsTo_weaken_R)
done

lemma leadsTo_cancel1: "[| F \<in> A \<longmapsto> (B \<union> A'); F \<in> B \<longmapsto> B' |] ==> F \<in> A \<longmapsto> (B' \<union> A')"
apply (simp add: Un_commute)
apply (blast intro!: leadsTo_cancel2)
done

lemma leadsTo_cancel_Diff1:
     "[|F \<in> A \<longmapsto> (B \<union> A'); F: (B-A') \<longmapsto> B'|]==> F \<in> A \<longmapsto> (B' \<union> A')"
apply (rule leadsTo_cancel1)
prefer 2 apply assumption
apply (blast intro: leadsTo_weaken_R dest: leadsToD2)
done

(*The INDUCTION rule as we should have liked to state it*)
lemma leadsTo_induct:
  assumes major: "F \<in> za \<longmapsto> zb"
      and basis: "!!A B. [|F \<in> A ensures B; st_set(A); st_set(B)|] ==> P(A,B)"
      and trans: "!!A B C. [| F \<in> A \<longmapsto> B; P(A, B);
                              F \<in> B \<longmapsto> C; P(B, C) |] ==> P(A,C)"
      and union: "!!B S. [| \<forall>A \<in> S. F \<in> A \<longmapsto> B; \<forall>A \<in> S. P(A,B);
                           st_set(B); \<forall>A \<in> S. st_set(A)|] ==> P(\<Union>(S), B)"
  shows "P(za, zb)"
apply (cut_tac major)
apply (unfold leadsTo_def, clarify)
apply (erule leads.induct)
  apply (blast intro: basis [unfolded st_set_def])
 apply (blast intro: trans [unfolded leadsTo_def])
apply (force intro: union [unfolded st_set_def leadsTo_def])
done

(* Added by Sidi, an induction rule without ensures *)
lemma leadsTo_induct2:
  assumes major: "F \<in> za \<longmapsto> zb"
      and basis1: "!!A B. [| A<=B; st_set(B) |] ==> P(A, B)"
      and basis2: "!!A B. [| F \<in> A co A \<union> B; F \<in> transient(A); st_set(B) |]
                          ==> P(A, B)"
      and trans: "!!A B C. [| F \<in> A \<longmapsto> B; P(A, B);
                              F \<in> B \<longmapsto> C; P(B, C) |] ==> P(A,C)"
      and union: "!!B S. [| \<forall>A \<in> S. F \<in> A \<longmapsto> B; \<forall>A \<in> S. P(A,B);
                           st_set(B); \<forall>A \<in> S. st_set(A)|] ==> P(\<Union>(S), B)"
  shows "P(za, zb)"
apply (cut_tac major)
apply (erule leadsTo_induct)
apply (auto intro: trans union)
apply (simp add: ensures_def, clarify)
apply (frule constrainsD2)
apply (drule_tac B' = " (A-B) \<union> B" in constrains_weaken_R)
apply blast
apply (frule ensuresI2 [THEN leadsTo_Basis])
apply (drule_tac [4] basis2, simp_all)
apply (frule_tac A1 = A and B = B in Int_lower2 [THEN basis1])
apply (subgoal_tac "A=\<Union>({A - B, A \<inter> B}) ")
prefer 2 apply blast
apply (erule ssubst)
apply (rule union)
apply (auto intro: subset_imp_leadsTo)
done

(** Variant induction rule: on the preconditions for B **)
(*Lemma is the weak version: can't see how to do it in one step*)
lemma leadsTo_induct_pre_aux:
  "[| F \<in> za \<longmapsto> zb;
      P(zb);
      !!A B. [| F \<in> A ensures B;  P(B); st_set(A); st_set(B) |] ==> P(A);
      !!S. [| \<forall>A \<in> S. P(A); \<forall>A \<in> S. st_set(A) |] ==> P(\<Union>(S))
   |] ==> P(za)"
txt\<open>by induction on this formula\<close>
apply (subgoal_tac "P (zb) \<longrightarrow> P (za) ")
txt\<open>now solve first subgoal: this formula is sufficient\<close>
apply (blast intro: leadsTo_refl)
apply (erule leadsTo_induct)
apply (blast+)
done

lemma leadsTo_induct_pre:
  "[| F \<in> za \<longmapsto> zb;
      P(zb);
      !!A B. [| F \<in> A ensures B;  F \<in> B \<longmapsto> zb;  P(B); st_set(A) |] ==> P(A);
      !!S. \<forall>A \<in> S. F \<in> A \<longmapsto> zb & P(A) & st_set(A) ==> P(\<Union>(S))
   |] ==> P(za)"
apply (subgoal_tac " (F \<in> za \<longmapsto> zb) & P (za) ")
apply (erule conjunct2)
apply (frule leadsToD2)
apply (erule leadsTo_induct_pre_aux)
prefer 3 apply (blast dest: leadsToD2 intro: leadsTo_Union)
prefer 2 apply (blast intro: leadsTo_Trans leadsTo_Basis)
apply (blast intro: leadsTo_refl)
done

(** The impossibility law **)
lemma leadsTo_empty:
   "F \<in> A \<longmapsto> 0 ==> A=0"
apply (erule leadsTo_induct_pre)
apply (auto simp add: ensures_def constrains_def transient_def st_set_def)
apply (drule bspec, assumption)+
apply blast
done
declare leadsTo_empty [simp]

subsection\<open>PSP: Progress-Safety-Progress\<close>

text\<open>Special case of PSP: Misra's "stable conjunction"\<close>

lemma psp_stable:
   "[| F \<in> A \<longmapsto> A'; F \<in> stable(B) |] ==> F:(A \<inter> B) \<longmapsto> (A' \<inter> B)"
apply (unfold stable_def)
apply (frule leadsToD2)
apply (erule leadsTo_induct)
prefer 3 apply (blast intro: leadsTo_Union_Int)
prefer 2 apply (blast intro: leadsTo_Trans)
apply (rule leadsTo_Basis)
apply (simp add: ensures_def Diff_Int_distrib2 [symmetric] Int_Un_distrib2 [symmetric])
apply (auto intro: transient_strengthen constrains_Int)
done

lemma psp_stable2: "[|F \<in> A \<longmapsto> A'; F \<in> stable(B) |]==>F: (B \<inter> A) \<longmapsto> (B \<inter> A')"
apply (simp (no_asm_simp) add: psp_stable Int_ac)
done

lemma psp_ensures:
"[| F \<in> A ensures A'; F \<in> B co B' |]==> F: (A \<inter> B') ensures ((A' \<inter> B) \<union> (B' - B))"
apply (unfold ensures_def constrains_def st_set_def)
(*speeds up the proof*)
apply clarify
apply (blast intro: transient_strengthen)
done

lemma psp:
"[|F \<in> A \<longmapsto> A'; F \<in> B co B'; st_set(B')|]==> F:(A \<inter> B') \<longmapsto> ((A' \<inter> B) \<union> (B' - B))"
apply (subgoal_tac "F \<in> program & st_set (A) & st_set (A') & st_set (B) ")
prefer 2 apply (blast dest!: constrainsD2 leadsToD2)
apply (erule leadsTo_induct)
prefer 3 apply (blast intro: leadsTo_Union_Int)
 txt\<open>Basis case\<close>
 apply (blast intro: psp_ensures leadsTo_Basis)
txt\<open>Transitivity case has a delicate argument involving "cancellation"\<close>
apply (rule leadsTo_Un_duplicate2)
apply (erule leadsTo_cancel_Diff1)
apply (simp add: Int_Diff Diff_triv)
apply (blast intro: leadsTo_weaken_L dest: constrains_imp_subset)
done

lemma psp2: "[| F \<in> A \<longmapsto> A'; F \<in> B co B'; st_set(B') |]
    ==> F \<in> (B' \<inter> A) \<longmapsto> ((B \<inter> A') \<union> (B' - B))"
by (simp (no_asm_simp) add: psp Int_ac)

lemma psp_unless:
   "[| F \<in> A \<longmapsto> A';  F \<in> B unless B'; st_set(B); st_set(B') |]
    ==> F \<in> (A \<inter> B) \<longmapsto> ((A' \<inter> B) \<union> B')"
apply (unfold unless_def)
apply (subgoal_tac "st_set (A) &st_set (A') ")
prefer 2 apply (blast dest: leadsToD2)
apply (drule psp, assumption, blast)
apply (blast intro: leadsTo_weaken)
done

subsection\<open>Proving the induction rules\<close>

(** The most general rule \<in> r is any wf relation; f is any variant function **)
lemma leadsTo_wf_induct_aux: "[| wf(r);
         m \<in> I;
         field(r)<=I;
         F \<in> program; st_set(B);
         \<forall>m \<in> I. F \<in> (A \<inter> f-``{m}) \<longmapsto>
                    ((A \<inter> f-``(converse(r)``{m})) \<union> B) |]
      ==> F \<in> (A \<inter> f-``{m}) \<longmapsto> B"
apply (erule_tac a = m in wf_induct2, simp_all)
apply (subgoal_tac "F \<in> (A \<inter> (f-`` (converse (r) ``{x}))) \<longmapsto> B")
 apply (blast intro: leadsTo_cancel1 leadsTo_Un_duplicate)
apply (subst vimage_eq_UN)
apply (simp del: UN_simps add: Int_UN_distrib)
apply (auto intro: leadsTo_UN simp del: UN_simps simp add: Int_UN_distrib)
done

(** Meta or object quantifier ? **)
lemma leadsTo_wf_induct: "[| wf(r);
         field(r)<=I;
         A<=f-``I;
         F \<in> program; st_set(A); st_set(B);
         \<forall>m \<in> I. F \<in> (A \<inter> f-``{m}) \<longmapsto>
                    ((A \<inter> f-``(converse(r)``{m})) \<union> B) |]
      ==> F \<in> A \<longmapsto> B"
apply (rule_tac b = A in subst)
 defer 1
 apply (rule_tac I = I in leadsTo_UN)
 apply (erule_tac I = I in leadsTo_wf_induct_aux, assumption+, best)
done

lemma nat_measure_field: "field(measure(nat, %x. x)) = nat"
apply (unfold field_def)
apply (simp add: measure_def)
apply (rule equalityI, force, clarify)
apply (erule_tac V = "x\<notin>range (y)" for y in thin_rl)
apply (erule nat_induct)
apply (rule_tac [2] b = "succ (succ (xa))" in domainI)
apply (rule_tac b = "succ (0) " in domainI)
apply simp_all
done

lemma Image_inverse_lessThan: "k<A ==> measure(A, %x. x) -`` {k} = k"
apply (rule equalityI)
apply (auto simp add: measure_def)
apply (blast intro: ltD)
apply (rule vimageI)
prefer 2 apply blast
apply (simp add: lt_Ord lt_Ord2 Ord_mem_iff_lt)
apply (blast intro: lt_trans)
done

(*Alternative proof is via the lemma F \<in> (A \<inter> f-`(lessThan m)) \<longmapsto> B*)
lemma lessThan_induct:
 "[| A<=f-``nat;
     F \<in> program; st_set(A); st_set(B);
     \<forall>m \<in> nat. F:(A \<inter> f-``{m}) \<longmapsto> ((A \<inter> f -`` m) \<union> B) |]
      ==> F \<in> A \<longmapsto> B"
apply (rule_tac A1 = nat and f1 = "%x. x" in wf_measure [THEN leadsTo_wf_induct])
apply (simp_all add: nat_measure_field)
apply (simp add: ltI Image_inverse_lessThan vimage_def [symmetric])
done

(*** wlt ****)

(*Misra's property W3*)
lemma wlt_type: "wlt(F,B) <=state"
by (unfold wlt_def, auto)

lemma wlt_st_set: "st_set(wlt(F, B))"
apply (unfold st_set_def)
apply (rule wlt_type)
done
declare wlt_st_set [iff]

lemma wlt_leadsTo_iff: "F \<in> wlt(F, B) \<longmapsto> B \<longleftrightarrow> (F \<in> program & st_set(B))"
apply (unfold wlt_def)
apply (blast dest: leadsToD2 intro!: leadsTo_Union)
done

(* [| F \<in> program;  st_set(B) |] ==> F \<in> wlt(F, B) \<longmapsto> B  *)
lemmas wlt_leadsTo = conjI [THEN wlt_leadsTo_iff [THEN iffD2]]

lemma leadsTo_subset: "F \<in> A \<longmapsto> B ==> A \<subseteq> wlt(F, B)"
apply (unfold wlt_def)
apply (frule leadsToD2)
apply (auto simp add: st_set_def)
done

(*Misra's property W2*)
lemma leadsTo_eq_subset_wlt: "F \<in> A \<longmapsto> B \<longleftrightarrow> (A \<subseteq> wlt(F,B) & F \<in> program & st_set(B))"
apply auto
apply (blast dest: leadsToD2 leadsTo_subset intro: leadsTo_weaken_L wlt_leadsTo)+
done

(*Misra's property W4*)
lemma wlt_increasing: "[| F \<in> program; st_set(B) |] ==> B \<subseteq> wlt(F,B)"
apply (rule leadsTo_subset)
apply (simp (no_asm_simp) add: leadsTo_eq_subset_wlt [THEN iff_sym] subset_imp_leadsTo)
done

(*Used in the Trans case below*)
lemma leadsTo_123_aux:
   "[| B \<subseteq> A2;
       F \<in> (A1 - B) co (A1 \<union> B);
       F \<in> (A2 - C) co (A2 \<union> C) |]
    ==> F \<in> (A1 \<union> A2 - C) co (A1 \<union> A2 \<union> C)"
apply (unfold constrains_def st_set_def, blast)
done

(*Lemma (1,2,3) of Misra's draft book, Chapter 4, "Progress"*)
(* slightly different from the HOL one \<in> B here is bounded *)
lemma leadsTo_123: "F \<in> A \<longmapsto> A'
      ==> \<exists>B \<in> Pow(state). A<=B & F \<in> B \<longmapsto> A' & F \<in> (B-A') co (B \<union> A')"
apply (frule leadsToD2)
apply (erule leadsTo_induct)
  txt\<open>Basis\<close>
  apply (blast dest: ensuresD constrainsD2 st_setD)
 txt\<open>Trans\<close>
 apply clarify
 apply (rule_tac x = "Ba \<union> Bb" in bexI)
 apply (blast intro: leadsTo_123_aux leadsTo_Un_Un leadsTo_cancel1 leadsTo_Un_duplicate, blast)
txt\<open>Union\<close>
apply (clarify dest!: ball_conj_distrib [THEN iffD1])
apply (subgoal_tac "\<exists>y. y \<in> Pi (S, %A. {Ba \<in> Pow (state) . A<=Ba & F \<in> Ba \<longmapsto> B & F \<in> Ba - B co Ba \<union> B}) ")
defer 1
apply (rule AC_ball_Pi, safe)
apply (rotate_tac 1)
apply (drule_tac x = x in bspec, blast, blast)
apply (rule_tac x = "\<Union>A \<in> S. y`A" in bexI, safe)
apply (rule_tac [3] I1 = S in constrains_UN [THEN constrains_weaken])
apply (rule_tac [2] leadsTo_Union)
prefer 5 apply (blast dest!: apply_type, simp_all)
apply (force dest!: apply_type)+
done

(*Misra's property W5*)
lemma wlt_constrains_wlt: "[| F \<in> program; st_set(B) |] ==>F \<in> (wlt(F, B) - B) co (wlt(F,B))"
apply (cut_tac F = F in wlt_leadsTo [THEN leadsTo_123], assumption, blast)
apply clarify
apply (subgoal_tac "Ba = wlt (F,B) ")
prefer 2 apply (blast dest: leadsTo_eq_subset_wlt [THEN iffD1], clarify)
apply (simp add: wlt_increasing [THEN subset_Un_iff2 [THEN iffD1]])
done

subsection\<open>Completion: Binary and General Finite versions\<close>

lemma completion_aux: "[| W = wlt(F, (B' \<union> C));
       F \<in> A \<longmapsto> (A' \<union> C);  F \<in> A' co (A' \<union> C);
       F \<in> B \<longmapsto> (B' \<union> C);  F \<in> B' co (B' \<union> C) |]
    ==> F \<in> (A \<inter> B) \<longmapsto> ((A' \<inter> B') \<union> C)"
apply (subgoal_tac "st_set (C) &st_set (W) &st_set (W-C) &st_set (A') &st_set (A) & st_set (B) & st_set (B') & F \<in> program")
 prefer 2
 apply simp
 apply (blast dest!: leadsToD2)
apply (subgoal_tac "F \<in> (W-C) co (W \<union> B' \<union> C) ")
 prefer 2
 apply (blast intro!: constrains_weaken [OF constrains_Un [OF _ wlt_constrains_wlt]])
apply (subgoal_tac "F \<in> (W-C) co W")
 prefer 2
 apply (simp add: wlt_increasing [THEN subset_Un_iff2 [THEN iffD1]] Un_assoc)
apply (subgoal_tac "F \<in> (A \<inter> W - C) \<longmapsto> (A' \<inter> W \<union> C) ")
 prefer 2 apply (blast intro: wlt_leadsTo psp [THEN leadsTo_weaken])
(** step 13 **)
apply (subgoal_tac "F \<in> (A' \<inter> W \<union> C) \<longmapsto> (A' \<inter> B' \<union> C) ")
apply (drule leadsTo_Diff)
apply (blast intro: subset_imp_leadsTo dest: leadsToD2 constrainsD2)
apply (force simp add: st_set_def)
apply (subgoal_tac "A \<inter> B \<subseteq> A \<inter> W")
prefer 2 apply (blast dest!: leadsTo_subset intro!: subset_refl [THEN Int_mono])
apply (blast intro: leadsTo_Trans subset_imp_leadsTo)
txt\<open>last subgoal\<close>
apply (rule_tac leadsTo_Un_duplicate2)
apply (rule_tac leadsTo_Un_Un)
 prefer 2 apply (blast intro: leadsTo_refl)
apply (rule_tac A'1 = "B' \<union> C" in wlt_leadsTo[THEN psp2, THEN leadsTo_weaken])
apply blast+
done

lemmas completion = refl [THEN completion_aux]

lemma finite_completion_aux:
     "[| I \<in> Fin(X); F \<in> program; st_set(C) |] ==>
       (\<forall>i \<in> I. F \<in> (A(i)) \<longmapsto> (A'(i) \<union> C)) \<longrightarrow>
                     (\<forall>i \<in> I. F \<in> (A'(i)) co (A'(i) \<union> C)) \<longrightarrow>
                   F \<in> (\<Inter>i \<in> I. A(i)) \<longmapsto> ((\<Inter>i \<in> I. A'(i)) \<union> C)"
apply (erule Fin_induct)
apply (auto simp add: Inter_0)
apply (rule completion)
apply (auto simp del: INT_simps simp add: INT_extend_simps)
apply (blast intro: constrains_INT)
done

lemma finite_completion:
     "[| I \<in> Fin(X);
         !!i. i \<in> I ==> F \<in> A(i) \<longmapsto> (A'(i) \<union> C);
         !!i. i \<in> I ==> F \<in> A'(i) co (A'(i) \<union> C); F \<in> program; st_set(C)|]
      ==> F \<in> (\<Inter>i \<in> I. A(i)) \<longmapsto> ((\<Inter>i \<in> I. A'(i)) \<union> C)"
by (blast intro: finite_completion_aux [THEN mp, THEN mp])

lemma stable_completion:
     "[| F \<in> A \<longmapsto> A';  F \<in> stable(A');
         F \<in> B \<longmapsto> B';  F \<in> stable(B') |]
    ==> F \<in> (A \<inter> B) \<longmapsto> (A' \<inter> B')"
apply (unfold stable_def)
apply (rule_tac C1 = 0 in completion [THEN leadsTo_weaken_R], simp+)
apply (blast dest: leadsToD2)
done

lemma finite_stable_completion:
     "[| I \<in> Fin(X);
         (!!i. i \<in> I ==> F \<in> A(i) \<longmapsto> A'(i));
         (!!i. i \<in> I ==> F \<in> stable(A'(i)));  F \<in> program |]
      ==> F \<in> (\<Inter>i \<in> I. A(i)) \<longmapsto> (\<Inter>i \<in> I. A'(i))"
apply (unfold stable_def)
apply (subgoal_tac "st_set (\<Inter>i \<in> I. A' (i))")
prefer 2 apply (blast dest: leadsToD2)
apply (rule_tac C1 = 0 in finite_completion [THEN leadsTo_weaken_R], auto)
done

end


theory RoseTree
  imports Main "$HIPSTER_HOME/IsaHipster"
    "~~/src/HOL/Library/BNF_Corec"
begin
(* Set Hipster tactic *)
setup Tactic_Data.set_sledgehammer_coinduct
setup Misc_Data.set_noisy
setup Misc_Data.set_time
setup Misc_Data.set_hammer_timeout_medium
setup Tactic_Data.set_no_proof
codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

(* Finitely branching Rose tree of pot infinite depth from Isabelle tutorial on corecursion. *)
codatatype 'a Tree =
  Node (lab: 'a) (sub: "'a Tree list")

(* Note: In the co-induction tutorial, this function is defined using a type-class for plus.
This seem to cause a weird XML-error in PIDE/xml.ML so something goes wrong in translation.
Presumably due to TIP not really supporting type-classes. *)
primcorec tsum :: "nat Tree \<Rightarrow> nat Tree \<Rightarrow> nat Tree"
where "tsum t u = Node (lab t + lab u) (map (\<lambda>(t', u'). tsum t' u') (zip (sub t) (sub u)))"
(*Bug? Error when generating observer functions. *)

primcorec mirror :: "'a Tree \<Rightarrow> 'a Tree"
  where "mirror t = Node (lab t) (rev (sub t))"
(* thm Tree.coinduct_strong *)

primcorec tmap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Tree \<Rightarrow> 'b Tree"
  where "tmap f t = Node (f (lab t)) (map (tmap f) (sub t))"

cohipster mirror (* 29.345s elapsed time, 7.060s cpu time, 1.694s GC time *)
lemma lemma_a [thy_expl]: "mirror (mirror y) = y"
  by (simp add: Tree.expand)

cohipster mirror tsum (*597.303s elapsed time, 83.481s cpu time, 9.110s GC time *)
lemma lemma_aa [thy_expl]: "tsum (mirror x) (mirror x) = mirror (tsum x x)"
  by (metis (no_types, lifting) mirror.code mirror.simps(1) mirror.simps(2) rev_map tsum.ctr tsum.simps(1) tsum.simps(2) zip_rev)

lemma unknown [thy_expl]: "tsum y x = tsum x y"
  oops

lemma unknown [thy_expl]: "tsum (tsum x y) z = tsum x (tsum y z)"
  oops

lemma unknown [thy_expl]: "mirror (tsum x (mirror x)) = tsum x (mirror x)"
  oops

lemma unknown [thy_expl]: "mirror (tsum x (mirror (tsum x x))) = tsum x (tsum x (mirror x))"
  oops

lemma unknown [thy_expl]: "mirror (tsum x (tsum x (mirror x))) = tsum x (mirror (tsum x x))"
  oops

lemma unknown [thy_expl]: "tsum (mirror x) (mirror (tsum x x)) = mirror (tsum x (tsum x x))"
  oops

cohipster mirror tmap (* 102.723s elapsed time, 23.739s cpu time, 2.948s GC time*)
lemma lemma_ab [thy_expl]: "tmap z (mirror x2) = mirror (tmap z x2)"
  by (simp add: mirror.code rev_map tmap.code)

(* This is obviously false, but if we call normal hipster it is suggested. Cause error in
coinduction tactic, but counter-example easily found by nitpick *)
ML\<open>
val t = @{term "Trueprop(sub z @ sub y = sub y @ sub z)"};
val t = @{term "Product_Type.Pair 1 2"};

val def_params = Nitpick_Commands.default_params @{theory} [];

fun goal_prop str ctxt =
  let val prop = Syntax.read_prop ctxt str
  in Proof.theorem NONE (K I) [[(prop, [])]] ctxt
  end;
val state = goal_prop "sub z @ sub y = sub y @ sub z" @{context} ;
val (res, l) = Nitpick.pick_nits_in_subgoal state def_params Nitpick.Normal 1 1;

fun nitpick_conj ctxt conj_str =
  let
    val state = goal_prop conj_str ctxt
    val thy = Proof.theory_of state
    val def_params = Nitpick_Commands.default_params thy [];
    val (res, _) = Nitpick.pick_nits_in_subgoal state def_params Nitpick.Normal 1 1;
  in
    (res = Nitpick.genuineN)
  end
(*val i = 0;
val n = 0;
val step = 0;
val state = Proof.init @{context};
val (answer, mystery_list) = Nitpick.pick_nits_in_term state def_params Nitpick.Normal 0 0 0 [] [] [] t;

 val genuine = (Nitpick.genuineN = answer); *)
\<close>

end


theory Lappend
  imports Main
  "~~/src/HOL/Library/Simps_Case_Conv"
  "$HIPSTER_HOME/IsaHipster"

begin
setup Tactic_Data.set_sledgehammer_coinduct
setup Misc_Data.set_noisy

codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

primcorec lappend :: "'a Llist \<Rightarrow> 'a Llist \<Rightarrow> 'a Llist" where
"lnull xs \<Longrightarrow> lnull ys \<Longrightarrow> lnull (lappend xs ys)"
| "lhd (lappend xs ys) = lhd (if lnull xs then ys else xs)"
| "ltl (lappend xs ys) = (if lnull xs then ltl ys else lappend (ltl xs) ys)"

simps_of_case lappend_simps: lappend.code
cohipster lappend
lemma lemma_a [thy_expl]: "lappend LNil y = y"
  by (simp add: lappend_simps lnull_def)

lemma lemma_aa [thy_expl]: "ltl (lappend y y) = lappend (ltl y) y"
by (metis Llist.sel(2) lappend.ctr(1) lappend.simps(4) lnull_def)

lemma lemma_ab [thy_expl]: "lappend (LCons y z) x2 = LCons y (lappend z x2)"
  by (simp add: lappend_simps)

lemma lemma_ac [thy_expl]: "ltl (lappend y (ltl y)) = lappend (ltl y) (ltl y)"
  by (metis Llist.sel(2) lappend.ctr(1) lappend.simps(4) lnull_def)

lemma lemma_ad [thy_expl]: "ltl (lappend y (ltl (ltl y))) = lappend (ltl y) (ltl (ltl y))"
by (metis Llist.sel(2) lappend.ctr(1) lappend.simps(4) lnull_def)

lemma lemma_ae [thy_expl]: "ltl (lappend y (ltl (ltl (ltl y)))) = lappend (ltl y) (ltl (ltl (ltl y)))"
  by (metis Llist.sel(2) lappend.ctr(1) lappend.simps(4) lnull_def)

lemma unknown [thy_expl]: "lappend y LNil = y"
  oops

lemma unknown [thy_expl]: "lappend (lappend y z) x2 = lappend y (lappend z x2)"
  oops

lemma unknown [thy_expl]: "ltl (lappend z (lappend y z)) = lappend (ltl (lappend z y)) z"
oops

lemma unknown [thy_expl]: "ltl (lappend y (lappend z z)) = lappend (ltl (lappend y z)) z"
  oops

lemma unknown [thy_expl]: "ltl (lappend z (lappend y (ltl z))) = lappend (ltl (lappend z y)) (ltl z)"
  oops

lemma unknown [thy_expl]: "ltl (lappend y (lappend z (ltl z))) = lappend (ltl (lappend y z)) (ltl z)"
  oops

lemma unknown [thy_expl]: "ltl (lappend y (lappend (ltl y) z)) = lappend (ltl y) (ltl (lappend y z))"
  oops

(*lemma thingy: "ltl (lappend z (lappend y z)) = lappend (ltl (lappend z y)) z"
  apply(coinduction arbitrary: y z rule: Llist.coinduct_strong)
  apply simp*)

end


theory ConcreteSemantics9_1_Ex2
  imports Main "~~/src/HOL/IMP/Types"
begin

fun atyp :: "tyenv \<Rightarrow> aexp \<Rightarrow> ty "
where
"atyp \<Gamma> (Ic i) = Ity" |
"atyp \<Gamma> (Rc r) = Rty" |
"atyp \<Gamma> (V x) = \<Gamma> x" |
"atyp \<Gamma> (Plus a1 a2) =
  (case (atyp \<Gamma> a1, atyp \<Gamma> a2)of
  (Ity, Ity) \<Rightarrow> Ity |
  (_, _) \<Rightarrow> Rty
)"

fun aval :: "aexp => state => val" where
"aval (Ic i) s = (Iv i)" |
"aval (Rc r) s = (Rv r)" |
"aval (V x) s = s x" |
"aval (Plus a1 a2) s =
  (case (aval a1 s, aval a2 s) of
    (Iv i1, Iv i2) \<Rightarrow> Iv(i1+i2) |
    (Iv i1, Rv r2) \<Rightarrow> Rv(real_of_int(i1)+r2) |
    (Rv r1, Iv i2) \<Rightarrow> Rv(r1+real_of_int(i2)) |
    (Rv r1, Rv r2) \<Rightarrow> Rv(r1+r2)
)"

(*
lemma "atyp \<Gamma> a1 = type (aval a1 s) \<Longrightarrow>
       atyp \<Gamma> a2 = type (aval a2 s) \<Longrightarrow>
       \<Gamma> \<turnstile> s \<Longrightarrow>
       (case type (aval a1 s) of Ity \<Rightarrow> case type (aval a2 s) of Ity \<Rightarrow> Ity | Rty \<Rightarrow> Rty | Rty \<Rightarrow> Rty) =
       type
        (case aval a1 s of Iv i1 \<Rightarrow> case aval a2 s of Iv i2 \<Rightarrow> Iv (i1 + i2) | Rv r2 \<Rightarrow> Rv (real_of_int i1 + r2)
         | Rv r1 \<Rightarrow> case aval a2 s of Iv i2 \<Rightarrow> Rv (r1 + real_of_int i2) | Rv r2 \<Rightarrow> Rv (r1 + r2))"
  sledgehammer*)

theorem "\<Gamma> \<turnstile> s \<Longrightarrow> atyp \<Gamma> a = type (aval a s)"
  apply(induction a)
     apply auto
   apply (simp add: styping_def)
  by (smt ty.exhaust ty.simps(3) ty.simps(4) type_eq_Ity type_eq_Rty val.simps(5) val.simps(6))

end


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

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

fun takeWhile :: "('a => bool) => 'a list => 'a list" where
"takeWhile x (nil2) = nil2"
| "takeWhile x (cons2 z xs) =
     (if x z then cons2 z (takeWhile x xs) else nil2)"

theorem property0 :
  "((takeWhile (% (x :: 'a) => True) xs) = xs)"
  oops

end