(* Title: Resumption.thy
  Author: Andreas Lochbihler, ETH Zurich *)

section \<open>The resumption-error monad\<close>

theory Resumption
imports
  Misc_CryptHOL
  Partial_Function_Set
begin

codatatype (results: 'a, outputs: 'out, 'in) resumption
  = Done (result: "'a option")
  | Pause ("output": 'out) (resume: "'in \<Rightarrow> ('a, 'out, 'in) resumption")
where
  "resume (Done a) = (\<lambda>inp. Done None)"

code_datatype Done Pause

primcorec bind_resumption ::
  "('a, 'out, 'in) resumption
     \<Rightarrow> ('a \<Rightarrow> ('b, 'out, 'in) resumption) \<Rightarrow> ('b, 'out, 'in) resumption"
where
  "\<lbrakk> is_Done x; result x \<noteq> None \<longrightarrow> is_Done (f (the (result x))) \<rbrakk> \<Longrightarrow> is_Done (bind_resumption x f)"
| "result (bind_resumption x f) = result x \<bind> result \<circ> f"
| "output (bind_resumption x f) = (if is_Done x then output (f (the (result x))) else output x)"
| "resume (bind_resumption x f) = (\<lambda>inp. if is_Done x then resume (f (the (result x))) inp else bind_resumption (resume x inp) f)"

declare bind_resumption.sel [simp del]

adhoc_overloading Monad_Syntax.bind bind_resumption

lemma is_Done_bind_resumption [simp]:
  "is_Done (x \<bind> f) \<longleftrightarrow> is_Done x \<and> (result x \<noteq> None \<longrightarrow> is_Done (f (the (result x))))"
by(simp add: bind_resumption_def)

lemma result_bind_resumption [simp]:
  "is_Done (x \<bind> f) \<Longrightarrow> result (x \<bind> f) = result x \<bind> result \<circ> f"
by(simp add: bind_resumption_def)

lemma output_bind_resumption [simp]:
  "\<not> is_Done (x \<bind> f) \<Longrightarrow> output (x \<bind> f) = (if is_Done x then output (f (the (result x))) else output x)"
by(simp add: bind_resumption_def)

lemma resume_bind_resumption [simp]:
  "\<not> is_Done (x \<bind> f) \<Longrightarrow>
  resume (x \<bind> f) =
  (if is_Done x then resume (f (the (result x)))
   else (\<lambda>inp. resume x inp \<bind> f))"
by(auto simp add: bind_resumption_def)

definition DONE :: "'a \<Rightarrow> ('a, 'out, 'in) resumption"
where "DONE = Done \<circ> Some"

definition ABORT :: "('a, 'out, 'in) resumption"
where "ABORT = Done None"

lemma resume_ABORT [simp]:
  "resume (Done r) = (\<lambda>inp. ABORT)"
by(simp add: ABORT_def)

declare resumption.sel(3)[simp del]

lemma results_DONE [simp]: "results (DONE x) = {x}"
by(simp add: DONE_def)

lemma results_ABORT [simp]: "results ABORT = {}"
by(simp add: ABORT_def)

lemma outputs_ABORT [simp]: "outputs ABORT = {}"
by(simp add: ABORT_def)

lemma outputs_DONE [simp]: "outputs (DONE x) = {}"
by(simp add: DONE_def)

lemma is_Done_cases [cases pred]:
  assumes "is_Done r"
  obtains (DONE) x where "r = DONE x" | (ABORT) "r = ABORT"
using assms by(cases r) auto

lemma not_is_Done_conv_Pause: "\<not> is_Done r \<longleftrightarrow> (\<exists>out c. r = Pause out c)"
by(cases r) auto

lemma Done_bind [code]:
  "Done a \<bind> f = (case a of None \<Rightarrow> Done None | Some a \<Rightarrow> f a)"
by(rule resumption.expand)(auto split: option.split)

lemma DONE_bind [simp]:
  "DONE a \<bind> f = f a"
by(simp add: DONE_def Done_bind)

lemma bind_resumption_Pause [simp, code]: fixes cont shows
  "Pause out cont \<bind> f
  = Pause out (\<lambda>inp. cont inp \<bind> f)"
by(rule resumption.expand)(simp_all)

lemma bind_DONE [simp]:
  "x \<bind> DONE = x"
by(coinduction arbitrary: x)(auto simp add: split_beta o_def)

lemma bind_bind_resumption:
  fixes r :: "('a, 'in, 'out) resumption"
  shows "(r \<bind> f) \<bind> g = do { x \<leftarrow> r; f x \<bind> g }"
apply(coinduction arbitrary: r rule: resumption.coinduct_strong)
apply(auto simp add: split_beta bind_eq_Some_conv)
apply(case_tac [!] "result r")
apply simp_all
done

lemmas resumption_monad = DONE_bind bind_DONE bind_bind_resumption

lemma ABORT_bind [simp]: "ABORT \<bind> f = ABORT"
by(simp add: ABORT_def Done_bind)

lemma bind_resumption_is_Done: "is_Done f \<Longrightarrow> f \<bind> g = (if result f = None then ABORT else g (the (result f)))"
by(rule resumption.expand) auto

lemma bind_resumption_eq_Done_iff [simp]:
  "f \<bind> g = Done x \<longleftrightarrow> (\<exists>y. f = DONE y \<and> g y = Done x) \<or> f = ABORT \<and> x = None"
by(cases f)(auto simp add: Done_bind split: option.split)

lemma bind_resumption_cong:
  assumes "x = y"
  and "\<And>z. z \<in> results y \<Longrightarrow> f z = g z"
  shows "x \<bind> f = y \<bind> g"
using assms(2) unfolding \<open>x = y\<close>
proof(coinduction arbitrary: y rule: resumption.coinduct_strong)
  case Eq_resumption thus ?case
    by(auto intro: resumption.set_sel simp add: is_Done_def rel_fun_def)
      (fastforce del: exI intro!: exI intro: resumption.set_sel(2) simp add: is_Done_def)
qed

lemma results_bind_resumption: (* Move to Resumption *)
  "results (bind_resumption x f) = (\<Union>a\<in>results x. results (f a))"
  (is "?lhs = ?rhs")
proof(intro set_eqI iffI)
  show "z \<in> ?rhs" if "z \<in> ?lhs" for z using that
  proof(induction r\<equiv>"x \<bind> f" arbitrary: x)
    case (Done z z' x)
    from Done(1) Done(2)[symmetric] show ?case by(auto)
  next
    case (Pause out c r z x)
    then show ?case
    proof(cases x)
      case (Done x')
      show ?thesis
      proof(cases x')
        case None
        with Done Pause(4) show ?thesis by(auto simp add: ABORT_def[symmetric])
      next
        case (Some x'')
        thus ?thesis using Pause(1,2,4) Done
          by(auto 4 3 simp add: DONE_def[unfolded o_def, symmetric, unfolded fun_eq_iff] dest: sym)
      qed
    qed(fastforce)
  qed
next
  fix z
  assume "z \<in> ?rhs"
  then obtain z' where z': "z' \<in> results x"
    and z: "z \<in> results (f z')" by blast
  from z' show "z \<in> ?lhs"
  proof(induction z'\<equiv>z' x)
    case (Done r)
    then show ?case using z
      by(auto simp add: DONE_def[unfolded o_def, symmetric, unfolded fun_eq_iff])
  qed auto
qed

lemma outputs_bind_resumption [simp]:
  "outputs (bind_resumption r f) = outputs r \<union> (\<Union>x\<in>results r. outputs (f x))"
  (is "?lhs = ?rhs")
proof(rule set_eqI iffI)+
  show "x \<in> ?rhs" if "x \<in> ?lhs" for x using that
  proof(induction r'\<equiv>"bind_resumption r f" arbitrary: r)
    case (Pause1 out c)
    thus ?case by(cases r)(auto simp add: Done_bind split: option.split_asm dest: sym)
  next
    case (Pause2 out c r' x)
    thus ?case by(cases r)(auto 4 3 simp add: Done_bind split: option.split_asm dest: sym)
  qed
next
  fix x
  assume "x \<in> ?rhs"
  then consider (left) "x \<in> outputs r" | (right) a where "a \<in> results r" "x \<in> outputs (f a)" by auto
  then show "x \<in> ?lhs"
  proof cases
    { case left  thus ?thesis by induction auto }
    { case right thus ?thesis by induction(auto simp add: Done_bind) }
  qed
qed

primrec ensure :: "bool \<Rightarrow> (unit, 'out, 'in) resumption"
where
  "ensure True = DONE ()"
| "ensure False = ABORT"

lemma is_Done_map_resumption [simp]:
  "is_Done (map_resumption f1 f2 r) \<longleftrightarrow> is_Done r"
by(cases r) simp_all

lemma result_map_resumption [simp]:
  "is_Done r \<Longrightarrow> result (map_resumption f1 f2 r) = map_option f1 (result r)"
by(clarsimp simp add: is_Done_def)

lemma output_map_resumption [simp]:
  "\<not> is_Done r \<Longrightarrow> output (map_resumption f1 f2 r) = f2 (output r)"
by(cases r) simp_all

lemma resume_map_resumption [simp]:
  "\<not> is_Done r
  \<Longrightarrow> resume (map_resumption f1 f2 r) = map_resumption f1 f2 \<circ> resume r"
by(cases r) simp_all

lemma rel_resumption_is_DoneD: "rel_resumption A B r1 r2 \<Longrightarrow> is_Done r1 \<longleftrightarrow> is_Done r2"
by(cases r1 r2 rule: resumption.exhaust[case_product resumption.exhaust]) simp_all

lemma rel_resumption_resultD1:
  "\<lbrakk> rel_resumption A B r1 r2; is_Done r1 \<rbrakk> \<Longrightarrow> rel_option A (result r1) (result r2)"
by(cases r1 r2 rule: resumption.exhaust[case_product resumption.exhaust]) simp_all

lemma rel_resumption_resultD2:
  "\<lbrakk> rel_resumption A B r1 r2; is_Done r2 \<rbrakk> \<Longrightarrow> rel_option A (result r1) (result r2)"
by(cases r1 r2 rule: resumption.exhaust[case_product resumption.exhaust]) simp_all

lemma rel_resumption_outputD1:
  "\<lbrakk> rel_resumption A B r1 r2; \<not> is_Done r1 \<rbrakk> \<Longrightarrow> B (output r1) (output r2)"
by(cases r1 r2 rule: resumption.exhaust[case_product resumption.exhaust]) simp_all

lemma rel_resumption_outputD2:
  "\<lbrakk> rel_resumption A B r1 r2; \<not> is_Done r2 \<rbrakk> \<Longrightarrow> B (output r1) (output r2)"
by(cases r1 r2 rule: resumption.exhaust[case_product resumption.exhaust]) simp_all

lemma rel_resumption_resumeD1:
  "\<lbrakk> rel_resumption A B r1 r2; \<not> is_Done r1 \<rbrakk>
  \<Longrightarrow> rel_resumption A B (resume r1 inp) (resume r2 inp)"
by(cases r1 r2 rule: resumption.exhaust[case_product resumption.exhaust])(auto dest: rel_funD)

lemma rel_resumption_resumeD2:
  "\<lbrakk> rel_resumption A B r1 r2; \<not> is_Done r2 \<rbrakk>
  \<Longrightarrow> rel_resumption A B (resume r1 inp) (resume r2 inp)"
by(cases r1 r2 rule: resumption.exhaust[case_product resumption.exhaust])(auto dest: rel_funD)

lemma rel_resumption_coinduct
  [consumes 1, case_names Done Pause,
   case_conclusion Done is_Done result,
   case_conclusion Pause "output" resume,
   coinduct pred: rel_resumption]:
  assumes X: "X r1 r2"
  and Done: "\<And>r1 r2. X r1 r2 \<Longrightarrow> (is_Done r1 \<longleftrightarrow> is_Done r2) \<and> (is_Done r1 \<longrightarrow> is_Done r2 \<longrightarrow> rel_option A (result r1) (result r2))"
  and Pause: "\<And>r1 r2. \<lbrakk> X r1 r2; \<not> is_Done r1; \<not> is_Done r2 \<rbrakk> \<Longrightarrow> B (output r1) (output r2) \<and> (\<forall>inp. X (resume r1 inp) (resume r2 inp))"
  shows "rel_resumption A B r1 r2"
using X
apply(rule resumption.rel_coinduct)
apply(unfold rel_fun_def)
apply(rule conjI)
 apply(erule Done[THEN conjunct1])
apply(rule conjI)
 apply(erule Done[THEN conjunct2])
apply(rule impI)+
apply(drule (2) Pause)
apply blast
done

subsection \<open>Setup for \<open>partial_function\<close>\<close>

context includes lifting_syntax begin

coinductive resumption_ord :: "('a, 'out, 'in) resumption \<Rightarrow> ('a, 'out, 'in) resumption \<Rightarrow> bool"
where
  Done_Done: "flat_ord None a a' \<Longrightarrow> resumption_ord (Done a) (Done a')"
| Done_Pause: "resumption_ord ABORT (Pause out c)"
| Pause_Pause: "((=) ===> resumption_ord) c c' \<Longrightarrow> resumption_ord (Pause out c) (Pause out c')"

inductive_simps resumption_ord_simps [simp]:
  "resumption_ord (Pause out c) r"
  "resumption_ord r (Done a)"

lemma resumption_ord_is_DoneD:
  "\<lbrakk> resumption_ord r r'; is_Done r' \<rbrakk> \<Longrightarrow> is_Done r"
by(cases r')(auto simp add: fun_ord_def)

lemma resumption_ord_resultD:
  "\<lbrakk> resumption_ord r r'; is_Done r' \<rbrakk> \<Longrightarrow> flat_ord None (result r) (result r')"
by(cases r')(auto simp add: flat_ord_def)

lemma resumption_ord_outputD:
  "\<lbrakk> resumption_ord r r'; \<not> is_Done r \<rbrakk> \<Longrightarrow> output r = output r'"
by(cases r) auto

lemma resumption_ord_resumeD:
  "\<lbrakk> resumption_ord r r'; \<not> is_Done r \<rbrakk> \<Longrightarrow> ((=) ===> resumption_ord) (resume r) (resume r')"
by(cases r) auto

lemma resumption_ord_coinduct [consumes 1, case_names Done Abort Pause, case_conclusion Pause "output" resume, coinduct pred: resumption_ord]:
  assumes "X r r'"
  and Done: "\<And>r r'. \<lbrakk> X r r'; is_Done r' \<rbrakk> \<Longrightarrow> is_Done r \<and> flat_ord None (result r) (result r')"
  and Abort: "\<And>r r'. \<lbrakk> X r r'; \<not> is_Done r'; is_Done r \<rbrakk> \<Longrightarrow> result r = None"
  and Pause: "\<And>r r'. \<lbrakk> X r r'; \<not> is_Done r; \<not> is_Done r' \<rbrakk>
  \<Longrightarrow> output r = output r' \<and> ((=) ===> (\<lambda>r r'. X r r' \<or> resumption_ord r r')) (resume r) (resume r')"
  shows "resumption_ord r r'"
using \<open>X r r'\<close>
proof coinduct
  case (resumption_ord r r')
  thus ?case
    by(cases r r' rule: resumption.exhaust[case_product resumption.exhaust])(auto dest: Done Pause Abort)
qed

end

lemma resumption_ord_ABORT [intro!, simp]: "resumption_ord ABORT r"
by(cases r)(simp_all add: flat_ord_def resumption_ord.Done_Pause)

lemma resumption_ord_ABORT2 [simp]: "resumption_ord r ABORT \<longleftrightarrow> r = ABORT"
by(simp add: ABORT_def flat_ord_def)

lemma resumption_ord_DONE1 [simp]: "resumption_ord (DONE x) r \<longleftrightarrow> r = DONE x"
by(cases r)(auto simp add: option_ord_Some1_iff DONE_def dest: resumption_ord_abort)

lemma resumption_ord_refl: "resumption_ord r r"
by(coinduction arbitrary: r)(auto simp add: flat_ord_def)

lemma resumption_ord_antisym:
  "\<lbrakk> resumption_ord r r'; resumption_ord r' r \<rbrakk>
  \<Longrightarrow> r = r'"
proof(coinduction arbitrary: r r' rule: resumption.coinduct_strong)
  case (Eq_resumption r r')
  thus ?case
    by cases(auto simp add: flat_ord_def rel_fun_def)
qed

lemma resumption_ord_trans:
  "\<lbrakk> resumption_ord r r'; resumption_ord r' r'' \<rbrakk>
  \<Longrightarrow> resumption_ord r r''"
proof(coinduction arbitrary: r r' r'')
  case (Done r r' r'')
  thus ?case by(auto 4 4 elim: resumption_ord.cases simp add: flat_ord_def)
next
  case (Abort r r' r'')
  thus ?case by(auto 4 4 elim: resumption_ord.cases simp add: flat_ord_def)
next
  case (Pause r r' r'')
  hence "resumption_ord r r'" "resumption_ord r' r''" by simp_all
  thus ?case using \<open>\<not> is_Done r\<close> \<open>\<not> is_Done r''\<close>
    by(cases)(auto simp add: rel_fun_def)
qed

primcorec resumption_lub :: "('a, 'out, 'in) resumption set \<Rightarrow> ('a, 'out, 'in) resumption"
where
  "\<forall>r \<in> R. is_Done r \<Longrightarrow> is_Done (resumption_lub R)"
| "result (resumption_lub R) = flat_lub None (result ` R)"
| "output (resumption_lub R) = (THE out. out \<in> output ` (R \<inter> {r. \<not> is_Done r}))"
| "resume (resumption_lub R) = (\<lambda>inp. resumption_lub ((\<lambda>c. c inp) ` resume ` (R \<inter> {r. \<not> is_Done r})))"

lemma is_Done_resumption_lub [simp]:
  "is_Done (resumption_lub R) \<longleftrightarrow> (\<forall>r \<in> R. is_Done r)"
by(simp add: resumption_lub_def)

lemma result_resumption_lub [simp]:
  "\<forall>r \<in> R. is_Done r \<Longrightarrow> result (resumption_lub R) = flat_lub None (result ` R)"
by(simp add: resumption_lub_def)

lemma output_resumption_lub [simp]:
  "\<exists>r\<in>R. \<not> is_Done r \<Longrightarrow> output (resumption_lub R) = (THE out. out \<in> output ` (R \<inter> {r. \<not> is_Done r}))"
by(simp add: resumption_lub_def)

lemma resume_resumption_lub [simp]:
  "\<exists>r\<in>R. \<not> is_Done r
  \<Longrightarrow> resume (resumption_lub R) inp =
     resumption_lub ((\<lambda>c. c inp) ` resume ` (R \<inter> {r. \<not> is_Done r}))"
by(simp add: resumption_lub_def)

lemma resumption_lub_empty: "resumption_lub {} = ABORT"
by(subst resumption_lub.code)(simp add: flat_lub_def)

context
  fixes R state inp R'
  defines R'_def: "R' \<equiv> (\<lambda>c. c inp) ` resume ` (R \<inter> {r. \<not> is_Done r})"
  assumes chain: "Complete_Partial_Order.chain resumption_ord R"
begin

lemma resumption_ord_chain_resume: "Complete_Partial_Order.chain resumption_ord R'"
proof(rule chainI)
  fix r' r''
  assume "r' \<in> R'"
    and "r'' \<in> R'"
  then obtain \<r>' \<r>''
    where r': "r' = resume \<r>' inp" "\<r>' \<in> R" "\<not> is_Done \<r>'"
    and r'': "r'' = resume \<r>'' inp" "\<r>'' \<in> R" "\<not> is_Done \<r>''"
    by(auto simp add: R'_def)
  from chain \<open>\<r>' \<in> R\<close> \<open>\<r>'' \<in> R\<close>
  have "resumption_ord \<r>' \<r>'' \<or> resumption_ord \<r>'' \<r>'"
    by(auto elim: chainE)
  with r' r''
  have "resumption_ord (resume \<r>' inp) (resume \<r>'' inp) \<or>
        resumption_ord (resume \<r>'' inp) (resume \<r>' inp)"
    by(auto elim: resumption_ord.cases simp add: rel_fun_def)
  with r' r''
  show "resumption_ord r' r'' \<or> resumption_ord r'' r'" by auto
qed

end

lemma resumption_partial_function_definition:
  "partial_function_definitions resumption_ord resumption_lub"
proof
  show "resumption_ord r r" for r :: "('a, 'b, 'c) resumption" by(rule resumption_ord_refl)
  show "resumption_ord r r''" if "resumption_ord r r'" "resumption_ord r' r''"
    for r r' r'' :: "('a, 'b, 'c) resumption" using that by(rule resumption_ord_trans)
  show "r = r'" if "resumption_ord r r'" "resumption_ord r' r" for r r' :: "('a, 'b, 'c) resumption"
    using that by(rule resumption_ord_antisym)
next
  fix R and r :: "('a, 'b, 'c) resumption"
  assume "Complete_Partial_Order.chain resumption_ord R" "r \<in> R"
  thus "resumption_ord r (resumption_lub R)"
  proof(coinduction arbitrary: r R)
    case (Done r R)
    note chain = \<open>Complete_Partial_Order.chain resumption_ord R\<close>
      and r = \<open>r \<in> R\<close>
    from \<open>is_Done (resumption_lub R)\<close> have A: "\<forall>r \<in> R. is_Done r" by simp
    with r obtain a' where "r = Done a'" by(cases r) auto
    { fix r'
      assume "a' \<noteq> None"
      hence "(THE x. x \<in> result ` R \<and> x \<noteq> None) = a'"
        using r A \<open>r = Done a'\<close>
        by(auto 4 3 del: the_equality intro!: the_equality intro: rev_image_eqI elim: chainE[OF chain] simp add: flat_ord_def is_Done_def)
    }
    with A r \<open>r = Done a'\<close> show ?case
      by(cases a')(auto simp add: flat_ord_def flat_lub_def)
  next
    case (Abort r R)
    hence chain: "Complete_Partial_Order.chain resumption_ord R" and "r \<in> R" by simp_all
    from \<open>r \<in> R\<close> \<open>\<not> is_Done (resumption_lub R)\<close> \<open>is_Done r\<close>
    show ?case by(auto elim: chainE[OF chain] dest: resumption_ord_abort resumption_ord_is_DoneD)
  next
    case (Pause r R)
    hence chain: "Complete_Partial_Order.chain resumption_ord R"
      and r: "r \<in> R" by simp_all
    have ?resume
      using r \<open>\<not> is_Done r\<close> resumption_ord_chain_resume[OF chain]
      by(auto simp add: rel_fun_def bexI)
    moreover
    from r \<open>\<not> is_Done r\<close> have "output (resumption_lub R) = output r"
      by(auto 4 4 simp add: bexI del: the_equality intro!: the_equality elim: chainE[OF chain] dest: resumption_ord_outputD)
    ultimately show ?case by simp
  qed
next
  fix R and r :: "('a, 'b, 'c) resumption"
  assume "Complete_Partial_Order.chain resumption_ord R" "\<And>r'. r' \<in> R \<Longrightarrow> resumption_ord r' r"
  thus "resumption_ord (resumption_lub R) r"
  proof(coinduction arbitrary: R r)
    case (Done R r)
    hence chain: "Complete_Partial_Order.chain resumption_ord R"
      and ub: "\<forall>r'\<in>R. resumption_ord r' r" by simp_all
    from \<open>is_Done r\<close> ub have is_Done: "\<forall>r' \<in> R. is_Done r'"
      and ub': "\<And>r'. r' \<in> result ` R \<Longrightarrow> flat_ord None r' (result r)"
      by(auto dest: resumption_ord_is_DoneD resumption_ord_resultD)
    from is_Done have chain': "Complete_Partial_Order.chain (flat_ord None) (result ` R)"
      by(auto 5 2 intro!: chainI elim: chainE[OF chain] dest: resumption_ord_resultD)
    hence "flat_ord None (flat_lub None (result ` R)) (result r)"
      by(rule partial_function_definitions.lub_least[OF flat_interpretation])(rule ub')
    thus ?case using is_Done by simp
  next
    case (Abort R r)
    hence chain: "Complete_Partial_Order.chain resumption_ord R"
      and ub: "\<forall>r'\<in>R. resumption_ord r' r" by simp_all
    from \<open>\<not> is_Done r\<close> \<open>is_Done (resumption_lub R)\<close> ub
    show ?case by(auto simp add: flat_lub_def dest: resumption_ord_abort)
  next
    case (Pause R r)
    hence chain: "Complete_Partial_Order.chain resumption_ord R"
      and ub: "\<And>r'. r'\<in>R \<Longrightarrow> resumption_ord r' r" by simp_all
    from \<open>\<not> is_Done (resumption_lub R)\<close> have exR: "\<exists>r \<in> R. \<not> is_Done r" by simp
    then obtain r' where r': "r' \<in> R" "\<not> is_Done r'" by auto
    with ub[of r'] have "output r = output r'" by(auto dest: resumption_ord_outputD)
    also have [symmetric]: "output (resumption_lub R) = output r'" using exR r'
      by(auto 4 4 elim: chainE[OF chain] dest: resumption_ord_outputD)
    finally have ?output ..
    moreover
    { fix inp r''
      assume "r'' \<in> R" "\<not> is_Done r''"
      with ub[of r'']
      have "resumption_ord (resume r'' inp) (resume r inp)"
        by(auto dest!: resumption_ord_resumeD simp add: rel_fun_def) }
    with exR resumption_ord_chain_resume[OF chain] r'
    have ?resume by(auto simp add: rel_fun_def)
    ultimately show ?case ..
  qed
qed

interpretation resumption:
  partial_function_definitions resumption_ord resumption_lub
  rewrites "resumption_lub {} = (ABORT :: ('a, 'b, 'c) resumption)"
by (rule resumption_partial_function_definition resumption_lub_empty)+

declaration \<open>Partial_Function.init "resumption" @{term resumption.fixp_fun}
  @{term resumption.mono_body} @{thm resumption.fixp_rule_uc} @{thm resumption.fixp_induct_uc} NONE\<close>

abbreviation "mono_resumption \<equiv> monotone (fun_ord resumption_ord) resumption_ord"

lemma mono_resumption_resume:
  assumes "mono_resumption B"
  shows "mono_resumption (\<lambda>f. resume (B f) inp)"
proof
  fix f g :: "'a \<Rightarrow> ('b, 'c, 'd) resumption"
  assume fg: "fun_ord resumption_ord f g"
  hence "resumption_ord (B f) (B g)" by(rule monotoneD[OF assms])
  with resumption_ord_resumeD[OF this]
  show "resumption_ord (resume (B f) inp) (resume (B g) inp)"
    by(cases "is_Done (B f)")(auto simp add: rel_fun_def is_Done_def)
qed

lemma bind_resumption_mono [partial_function_mono]:
  assumes mf: "mono_resumption B"
  and mg: "\<And>y. mono_resumption (C y)"
  shows "mono_resumption (\<lambda>f. do { y \<leftarrow> B f; C y f })"
proof(rule monotoneI)
  fix f g :: "'a \<Rightarrow> ('b, 'c, 'd) resumption"
  assume *: "fun_ord resumption_ord f g"
  define f' where "f' \<equiv> B f" define g' where "g' \<equiv> B g"
  define h where "h \<equiv> \<lambda>x. C x f" define k where "k \<equiv> \<lambda>x. C x g"
  from mf[THEN monotoneD, OF *] mg[THEN monotoneD, OF *] f'_def g'_def h_def k_def
  have "resumption_ord f' g'" "\<And>x. resumption_ord (h x) (k x)" by auto
  thus "resumption_ord (f' \<bind> h) (g' \<bind> k)"
  proof(coinduction arbitrary: f' g' h k)
    case (Done f' g' h k)
    hence le: "resumption_ord f' g'"
      and mg: "\<And>y. resumption_ord (h y) (k y)" by simp_all
    from \<open>is_Done (g' \<bind> k)\<close>
    have done_Bg: "is_Done g'"
      and "result g' \<noteq> None \<Longrightarrow> is_Done (k (the (result g')))" by simp_all
    moreover
    have "is_Done f'" using le done_Bg by(rule resumption_ord_is_DoneD)
    moreover
    from le done_Bg have "flat_ord None (result f') (result g')"
      by(rule resumption_ord_resultD)
    hence "result f' \<noteq> None \<Longrightarrow> result g' = result f'"
      by(auto simp add: flat_ord_def)
    moreover
    have "resumption_ord (h (the (result f'))) (k (the (result f')))" by(rule mg)
    ultimately show ?case
      by(subst (1 2) result_bind_resumption)(auto dest: resumption_ord_is_DoneD resumption_ord_resultD simp add: flat_ord_def bind_eq_None_conv)
  next
    case (Abort f' g' h k)
    hence "resumption_ord (h (the (result f'))) (k (the (result f')))" by simp
    thus ?case using Abort
      by(cases "is_Done g'")(auto 4 4 simp add: bind_eq_None_conv flat_ord_def dest: resumption_ord_abort resumption_ord_resultD resumption_ord_is_DoneD)
  next
    case (Pause f' g' h k)
    hence ?output
      by(auto 4 4 dest: resumption_ord_outputD resumption_ord_is_DoneD resumption_ord_resultD resumption_ord_abort simp add: flat_ord_def)
    moreover have ?resume
    proof(cases "is_Done f'")
      case False
      with Pause show ?thesis
        by(auto simp add: rel_fun_def dest: resumption_ord_is_DoneD intro: resumption_ord_resumeD[THEN rel_funD] del: exI intro!: exI)
    next
      case True
      hence "is_Done g'" using Pause by(auto dest: resumption_ord_abort)
      thus ?thesis using True Pause resumption_ord_resultD[OF \<open>resumption_ord f' g'\<close>]
        by(auto del: rel_funI intro!: rel_funI simp add: bind_resumption_is_Done flat_ord_def intro: resumption_ord_resumeD[THEN rel_funD] exI[where x=f'] exI[where x=g'])
    qed
    ultimately show ?case ..
  qed
qed

lemma fixes f F
  defines "F \<equiv> \<lambda>results r. case r of resumption.Done x \<Rightarrow> set_option x | resumption.Pause out c \<Rightarrow> \<Union>input. results (c input)"
  shows results_conv_fixp: "results \<equiv> ccpo.fixp (fun_lub Union) (fun_ord (\<subseteq>)) F" (is "_ \<equiv> ?fixp")
  and results_mono: "\<And>x. monotone (fun_ord (\<subseteq>)) (\<subseteq>) (\<lambda>f. F f x)" (is "PROP ?mono")
proof(rule eq_reflection ext antisym subsetI)+
  show mono: "PROP ?mono" unfolding F_def by(tactic \<open>Partial_Function.mono_tac @{context} 1\<close>)
  fix x r
  show "?fixp r \<subseteq> results r"
    by(induction arbitrary: r rule: lfp.fixp_induct_uc[of "\<lambda>x. x" F "\<lambda>x. x", OF mono reflexive refl])
      (fastforce simp add: F_def split: resumption.split_asm)+

  assume "x \<in> results r"
  thus "x \<in> ?fixp r" by induct(subst lfp.mono_body_fixp[OF mono]; auto simp add: F_def)+
qed

lemma mcont_case_resumption:
  fixes f g
  defines "h \<equiv> \<lambda>r. if is_Done r then f (result r) else g (output r) (resume r) r"
  assumes mcont1: "mcont (flat_lub None) option_ord lub ord f"
  and mcont2: "\<And>out. mcont (fun_lub resumption_lub) (fun_ord resumption_ord) lub ord (\<lambda>c. g out c (Pause out c))"
  and ccpo: "class.ccpo lub ord (mk_less ord)"
  and bot: "\<And>x. ord (f None) x"
  shows "mcont resumption_lub resumption_ord lub ord (\<lambda>r. case r of Done x \<Rightarrow> f x | Pause out c \<Rightarrow> g out c r)"
    (is "mcont ?lub ?ord _ _ ?f")
proof(rule resumption.mcont_if_bot[OF ccpo bot, where bound=ABORT and f=h])
  show "?f x = (if ?ord x ABORT then f None else h x)" for x
    by(simp add: h_def split: resumption.split)
  show "ord (h x) (h y)" if "?ord x y" "\<not> ?ord x ABORT" for x y using that
    by(cases x)(simp_all add: h_def mcont_monoD[OF mcont1] fun_ord_conv_rel_fun mcont_monoD[OF mcont2])

  fix Y :: "('a, 'b, 'c) resumption set"
  assume chain: "Complete_Partial_Order.chain ?ord Y"
    and Y: "Y \<noteq> {}"
    and nbot: "\<And>x. x \<in> Y \<Longrightarrow> \<not> ?ord x ABORT"
  show "h (?lub Y) = lub (h ` Y)"
  proof(cases "\<exists>x. DONE x \<in> Y")
    case True
    then obtain x where x: "DONE x \<in> Y" ..
    have is_Done: "is_Done r" if "r \<in> Y" for r using chainD[OF chain that x]
      by(auto dest: resumption_ord_is_DoneD)
    from is_Done have chain': "Complete_Partial_Order.chain (flat_ord None) (result ` Y)"
      by(auto 5 2 intro!: chainI elim: chainE[OF chain] dest: resumption_ord_resultD)
    from is_Done have "is_Done (?lub Y)" "Y \<inter> {r. is_Done r} = Y" "Y \<inter> {r. \<not> is_Done r} = {}" by auto
    then show ?thesis using Y by(simp add: h_def mcont_contD[OF mcont1 chain'] image_image)
  next
    case False
    have is_Done: "\<not> is_Done r" if "r \<in> Y" for r using that False nbot
      by(auto elim!: is_Done_cases)
    from Y obtain out c where Pause: "Pause out c \<in> Y"
      by(auto 5 2 dest: is_Done iff: not_is_Done_conv_Pause)

    have out: "(THE out. out \<in> output ` (Y \<inter> {r. \<not> is_Done r})) = out" using Pause
      by(auto 4 3 intro: rev_image_eqI iff: not_is_Done_conv_Pause dest: chainD[OF chain])
    have "(\<lambda>r. g (output r) (resume r) r) ` (Y \<inter> {r. \<not> is_Done r}) = (\<lambda>r. g out (resume r) r) ` (Y \<inter> {r. \<not> is_Done r})"
      by(auto 4 3 simp add: not_is_Done_conv_Pause dest: chainD[OF chain Pause] intro: rev_image_eqI)
    moreover have "\<not> is_Done (?lub Y)" using Y is_Done by(auto)
    moreover from is_Done have "Y \<inter> {r. is_Done r} = {}" "Y \<inter> {r. \<not> is_Done r} = Y" by auto
    moreover have "(\<lambda>inp. resumption_lub ((\<lambda>x. resume x inp) ` Y)) = fun_lub resumption_lub (resume ` Y)"
      by(auto simp add: fun_lub_def fun_eq_iff intro!: arg_cong[where f="resumption_lub"])
    moreover have "resumption_lub Y = Pause out (fun_lub resumption_lub (resume ` Y))"
      using Y is_Done out
      by(intro resumption.expand)(auto simp add: fun_lub_def fun_eq_iff image_image intro!: arg_cong[where f=resumption_lub])
    moreover have chain': "Complete_Partial_Order.chain resumption.le_fun (resume ` Y)" using chain
      by(rule chain_imageI)(auto dest!: is_Done simp add: not_is_Done_conv_Pause fun_ord_conv_rel_fun)
    moreover have "(\<lambda>r. g out (resume r) (Pause out (resume r))) ` Y = (\<lambda>r. g out (resume r) r) ` Y"
      by(intro image_cong[OF refl])(frule nbot; auto dest!: chainD[OF chain Pause] elim: resumption_ord.cases)
    ultimately show ?thesis using False out Y
      by(simp add: h_def image_image mcont_contD[OF mcont2])
  qed
qed

lemma mcont2mcont_results[THEN mcont2mcont, cont_intro, simp]:
  shows mcont_results: "mcont resumption_lub resumption_ord Union (\<subseteq>) results"
apply(rule lfp.fixp_preserves_mcont1[OF results_mono results_conv_fixp])
apply(rule mcont_case_resumption)
apply(simp_all add: mcont_applyI)
done

lemma mono2mono_results[THEN lfp.mono2mono, cont_intro, simp]:
  shows monotone_results: "monotone resumption_ord (\<subseteq>) results"
using mcont_results by(rule mcont_mono)

lemma fixes f F
  defines "F \<equiv> \<lambda>outputs xs. case xs of resumption.Done x \<Rightarrow> {} | resumption.Pause out c \<Rightarrow> insert out (\<Union>input. outputs (c input))"
  shows outputs_conv_fixp: "outputs \<equiv> ccpo.fixp (fun_lub Union) (fun_ord (\<subseteq>)) F" (is "_ \<equiv> ?fixp")
  and outputs_mono: "\<And>x. monotone (fun_ord (\<subseteq>)) (\<subseteq>) (\<lambda>f. F f x)" (is "PROP ?mono")
proof(rule eq_reflection ext antisym subsetI)+
  show mono: "PROP ?mono" unfolding F_def by(tactic \<open>Partial_Function.mono_tac @{context} 1\<close>)
  show "?fixp r \<subseteq> outputs r" for r
    by(induct arbitrary: r rule: lfp.fixp_induct_uc[of "\<lambda>x. x" F "\<lambda>x. x", OF mono reflexive refl])(auto simp add: F_def split: resumption.split)
  show "x \<in> ?fixp r" if "x \<in> outputs r" for x r using that
    by induct(subst lfp.mono_body_fixp[OF mono]; auto simp add: F_def; fail)+
qed

lemma mcont2mcont_outputs[THEN lfp.mcont2mcont, cont_intro, simp]:
  shows mcont_outputs: "mcont resumption_lub resumption_ord Union (\<subseteq>) outputs"
apply(rule lfp.fixp_preserves_mcont1[OF outputs_mono outputs_conv_fixp])
apply(auto intro: lfp.mcont2mcont intro!: mcont2mcont_insert mcont_SUP mcont_case_resumption)
done

lemma mono2mono_outputs[THEN lfp.mono2mono, cont_intro, simp]:
  shows monotone_outputs: "monotone resumption_ord (\<subseteq>) outputs"
using mcont_outputs by(rule mcont_mono)

lemma pred_resumption_antimono:
  assumes r: "pred_resumption A C r'"
  and le: "resumption_ord r r'"
  shows "pred_resumption A C r"
using r monotoneD[OF monotone_results le] monotoneD[OF monotone_outputs le]
by(auto simp add: pred_resumption_def)

subsection \<open>Setup for lifting and transfer\<close>

declare resumption.rel_eq [id_simps, relator_eq]
declare resumption.rel_mono [relator_mono]

lemma left_total_rel_resumption [transfer_rule]:
  "\<lbrakk> left_total R1; left_total R2 \<rbrakk> \<Longrightarrow> left_total (rel_resumption R1 R2)"
  by(simp only: left_total_alt_def resumption.rel_eq[symmetric] resumption.rel_conversep[symmetric] rel_resumption_OO resumption.rel_mono)

lemma left_unique_rel_resumption [transfer_rule]:
  "\<lbrakk> left_unique R1; left_unique R2 \<rbrakk> \<Longrightarrow> left_unique (rel_resumption R1 R2)"
  by(simp only: left_unique_alt_def resumption.rel_eq[symmetric] resumption.rel_conversep[symmetric] rel_resumption_OO resumption.rel_mono)

lemma right_total_rel_resumption [transfer_rule]:
  "\<lbrakk> right_total R1; right_total R2 \<rbrakk> \<Longrightarrow> right_total (rel_resumption R1 R2)"
  by(simp only: right_total_alt_def resumption.rel_eq[symmetric] resumption.rel_conversep[symmetric] rel_resumption_OO resumption.rel_mono)

lemma right_unique_rel_resumption [transfer_rule]:
  "\<lbrakk> right_unique R1; right_unique R2 \<rbrakk> \<Longrightarrow> right_unique (rel_resumption R1 R2)"
  by(simp only: right_unique_alt_def resumption.rel_eq[symmetric] resumption.rel_conversep[symmetric] rel_resumption_OO resumption.rel_mono)

lemma bi_total_rel_resumption [transfer_rule]:
  "\<lbrakk> bi_total A; bi_total B \<rbrakk> \<Longrightarrow> bi_total (rel_resumption A B)"
unfolding bi_total_alt_def
by(blast intro: left_total_rel_resumption right_total_rel_resumption)

lemma bi_unique_rel_resumption [transfer_rule]:
  "\<lbrakk> bi_unique A; bi_unique B \<rbrakk> \<Longrightarrow> bi_unique (rel_resumption A B)"
unfolding bi_unique_alt_def
by(blast intro: left_unique_rel_resumption right_unique_rel_resumption)

lemma Quotient_resumption [quot_map]:
  "\<lbrakk> Quotient R1 Abs1 Rep1 T1; Quotient R2 Abs2 Rep2 T2 \<rbrakk>
  \<Longrightarrow> Quotient (rel_resumption R1 R2) (map_resumption Abs1 Abs2) (map_resumption Rep1 Rep2) (rel_resumption T1 T2)"
  by(simp add: Quotient_alt_def5 resumption.rel_Grp[of UNIV _ UNIV _, symmetric, simplified] resumption.rel_compp resumption.rel_conversep[symmetric] resumption.rel_mono)

end


section "Subsumption and change of environment"

theory ChangeEnv
  imports Main Lambda DeclSemAsDenotFSet ValuesFSetProps
begin

lemma e_prim_intro[intro]: "\<lbrakk> VNat n1 \<in> E e1 \<rho>; VNat n2 \<in> E e2 \<rho>; v = VNat (f n1 n2) \<rbrakk>
    \<Longrightarrow> v \<in> E (EPrim f e1 e2) \<rho>" by auto

lemma e_prim_elim[elim]: "\<lbrakk> v \<in> E (EPrim f e1 e2) \<rho>;
   \<And> n1 n2. \<lbrakk> VNat n1 \<in> E e1 \<rho>; VNat n2 \<in> E e2 \<rho>; v = VNat (f n1 n2) \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by auto

lemma e_app_elim[elim]: "\<lbrakk> v3 \<in> E (EApp e1 e2) \<rho>;
  \<And> f v2 v2' v3'. \<lbrakk> VFun f \<in> E e1 \<rho>; v2 \<in> E e2 \<rho>; (v2',v3') \<in> fset f; v2' \<sqsubseteq> v2; v3 \<sqsubseteq> v3' \<rbrakk> \<Longrightarrow> P
 \<rbrakk> \<Longrightarrow> P"
  by auto

lemma e_app_intro[intro]: "\<lbrakk> VFun f \<in> E e1 \<rho>; v2 \<in> E e2 \<rho>; (v2',v3') \<in> fset f; v2' \<sqsubseteq> v2; v3 \<sqsubseteq> v3'\<rbrakk>
     \<Longrightarrow> v3 \<in> E (EApp e1 e2) \<rho>" by auto

lemma e_lam_intro[intro]: "\<lbrakk> v = VFun f;
      \<forall> v1 v2. (v1,v2) \<in> fset f \<longrightarrow> v2 \<in> E e ((x,v1)#\<rho>) \<rbrakk>
    \<Longrightarrow> v \<in> E (ELam x e) \<rho>"
  by auto

lemma e_lam_intro2[intro]:
  "\<lbrakk> VFun f \<in> E (ELam x e) \<rho>; v2 \<in> E e ((x,v1)#\<rho>) \<rbrakk>
  \<Longrightarrow> VFun (finsert (v1,v2) f) \<in> E (ELam x e) \<rho>"
  by auto

lemma e_lam_intro3[intro]: "VFun {||} \<in> E (ELam x e) \<rho>"
  by auto

lemma e_if_intro[intro]: "\<lbrakk> VNat n \<in> E e1 \<rho>; n = 0 \<longrightarrow> v \<in> E e3 \<rho>; n \<noteq> 0 \<longrightarrow> v \<in> E e2 \<rho> \<rbrakk>
    \<Longrightarrow> v \<in> E (EIf e1 e2 e3) \<rho>"
  by auto

lemma e_var_intro[elim]: "\<lbrakk> lookup \<rho> x = Some v'; v \<sqsubseteq> v' \<rbrakk> \<Longrightarrow> v \<in> E (EVar x) \<rho>"
  by auto

lemma e_var_elim[elim]: "\<lbrakk> v \<in> E (EVar x) \<rho>;
   \<And> v'. \<lbrakk> lookup \<rho> x = Some v'; v \<sqsubseteq> v' \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by auto

lemma e_lam_elim[elim]: "\<lbrakk> v \<in> E (ELam x e) \<rho>;
   \<And> f. \<lbrakk> v = VFun f; \<forall> v1 v2. (v1,v2) \<in> fset f \<longrightarrow> v2 \<in> E e ((x,v1)#\<rho>) \<rbrakk>
    \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by auto

lemma e_lam_elim2[elim]: "\<lbrakk> VFun (finsert (v1,v2) f) \<in> E (ELam x e) \<rho>;
   \<lbrakk> v2 \<in> E e ((x,v1)#\<rho>) \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by auto

lemma e_if_elim[elim]: "\<lbrakk> v \<in> E (EIf e1 e2 e3) \<rho>;
   \<And> n. \<lbrakk> VNat n \<in> E e1 \<rho>; n = 0 \<longrightarrow> v \<in> E e3 \<rho>; n \<noteq> 0 \<longrightarrow> v \<in> E e2 \<rho> \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by auto

definition xenv_le :: "name set \<Rightarrow> env \<Rightarrow> env \<Rightarrow> bool" ("_ \<turnstile> _ \<sqsubseteq> _" [51,51,51] 52) where
  "X \<turnstile> \<rho> \<sqsubseteq> \<rho>' \<equiv> \<forall> x v. x \<in> X \<and> lookup \<rho> x = Some v \<longrightarrow> (\<exists> v'. lookup \<rho>' x = Some v' \<and> v \<sqsubseteq> v')"
declare xenv_le_def[simp]

proposition change_env_le: fixes v::val and \<rho>::env
  assumes de: "v \<in> E e \<rho>" and vp_v: "v' \<sqsubseteq> v" and rr: "FV e \<turnstile> \<rho> \<sqsubseteq> \<rho>'"
  shows "v' \<in> E e \<rho>'"
  using de rr vp_v
proof (induction e arbitrary: v v' \<rho> \<rho>' rule: exp.induct)
  case (EVar x v v' \<rho> \<rho>')
  from EVar obtain v2 where lx: "lookup \<rho> x = Some v2" and v_v2: "v \<sqsubseteq> v2" by auto
  from lx EVar obtain v3 where
    lx2: "lookup \<rho>' x = Some v3" and v2_v3: "v2 \<sqsubseteq> v3" by force
  from v_v2 v2_v3 have v_v3: "v \<sqsubseteq> v3" by (rule val_le_trans)
  from EVar v_v3 have vp_v3: "v' \<sqsubseteq> v3" using val_le_trans by blast
  from lx2 vp_v3 show ?case by (rule e_var_intro)
next
  case (ENat n) then show ?case by simp
next
  case (ELam x e)
  from ELam(2) obtain f where v: "v = VFun f" and
    body: "\<forall> v1 v2. (v1,v2) \<in> fset f \<longrightarrow> v2 \<in> E e ((x,v1)#\<rho>)" by auto
  from v ELam(4) obtain f' where vp: "v' = VFun f'" and fp_f: "fset f' \<subseteq> fset f"
    by (case_tac v') auto
  from vp show ?case
  proof (simp,clarify)
    fix v1 v2 assume v12: "(v1,v2)\<in> fset f'"
    from v12 fp_f have v34: "(v1,v2) \<in> fset f" by blast
    from v34 body have v4_E: "v2 \<in> E e ((x,v1)#\<rho>)" by blast
    from ELam(3) have rr2: "FV e \<turnstile> ((x,v1)#\<rho>) \<sqsubseteq> ((x,v1)#\<rho>')" by auto
    from ELam(1) v4_E rr2 show "v2 \<in> E e ((x,v1)#\<rho>')" by auto
  qed
next
  case (EApp e1 e2)
  from EApp(3) obtain f and v2::val and v2' v3' where
    f_e1: "VFun f \<in> E e1 \<rho>" and v2_e2: "v2 \<in> E e2 \<rho>" and
    v23p_f: "(v2',v3') \<in> fset f" and v2p_v2: "v2' \<sqsubseteq> v2" and v_v3: "v \<sqsubseteq> v3'" by blast
  from EApp(4) have 1: "FV e1 \<turnstile> \<rho> \<sqsubseteq> \<rho>'" by auto
  have f_f: "VFun f \<sqsubseteq> VFun f" by auto
  from EApp(1) f_e1 1 f_f have f_e1b: "VFun f \<in> E e1 \<rho>'" by blast
  from EApp(4) have 2: "FV e2 \<turnstile> \<rho> \<sqsubseteq> \<rho>'" by auto
  from EApp(2) v2_e2 2 have v2_e2b: "v2 \<in> E e2 \<rho>'" by auto
  from EApp(5) v_v3 have vp_v3p: "v' \<sqsubseteq> v3'" by (rule val_le_trans)
  from f_e1b v2_e2b v23p_f v2p_v2 vp_v3p
  show ?case by auto
next
  case (EPrim f e1 e2)
  from EPrim(3) obtain n1 n2 where n1_e1: "VNat n1 \<in> E e1 \<rho>" and
    n2_e2: "VNat n2 \<in> E e2 \<rho>" and v: "v = VNat (f n1 n2)" by blast
  from EPrim(4) have 1: "FV e1 \<turnstile> \<rho> \<sqsubseteq> \<rho>'" by auto
  from EPrim(1) n1_e1 1 have n1_e1b: "VNat n1 \<in> E e1 \<rho>'" by blast
  from EPrim(4) have 2: "FV e2 \<turnstile> \<rho> \<sqsubseteq> \<rho>'" by auto
  from EPrim(2) n2_e2 2 have n2_e2b: "VNat n2 \<in> E e2 \<rho>'" by blast
  from v EPrim(5) have vp: "v' = VNat (f n1 n2)" by auto
  from n1_e1b n2_e2b vp show ?case by auto
next
  case (EIf e1 e2 e3)
  then show ?case apply simp apply clarify apply (rule_tac x=n in exI) apply (rule conjI)
      apply force apply force done
qed

\<comment> \<open>Subsumption is admissible\<close>
proposition e_sub: "\<lbrakk> v \<in> E e \<rho>; v' \<sqsubseteq> v \<rbrakk> \<Longrightarrow> v' \<in> E e \<rho>"
  apply (subgoal_tac "FV e \<turnstile> \<rho> \<sqsubseteq> \<rho>") using change_env_le apply blast apply auto done

lemma env_le_ext: fixes \<rho>::env assumes rr: "\<rho> \<sqsubseteq> \<rho>'" shows "((x,v)#\<rho>) \<sqsubseteq> ((x,v)#\<rho>')"
  using rr apply (simp add: env_le_def) done

lemma change_env: fixes \<rho>::env assumes de: "v \<in> E e \<rho>" and rr: "FV e \<turnstile> \<rho> \<sqsubseteq> \<rho>'" shows "v \<in> E e \<rho>'"
proof -
  have vv: "v \<sqsubseteq> v" by auto
  from de rr vv show ?thesis using change_env_le by blast
qed

lemma raise_env: fixes \<rho>::env assumes de: "v \<in> E e \<rho>" and rr: "\<rho> \<sqsubseteq> \<rho>'" shows "v \<in> E e \<rho>'"
  using de rr change_env env_le_def by auto

lemma env_eq_refl[simp]: fixes \<rho>::env shows "\<rho> \<approx> \<rho>" by (simp add: env_eq_def)

lemma eq_implies_le: fixes \<rho>::env shows "\<rho> \<approx> \<rho>' \<Longrightarrow> \<rho> \<sqsubseteq> \<rho>'"
  by (simp add: env_le_def env_eq_def)

lemma env_swap: fixes \<rho>::env assumes rr: "\<rho> \<approx> \<rho>'" and ve: "v \<in> E e \<rho>" shows "v \<in> E e \<rho>'"
  using rr ve apply (subgoal_tac "\<rho> \<sqsubseteq> \<rho>'") prefer 2 apply (rule eq_implies_le) apply blast
  apply (rule raise_env) apply auto done

lemma env_strengthen: "\<lbrakk> v \<in> E e \<rho>; \<forall> x. x \<in> FV e \<longrightarrow> lookup \<rho>' x = lookup \<rho> x \<rbrakk> \<Longrightarrow> v \<in> E e \<rho>'"
  using change_env by auto

end


(*  Title:      HOL/HOLCF/Library/Stream.thy
    Author:     Franz Regensburger, David von Oheimb, Borislav Gajanovic
*)

section \<open>General Stream domain\<close>

theory Stream
imports "../HOLCF" "~~/src/HOL/Library/Extended_Nat"
begin

default_sort pcpo

domain (unsafe) 'a stream = scons (ft::'a) (lazy rt::"'a stream") (infixr "&&" 65)

definition
  smap :: "('a \<rightarrow> 'b) \<rightarrow> 'a stream \<rightarrow> 'b stream" where
  "smap = fix\<cdot>(\<Lambda> h f s. case s of x && xs \<Rightarrow> f\<cdot>x && h\<cdot>f\<cdot>xs)"

definition
  sfilter :: "('a \<rightarrow> tr) \<rightarrow> 'a stream \<rightarrow> 'a stream" where
  "sfilter = fix\<cdot>(\<Lambda> h p s. case s of x && xs \<Rightarrow>
                                     If p\<cdot>x then x && h\<cdot>p\<cdot>xs else h\<cdot>p\<cdot>xs)"

definition
  slen :: "'a stream \<Rightarrow> enat"  ("#_" [1000] 1000) where
  "#s = (if stream_finite s then enat (LEAST n. stream_take n\<cdot>s = s) else \<infinity>)"

(* concatenation *)

definition
  i_rt :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where (* chops the first i elements *)
  "i_rt = (\<lambda>i s. iterate i\<cdot>rt\<cdot>s)"

definition
  i_th :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a" where (* the i-th element *)
  "i_th = (\<lambda>i s. ft\<cdot>(i_rt i s))"

definition
  sconc :: "'a stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream"  (infixr "ooo" 65) where
  "s1 ooo s2 = (case #s1 of
                  enat n \<Rightarrow> (SOME s. (stream_take n\<cdot>s = s1) \<and> (i_rt n s = s2))
               | \<infinity>     \<Rightarrow> s1)"

primrec constr_sconc' :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream"
where
  constr_sconc'_0:   "constr_sconc' 0 s1 s2 = s2"
| constr_sconc'_Suc: "constr_sconc' (Suc n) s1 s2 = ft\<cdot>s1 && constr_sconc' n (rt\<cdot>s1) s2"

definition
  constr_sconc  :: "'a stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where (* constructive *)
  "constr_sconc s1 s2 = (case #s1 of
                          enat n \<Rightarrow> constr_sconc' n s1 s2
                        | \<infinity>    \<Rightarrow> s1)"

(* ----------------------------------------------------------------------- *)
(* theorems about scons                                                    *)
(* ----------------------------------------------------------------------- *)

section "scons"

lemma scons_eq_UU: "(a && s = UU) = (a = UU)"
by simp

lemma scons_not_empty: "\<lbrakk>a && x = UU; a \<noteq> UU\<rbrakk> \<Longrightarrow> R"
by simp

lemma stream_exhaust_eq: "x \<noteq> UU \<longleftrightarrow> (\<exists>a y. a \<noteq> UU \<and> x = a && y)"
by (cases x, auto)

lemma stream_neq_UU: "x \<noteq> UU \<Longrightarrow> \<exists>a a_s. x = a && a_s \<and> a \<noteq> UU"
by (simp add: stream_exhaust_eq,auto)

lemma stream_prefix:
  "\<lbrakk>a && s \<sqsubseteq> t; a \<noteq> UU\<rbrakk> \<Longrightarrow> \<exists>b tt. t = b && tt \<and> b \<noteq> UU \<and> s \<sqsubseteq> tt"
by (cases t, auto)

lemma stream_prefix':
  "b \<noteq> UU \<Longrightarrow> x \<sqsubseteq> b && z =
   (x = UU \<or> (\<exists>a y. x = a && y \<and> a \<noteq> UU \<and> a \<sqsubseteq> b \<and> y \<sqsubseteq> z))"
by (cases x, auto)

(*
lemma stream_prefix1: "\<lbrakk>x \<sqsubseteq> y; xs \<sqsubseteq> ys\<rbrakk> \<Longrightarrow> x && xs \<sqsubseteq> y && ys"
by (insert stream_prefix' [of y "x && xs" ys],force)
*)

lemma stream_flat_prefix:
  "\<lbrakk>x && xs \<sqsubseteq> y && ys; (x::'a::flat) \<noteq> UU\<rbrakk> \<Longrightarrow> x = y \<and> xs \<sqsubseteq> ys"
apply (case_tac "y = UU",auto)
apply (drule ax_flat,simp)
done

(* ----------------------------------------------------------------------- *)
(* theorems about stream_case                                              *)
(* ----------------------------------------------------------------------- *)

section "stream_case"

lemma stream_case_strictf: "stream_case\<cdot>UU\<cdot>s = UU"
by (cases s, auto)

(* ----------------------------------------------------------------------- *)
(* theorems about ft and rt                                                *)
(* ----------------------------------------------------------------------- *)

section "ft and rt"

lemma ft_defin: "s \<noteq> UU \<Longrightarrow> ft\<cdot>s \<noteq> UU"
by simp

lemma rt_strict_rev: "rt\<cdot>s \<noteq> UU \<Longrightarrow> s \<noteq> UU"
by auto

lemma surjectiv_scons: "(ft\<cdot>s) && (rt\<cdot>s) = s"
by (cases s, auto)

lemma monofun_rt_mult: "x \<sqsubseteq> s \<Longrightarrow> iterate i\<cdot>rt\<cdot>x \<sqsubseteq> iterate i\<cdot>rt\<cdot>s"
by (rule monofun_cfun_arg)

(* ----------------------------------------------------------------------- *)
(* theorems about stream_take                                              *)
(* ----------------------------------------------------------------------- *)

section "stream_take"

lemma stream_reach2: "(LUB i. stream_take i\<cdot>s) = s"
by (rule stream.reach)

lemma chain_stream_take: "chain (\<lambda>i. stream_take i\<cdot>s)"
by simp

lemma stream_take_prefix [simp]: "stream_take n\<cdot>s \<sqsubseteq> s"
apply (insert stream_reach2 [of s])
apply (erule subst) back
apply (rule is_ub_thelub)
apply (simp only: chain_stream_take)
done

lemma stream_take_more [rule_format]:
  "\<forall>x. stream_take n\<cdot>x = x \<longrightarrow> stream_take (Suc n)\<cdot>x = x"
apply (induct_tac n,auto)
apply (case_tac "x=UU",auto)
apply (drule stream_exhaust_eq [THEN iffD1],auto)
done

lemma stream_take_lemma3 [rule_format]:
  "\<forall>x xs. x \<noteq> UU \<longrightarrow> stream_take n\<cdot>(x && xs) = x && xs \<longrightarrow> stream_take n\<cdot>xs = xs"
apply (induct_tac n,clarsimp)
(*apply (drule sym, erule scons_not_empty, simp)*)
apply (clarify, rule stream_take_more)
apply (erule_tac x="x" in allE)
apply (erule_tac x="xs" in allE,simp)
done

lemma stream_take_lemma4:
  "\<forall>x xs. stream_take n\<cdot>xs = xs \<longrightarrow> stream_take (Suc n)\<cdot>(x && xs) = x && xs"
by auto

lemma stream_take_idempotent [rule_format, simp]:
  "\<forall>s. stream_take n\<cdot>(stream_take n\<cdot>s) = stream_take n\<cdot>s"
apply (induct_tac n, auto)
apply (case_tac "s=UU", auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
done

lemma stream_take_take_Suc [rule_format, simp]:
  "\<forall>s. stream_take n\<cdot>(stream_take (Suc n)\<cdot>s) = stream_take n\<cdot>s"
apply (induct_tac n, auto)
apply (case_tac "s=UU", auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
done

lemma mono_stream_take_pred:
  "stream_take (Suc n)\<cdot>s1 \<sqsubseteq> stream_take (Suc n)\<cdot>s2 \<Longrightarrow>
                       stream_take n\<cdot>s1 \<sqsubseteq> stream_take n\<cdot>s2"
by (insert monofun_cfun_arg [of "stream_take (Suc n)\<cdot>s1"
  "stream_take (Suc n)\<cdot>s2" "stream_take n"], auto)
(*
lemma mono_stream_take_pred:
  "stream_take (Suc n)\<cdot>s1 \<sqsubseteq> stream_take (Suc n)\<cdot>s2 \<Longrightarrow>
                       stream_take n\<cdot>s1 \<sqsubseteq> stream_take n\<cdot>s2"
by (drule mono_stream_take [of _ _ n],simp)
*)

lemma stream_take_lemma10 [rule_format]:
  "\<forall>k\<le>n. stream_take n\<cdot>s1 \<sqsubseteq> stream_take n\<cdot>s2 \<longrightarrow> stream_take k\<cdot>s1 \<sqsubseteq> stream_take k\<cdot>s2"
apply (induct_tac n,simp,clarsimp)
apply (case_tac "k=Suc n",blast)
apply (erule_tac x="k" in allE)
apply (drule mono_stream_take_pred,simp)
done

lemma stream_take_le_mono : "k \<le> n \<Longrightarrow> stream_take k\<cdot>s1 \<sqsubseteq> stream_take n\<cdot>s1"
apply (insert chain_stream_take [of s1])
apply (drule chain_mono,auto)
done

lemma mono_stream_take: "s1 \<sqsubseteq> s2 \<Longrightarrow> stream_take n\<cdot>s1 \<sqsubseteq> stream_take n\<cdot>s2"
by (simp add: monofun_cfun_arg)

(*
lemma stream_take_prefix [simp]: "stream_take n\<cdot>s \<sqsubseteq> s"
apply (subgoal_tac "s=(LUB n. stream_take n\<cdot>s)")
 apply (erule ssubst, rule is_ub_thelub)
 apply (simp only: chain_stream_take)
by (simp only: stream_reach2)
*)

lemma stream_take_take_less:"stream_take k\<cdot>(stream_take n\<cdot>s) \<sqsubseteq> stream_take k\<cdot>s"
by (rule monofun_cfun_arg,auto)

(* ------------------------------------------------------------------------- *)
(* special induction rules                                                   *)
(* ------------------------------------------------------------------------- *)

section "induction"

lemma stream_finite_ind:
  "\<lbrakk>stream_finite x; P UU; \<And>a s. \<lbrakk>a \<noteq> UU; P s\<rbrakk> \<Longrightarrow> P (a && s)\<rbrakk> \<Longrightarrow> P x"
apply (simp add: stream.finite_def,auto)
apply (erule subst)
apply (drule stream.finite_induct [of P _ x], auto)
done

lemma stream_finite_ind2:
  "\<lbrakk>P UU; \<And>x. x \<noteq> UU \<Longrightarrow> P (x && UU); \<And>y z s. \<lbrakk>y \<noteq> UU; z \<noteq> UU; P s\<rbrakk> \<Longrightarrow> P (y && z && s)\<rbrakk> \<Longrightarrow>
                                 \<forall>s. P (stream_take n\<cdot>s)"
apply (rule nat_less_induct [of _ n],auto)
apply (case_tac n, auto)
apply (case_tac nat, auto)
apply (case_tac "s=UU",clarsimp)
apply (drule stream_exhaust_eq [THEN iffD1],clarsimp)
apply (case_tac "s=UU",clarsimp)
apply (drule stream_exhaust_eq [THEN iffD1],clarsimp)
apply (case_tac "y=UU",clarsimp)
apply (drule stream_exhaust_eq [THEN iffD1],clarsimp)
done

lemma stream_ind2:
"\<lbrakk> adm P; P UU; \<And>a. a \<noteq> UU \<Longrightarrow> P (a && UU); \<And>a b s. \<lbrakk>a \<noteq> UU; b \<noteq> UU; P s\<rbrakk> \<Longrightarrow> P (a && b && s)\<rbrakk> \<Longrightarrow> P x"
apply (insert stream.reach [of x],erule subst)
apply (erule admD, rule chain_stream_take)
apply (insert stream_finite_ind2 [of P])
by simp

(* ----------------------------------------------------------------------- *)
(* simplify use of coinduction                                             *)
(* ----------------------------------------------------------------------- *)

section "coinduction"

lemma stream_coind_lemma2: "\<forall>s1 s2. R s1 s2 \<longrightarrow> ft\<cdot>s1 = ft\<cdot>s2 \<and> R (rt\<cdot>s1) (rt\<cdot>s2) \<Longrightarrow> stream_bisim R"
 apply (simp add: stream.bisim_def,clarsimp)
 apply (drule spec, drule spec, drule (1) mp)
 apply (case_tac "x", simp)
 apply (case_tac "y", simp)
 apply auto
 done

(* ----------------------------------------------------------------------- *)
(* theorems about stream_finite                                            *)
(* ----------------------------------------------------------------------- *)

section "stream_finite"

lemma stream_finite_UU [simp]: "stream_finite UU"
by (simp add: stream.finite_def)

lemma stream_finite_UU_rev: "\<not> stream_finite s \<Longrightarrow> s \<noteq> UU"
by (auto simp add: stream.finite_def)

lemma stream_finite_lemma1: "stream_finite xs \<Longrightarrow> stream_finite (x && xs)"
apply (simp add: stream.finite_def,auto)
apply (rule_tac x="Suc n" in exI)
apply (simp add: stream_take_lemma4)
done

lemma stream_finite_lemma2: "\<lbrakk>x \<noteq> UU; stream_finite (x && xs)\<rbrakk> \<Longrightarrow> stream_finite xs"
apply (simp add: stream.finite_def, auto)
apply (rule_tac x="n" in exI)
apply (erule stream_take_lemma3,simp)
done

lemma stream_finite_rt_eq: "stream_finite (rt\<cdot>s) = stream_finite s"
apply (cases s, auto)
apply (rule stream_finite_lemma1, simp)
apply (rule stream_finite_lemma2,simp)
apply assumption
done

lemma stream_finite_less: "stream_finite s \<Longrightarrow> \<forall>t. t \<sqsubseteq> s \<longrightarrow> stream_finite t"
apply (erule stream_finite_ind [of s], auto)
apply (case_tac "t=UU", auto)
apply (drule stream_exhaust_eq [THEN iffD1],auto)
apply (erule_tac x="y" in allE, simp)
apply (rule stream_finite_lemma1, simp)
done

lemma stream_take_finite [simp]: "stream_finite (stream_take n\<cdot>s)"
apply (simp add: stream.finite_def)
apply (rule_tac x="n" in exI,simp)
done

lemma adm_not_stream_finite: "adm (\<lambda>x. \<not> stream_finite x)"
apply (rule adm_upward)
apply (erule contrapos_nn)
apply (erule (1) stream_finite_less [rule_format])
done

(* ----------------------------------------------------------------------- *)
(* theorems about stream length                                            *)
(* ----------------------------------------------------------------------- *)

section "slen"

lemma slen_empty [simp]: "#\<bottom> = 0"
by (simp add: slen_def stream.finite_def zero_enat_def Least_equality)

lemma slen_scons [simp]: "x \<noteq> \<bottom> \<Longrightarrow> #(x && xs) = eSuc (#xs)"
apply (case_tac "stream_finite (x && xs)")
apply (simp add: slen_def, auto)
apply (simp add: stream.finite_def, auto simp add: eSuc_enat)
apply (rule Least_Suc2, auto)
(*apply (drule sym)*)
(*apply (drule sym scons_eq_UU [THEN iffD1],simp)*)
apply (erule stream_finite_lemma2, simp)
apply (simp add: slen_def, auto)
apply (drule stream_finite_lemma1,auto)
done

lemma slen_less_1_eq: "(#x < enat (Suc 0)) = (x = \<bottom>)"
by (cases x) (auto simp add: enat_0 eSuc_enat[THEN sym])

lemma slen_empty_eq: "(#x = 0) = (x = \<bottom>)"
by (cases x) auto

lemma slen_scons_eq: "(enat (Suc n) < #x) = (? a y. x = a && y \<and> a \<noteq> \<bottom> \<and> enat n < #y)"
apply (auto, case_tac "x=UU",auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
apply (case_tac "#y") apply simp_all
apply (case_tac "#y") apply simp_all
done

lemma slen_eSuc: "#x = eSuc n \<longrightarrow> (\<exists>a y. x = a && y \<and> a \<noteq> \<bottom> \<and> #y = n)"
by (cases x) auto

lemma slen_stream_take_finite [simp]: "#(stream_take n\<cdot>s) \<noteq> \<infinity>"
by (simp add: slen_def)

lemma slen_scons_eq_rev: "#x < enat (Suc (Suc n)) \<longleftrightarrow> (\<forall>a y. x \<noteq> a && y \<or> a = \<bottom> \<or> #y < enat (Suc n))"
 apply (cases x, auto)
   apply (simp add: zero_enat_def)
  apply (case_tac "#stream") apply (simp_all add: eSuc_enat)
 apply (case_tac "#stream") apply (simp_all add: eSuc_enat)
done

lemma slen_take_lemma4 [rule_format]:
  "\<forall>s. stream_take n\<cdot>s \<noteq> s \<longrightarrow> #(stream_take n\<cdot>s) = enat n"
apply (induct n, auto simp add: enat_0)
apply (case_tac "s=UU", simp)
apply (drule stream_exhaust_eq [THEN iffD1], auto simp add: eSuc_enat)
done

(*
lemma stream_take_idempotent [simp]:
 "stream_take n\<cdot>(stream_take n\<cdot>s) = stream_take n\<cdot>s"
apply (case_tac "stream_take n\<cdot>s = s")
apply (auto,insert slen_take_lemma4 [of n s]);
by (auto,insert slen_take_lemma1 [of "stream_take n\<cdot>s" n],simp)

lemma stream_take_take_Suc [simp]: "stream_take n\<cdot>(stream_take (Suc n)\<cdot>s) =
                                    stream_take n\<cdot>s"
apply (simp add: po_eq_conv,auto)
 apply (simp add: stream_take_take_less)
apply (subgoal_tac "stream_take n\<cdot>s = stream_take n\<cdot>(stream_take n\<cdot>s)")
 apply (erule ssubst)
 apply (rule_tac monofun_cfun_arg)
 apply (insert chain_stream_take [of s])
by (simp add: chain_def,simp)
*)

lemma slen_take_eq: "\<forall>x. enat n < #x \<longleftrightarrow> stream_take n\<cdot>x \<noteq> x"
apply (induct_tac n, auto)
apply (simp add: enat_0, clarsimp)
apply (drule not_sym)
apply (drule slen_empty_eq [THEN iffD1], simp)
apply (case_tac "x=UU", simp)
apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
apply (erule_tac x="y" in allE, auto)
apply (simp_all add: not_less eSuc_enat)
apply (case_tac "#y") apply simp_all
apply (case_tac "x=UU", simp)
apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
apply (erule_tac x="y" in allE, simp)
apply (case_tac "#y")
apply simp_all
done

lemma slen_take_eq_rev: "#x \<le> enat n \<longleftrightarrow> stream_take n\<cdot>x = x"
by (simp add: linorder_not_less [symmetric] slen_take_eq)

lemma slen_take_lemma1: "#x = enat n \<Longrightarrow> stream_take n\<cdot>x = x"
by (rule slen_take_eq_rev [THEN iffD1], auto)

lemma slen_rt_mono: "#s2 \<le> #s1 \<Longrightarrow> #(rt\<cdot>s2) \<le> #(rt\<cdot>s1)"
apply (cases s1)
 apply (cases s2, simp+)+
done

lemma slen_take_lemma5: "#(stream_take n\<cdot>s) \<le> enat n"
apply (case_tac "stream_take n\<cdot>s = s")
 apply (simp add: slen_take_eq_rev)
apply (simp add: slen_take_lemma4)
done

lemma slen_take_lemma2: "\<forall>x. \<not> stream_finite x \<longrightarrow> #(stream_take i\<cdot>x) = enat i"
apply (simp add: stream.finite_def, auto)
apply (simp add: slen_take_lemma4)
done

lemma slen_infinite: "stream_finite x \<longleftrightarrow> #x \<noteq> \<infinity>"
by (simp add: slen_def)

lemma slen_mono_lemma: "stream_finite s \<Longrightarrow> \<forall>t. s \<sqsubseteq> t \<longrightarrow> #s \<le> #t"
apply (erule stream_finite_ind [of s], auto)
apply (case_tac "t = UU", auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
done

lemma slen_mono: "s \<sqsubseteq> t \<Longrightarrow> #s \<le> #t"
apply (case_tac "stream_finite t")
apply (frule stream_finite_less)
apply (erule_tac x="s" in allE, simp)
apply (drule slen_mono_lemma, auto)
apply (simp add: slen_def)
done

lemma iterate_lemma: "F\<cdot>(iterate n\<cdot>F\<cdot>x) = iterate n\<cdot>F\<cdot>(F\<cdot>x)"
by (insert iterate_Suc2 [of n F x], auto)

lemma slen_rt_mult [rule_format]: "\<forall>x. enat (i + j) \<le> #x \<longrightarrow> enat j \<le> #(iterate i\<cdot>rt\<cdot>x)"
apply (induct i, auto)
apply (case_tac "x = UU", auto simp add: zero_enat_def)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
apply (erule_tac x = "y" in allE, auto)
apply (simp add: not_le) apply (case_tac "#y") apply (simp_all add: eSuc_enat)
apply (simp add: iterate_lemma)
done

lemma slen_take_lemma3 [rule_format]:
  "\<forall>(x::'a::flat stream) y. enat n \<le> #x \<longrightarrow> x \<sqsubseteq> y \<longrightarrow> stream_take n\<cdot>x = stream_take n\<cdot>y"
apply (induct_tac n, auto)
apply (case_tac "x=UU", auto)
apply (simp add: zero_enat_def)
apply (simp add: Suc_ile_eq)
apply (case_tac "y=UU", clarsimp)
apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)+
apply (erule_tac x="ya" in allE, simp)
by (drule ax_flat, simp)

lemma slen_strict_mono_lemma:
  "stream_finite t \<Longrightarrow> \<forall>s. #(s::'a::flat stream) = #t \<and> s \<sqsubseteq> t \<longrightarrow> s = t"
apply (erule stream_finite_ind, auto)
apply (case_tac "sa = UU", auto)
apply (drule stream_exhaust_eq [THEN iffD1], clarsimp)
apply (drule ax_flat, simp)
done

lemma slen_strict_mono: "\<lbrakk>stream_finite t; s \<noteq> t; s \<sqsubseteq> (t::'a::flat stream)\<rbrakk> \<Longrightarrow> #s < #t"
by (auto simp add: slen_mono less_le dest: slen_strict_mono_lemma)

lemma stream_take_Suc_neq: "stream_take (Suc n)\<cdot>s \<noteq> s \<Longrightarrow>
                     stream_take n\<cdot>s \<noteq> stream_take (Suc n)\<cdot>s"
apply auto
apply (subgoal_tac "stream_take n\<cdot>s \<noteq> s")
 apply (insert slen_take_lemma4 [of n s],auto)
apply (cases s, simp)
apply (simp add: slen_take_lemma4 eSuc_enat)
done

(* ----------------------------------------------------------------------- *)
(* theorems about smap                                                     *)
(* ----------------------------------------------------------------------- *)

section "smap"

lemma smap_unfold: "smap = (\<Lambda> f t. case t of x && xs \<Rightarrow> f\<cdot>x && smap\<cdot>f\<cdot>xs)"
by (insert smap_def [where 'a='a and 'b='b, THEN eq_reflection, THEN fix_eq2], auto)

lemma smap_empty [simp]: "smap\<cdot>f\<cdot>\<bottom> = \<bottom>"
by (subst smap_unfold, simp)

lemma smap_scons [simp]: "x \<noteq> \<bottom> \<Longrightarrow> smap\<cdot>f\<cdot>(x && xs) = (f\<cdot>x) && (smap\<cdot>f\<cdot>xs)"
by (subst smap_unfold, force)

(* ----------------------------------------------------------------------- *)
(* theorems about sfilter                                                  *)
(* ----------------------------------------------------------------------- *)

section "sfilter"

lemma sfilter_unfold:
 "sfilter = (\<Lambda> p s. case s of x && xs \<Rightarrow>
  If p\<cdot>x then x && sfilter\<cdot>p\<cdot>xs else sfilter\<cdot>p\<cdot>xs)"
by (insert sfilter_def [where 'a='a, THEN eq_reflection, THEN fix_eq2], auto)

lemma strict_sfilter: "sfilter\<cdot>\<bottom> = \<bottom>"
apply (rule cfun_eqI)
apply (subst sfilter_unfold, auto)
apply (case_tac "x=UU", auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
done

lemma sfilter_empty [simp]: "sfilter\<cdot>f\<cdot>\<bottom> = \<bottom>"
by (subst sfilter_unfold, force)

lemma sfilter_scons [simp]:
  "x \<noteq> \<bottom> \<Longrightarrow> sfilter\<cdot>f\<cdot>(x && xs) =
                           If f\<cdot>x then x && sfilter\<cdot>f\<cdot>xs else sfilter\<cdot>f\<cdot>xs"
by (subst sfilter_unfold, force)

(* ----------------------------------------------------------------------- *)
   section "i_rt"
(* ----------------------------------------------------------------------- *)

lemma i_rt_UU [simp]: "i_rt n UU = UU"
  by (induct n) (simp_all add: i_rt_def)

lemma i_rt_0 [simp]: "i_rt 0 s = s"
by (simp add: i_rt_def)

lemma i_rt_Suc [simp]: "a \<noteq> UU \<Longrightarrow> i_rt (Suc n) (a&&s) = i_rt n s"
by (simp add: i_rt_def iterate_Suc2 del: iterate_Suc)

lemma i_rt_Suc_forw: "i_rt (Suc n) s = i_rt n (rt\<cdot>s)"
by (simp only: i_rt_def iterate_Suc2)

lemma i_rt_Suc_back: "i_rt (Suc n) s = rt\<cdot>(i_rt n s)"
by (simp only: i_rt_def,auto)

lemma i_rt_mono: "x << s \<Longrightarrow> i_rt n x  << i_rt n s"
by (simp add: i_rt_def monofun_rt_mult)

lemma i_rt_ij_lemma: "enat (i + j) \<le> #x \<Longrightarrow> enat j \<le> #(i_rt i x)"
by (simp add: i_rt_def slen_rt_mult)

lemma slen_i_rt_mono: "#s2 \<le> #s1 \<Longrightarrow> #(i_rt n s2) \<le> #(i_rt n s1)"
apply (induct_tac n,auto)
apply (simp add: i_rt_Suc_back)
apply (drule slen_rt_mono,simp)
done

lemma i_rt_take_lemma1 [rule_format]: "\<forall>s. i_rt n (stream_take n\<cdot>s) = UU"
apply (induct_tac n)
 apply (simp add: i_rt_Suc_back,auto)
apply (case_tac "s=UU",auto)
apply (drule stream_exhaust_eq [THEN iffD1],auto)
done

lemma i_rt_slen: "i_rt n s = UU \<longleftrightarrow> stream_take n\<cdot>s = s"
apply auto
 apply (insert i_rt_ij_lemma [of n "Suc 0" s])
 apply (subgoal_tac "#(i_rt n s)=0")
  apply (case_tac "stream_take n\<cdot>s = s",simp+)
  apply (insert slen_take_eq [rule_format,of n s],simp)
  apply (cases "#s") apply (simp_all add: zero_enat_def)
  apply (simp add: slen_take_eq)
  apply (cases "#s")
  using i_rt_take_lemma1 [of n s]
  apply (simp_all add: zero_enat_def)
  done

lemma i_rt_lemma_slen: "#s=enat n \<Longrightarrow> i_rt n s = UU"
by (simp add: i_rt_slen slen_take_lemma1)

lemma stream_finite_i_rt [simp]: "stream_finite (i_rt n s) = stream_finite s"
apply (induct_tac n, auto)
 apply (cases s, auto simp del: i_rt_Suc)
apply (simp add: i_rt_Suc_back stream_finite_rt_eq)+
done

lemma take_i_rt_len_lemma: "\<forall>sl x j t. enat sl = #x \<and> n \<le> sl \<and>
                            #(stream_take n\<cdot>x) = enat t \<and> #(i_rt n x) = enat j
                                              \<longrightarrow> enat (j + t) = #x"
apply (induct n, auto)
 apply (simp add: zero_enat_def)
apply (case_tac "x=UU",auto)
 apply (simp add: zero_enat_def)
apply (drule stream_exhaust_eq [THEN iffD1],clarsimp)
apply (subgoal_tac "\<exists>k. enat k = #y",clarify)
 apply (erule_tac x="k" in allE)
 apply (erule_tac x="y" in allE,auto)
 apply (erule_tac x="THE p. Suc p = t" in allE,auto)
   apply (simp add: eSuc_def split: enat.splits)
  apply (simp add: eSuc_def split: enat.splits)
  apply (simp only: the_equality)
 apply (simp add: eSuc_def split: enat.splits)
 apply force
apply (simp add: eSuc_def split: enat.splits)
done

lemma take_i_rt_len:
"\<lbrakk>enat sl = #x; n \<le> sl; #(stream_take n\<cdot>x) = enat t; #(i_rt n x) = enat j\<rbrakk> \<Longrightarrow>
    enat (j + t) = #x"
by (blast intro: take_i_rt_len_lemma [rule_format])

(* ----------------------------------------------------------------------- *)
   section "i_th"
(* ----------------------------------------------------------------------- *)

lemma i_th_i_rt_step:
"[| i_th n s1 << i_th n s2; i_rt (Suc n) s1 << i_rt (Suc n) s2 |] ==>
   i_rt n s1 << i_rt n s2"
apply (simp add: i_th_def i_rt_Suc_back)
apply (cases "i_rt n s1", simp)
apply (cases "i_rt n s2", auto)
done

lemma i_th_stream_take_Suc [rule_format]:
 "\<forall>s. i_th n (stream_take (Suc n)\<cdot>s) = i_th n s"
apply (induct_tac n,auto)
 apply (simp add: i_th_def)
 apply (case_tac "s=UU",auto)
 apply (drule stream_exhaust_eq [THEN iffD1],auto)
apply (case_tac "s=UU",simp add: i_th_def)
apply (drule stream_exhaust_eq [THEN iffD1],auto)
apply (simp add: i_th_def i_rt_Suc_forw)
done

lemma i_th_last: "i_th n s && UU = i_rt n (stream_take (Suc n)\<cdot>s)"
apply (insert surjectiv_scons [of "i_rt n (stream_take (Suc n)\<cdot>s)"])
apply (rule i_th_stream_take_Suc [THEN subst])
apply (simp add: i_th_def  i_rt_Suc_back [symmetric])
by (simp add: i_rt_take_lemma1)

lemma i_th_last_eq:
"i_th n s1 = i_th n s2 \<Longrightarrow> i_rt n (stream_take (Suc n)\<cdot>s1) = i_rt n (stream_take (Suc n)\<cdot>s2)"
apply (insert i_th_last [of n s1])
apply (insert i_th_last [of n s2])
apply auto
done

lemma i_th_prefix_lemma:
"\<lbrakk>k \<le> n; stream_take (Suc n)\<cdot>s1 << stream_take (Suc n)\<cdot>s2\<rbrakk> \<Longrightarrow>
    i_th k s1 << i_th k s2"
apply (insert i_th_stream_take_Suc [of k s1, THEN sym])
apply (insert i_th_stream_take_Suc [of k s2, THEN sym],auto)
apply (simp add: i_th_def)
apply (rule monofun_cfun, auto)
apply (rule i_rt_mono)
apply (blast intro: stream_take_lemma10)
done

lemma take_i_rt_prefix_lemma1:
  "stream_take (Suc n)\<cdot>s1 << stream_take (Suc n)\<cdot>s2 \<Longrightarrow>
   i_rt (Suc n) s1 << i_rt (Suc n) s2 \<Longrightarrow>
   i_rt n s1 << i_rt n s2 \<and> stream_take n\<cdot>s1 << stream_take n\<cdot>s2"
apply auto
 apply (insert i_th_prefix_lemma [of n n s1 s2])
 apply (rule i_th_i_rt_step,auto)
apply (drule mono_stream_take_pred,simp)
done

lemma take_i_rt_prefix_lemma:
"\<lbrakk>stream_take n\<cdot>s1 << stream_take n\<cdot>s2; i_rt n s1 << i_rt n s2\<rbrakk> \<Longrightarrow> s1 << s2"
apply (case_tac "n=0",simp)
apply (auto)
apply (subgoal_tac "stream_take 0\<cdot>s1 << stream_take 0\<cdot>s2 \<and> i_rt 0 s1 << i_rt 0 s2")
 defer 1
 apply (rule zero_induct,blast)
 apply (blast dest: take_i_rt_prefix_lemma1)
apply simp
done

lemma streams_prefix_lemma: "s1 << s2 \<longleftrightarrow>
  (stream_take n\<cdot>s1 << stream_take n\<cdot>s2 \<and> i_rt n s1 << i_rt n s2)"
apply auto
  apply (simp add: monofun_cfun_arg)
 apply (simp add: i_rt_mono)
apply (erule take_i_rt_prefix_lemma,simp)
done

lemma streams_prefix_lemma1:
  "\<lbrakk>stream_take n\<cdot>s1 = stream_take n\<cdot>s2; i_rt n s1 = i_rt n s2\<rbrakk> \<Longrightarrow> s1 = s2"
apply (simp add: po_eq_conv,auto)
 apply (insert streams_prefix_lemma)
 apply blast+
done

(* ----------------------------------------------------------------------- *)
   section "sconc"
(* ----------------------------------------------------------------------- *)

lemma UU_sconc [simp]: " UU ooo s = s "
by (simp add: sconc_def zero_enat_def)

lemma scons_neq_UU: "a \<noteq> UU \<Longrightarrow> a && s \<noteq> UU"
by auto

lemma singleton_sconc [rule_format, simp]: "x \<noteq> UU \<longrightarrow> (x && UU) ooo y = x && y"
apply (simp add: sconc_def zero_enat_def eSuc_def split: enat.splits, auto)
apply (rule someI2_ex,auto)
 apply (rule_tac x="x && y" in exI,auto)
apply (simp add: i_rt_Suc_forw)
apply (case_tac "xa=UU",simp)
by (drule stream_exhaust_eq [THEN iffD1],auto)

lemma ex_sconc [rule_format]:
  "\<forall>k y. #x = enat k \<longrightarrow> (\<exists>w. stream_take k\<cdot>w = x \<and> i_rt k w = y)"
apply (case_tac "#x")
 apply (rule stream_finite_ind [of x],auto)
  apply (simp add: stream.finite_def)
  apply (drule slen_take_lemma1,blast)
 apply (simp_all add: zero_enat_def eSuc_def split: enat.splits)
apply (erule_tac x="y" in allE,auto)
apply (rule_tac x="a && w" in exI,auto)
done

lemma rt_sconc1: "enat n = #x \<Longrightarrow> i_rt n (x ooo y) = y"
apply (simp add: sconc_def split: enat.splits, arith?,auto)
apply (rule someI2_ex,auto)
apply (drule ex_sconc,simp)
done

lemma sconc_inj2: "\<lbrakk>enat n = #x; x ooo y = x ooo z\<rbrakk> \<Longrightarrow> y = z"
apply (frule_tac y=y in rt_sconc1)
apply (auto elim: rt_sconc1)
done

lemma sconc_UU [simp]:"s ooo UU = s"
apply (case_tac "#s")
 apply (simp add: sconc_def)
 apply (rule someI2_ex)
  apply (rule_tac x="s" in exI)
  apply auto
   apply (drule slen_take_lemma1,auto)
  apply (simp add: i_rt_lemma_slen)
 apply (drule slen_take_lemma1,auto)
 apply (simp add: i_rt_slen)
apply (simp add: sconc_def)
done

lemma stream_take_sconc [simp]: "enat n = #x \<Longrightarrow> stream_take n\<cdot>(x ooo y) = x"
apply (simp add: sconc_def)
apply (cases "#x")
apply auto
apply (rule someI2_ex, auto)
apply (drule ex_sconc,simp)
done

lemma scons_sconc [rule_format,simp]: "a \<noteq> UU \<longrightarrow> (a && x) ooo y = a && x ooo y"
apply (cases "#x",auto)
 apply (simp add: sconc_def eSuc_enat)
 apply (rule someI2_ex)
  apply (drule ex_sconc, simp)
 apply (rule someI2_ex, auto)
  apply (simp add: i_rt_Suc_forw)
  apply (rule_tac x="a && xa" in exI, auto)
 apply (case_tac "xaa=UU",auto)
 apply (drule stream_exhaust_eq [THEN iffD1],auto)
 apply (drule streams_prefix_lemma1,simp+)
apply (simp add: sconc_def)
done

lemma ft_sconc: "x \<noteq> UU \<Longrightarrow> ft\<cdot>(x ooo y) = ft\<cdot>x"
by (cases x) auto

lemma sconc_assoc: "(x ooo y) ooo z = x ooo y ooo z"
apply (case_tac "#x")
 apply (rule stream_finite_ind [of x],auto simp del: scons_sconc)
  apply (simp add: stream.finite_def del: scons_sconc)
  apply (drule slen_take_lemma1,auto simp del: scons_sconc)
 apply (case_tac "a = UU", auto)
by (simp add: sconc_def)

(* ----------------------------------------------------------------------- *)

lemma cont_sconc_lemma1: "stream_finite x \<Longrightarrow> cont (\<lambda>y. x ooo y)"
by (erule stream_finite_ind, simp_all)

lemma cont_sconc_lemma2: "\<not> stream_finite x \<Longrightarrow> cont (\<lambda>y. x ooo y)"
by (simp add: sconc_def slen_def)

lemma cont_sconc: "cont (\<lambda>y. x ooo y)"
apply (cases "stream_finite x")
apply (erule cont_sconc_lemma1)
apply (erule cont_sconc_lemma2)
done

lemma sconc_mono: "y << y' \<Longrightarrow> x ooo y << x ooo y'"
by (rule cont_sconc [THEN cont2mono, THEN monofunE])

lemma sconc_mono1 [simp]: "x << x ooo y"
by (rule sconc_mono [of UU, simplified])

(* ----------------------------------------------------------------------- *)

lemma empty_sconc [simp]: "x ooo y = UU \<longleftrightarrow> x = UU \<and> y = UU"
apply (case_tac "#x",auto)
   apply (insert sconc_mono1 [of x y])
   apply auto
done

(* ----------------------------------------------------------------------- *)

lemma rt_sconc [rule_format, simp]: "s \<noteq> UU \<longrightarrow> rt\<cdot>(s ooo x) = rt\<cdot>s ooo x"
by (cases s, auto)

lemma i_th_sconc_lemma [rule_format]:
  "\<forall>x y. enat n < #x \<longrightarrow> i_th n (x ooo y) = i_th n x"
apply (induct_tac n, auto)
apply (simp add: enat_0 i_th_def)
apply (simp add: slen_empty_eq ft_sconc)
apply (simp add: i_th_def)
apply (case_tac "x=UU",auto)
apply (drule stream_exhaust_eq [THEN iffD1], auto)
apply (erule_tac x="ya" in allE)
apply (case_tac "#ya")
apply simp_all
done

(* ----------------------------------------------------------------------- *)

lemma sconc_lemma [rule_format, simp]: "\<forall>s. stream_take n\<cdot>s ooo i_rt n s = s"
apply (induct_tac n,auto)
apply (case_tac "s=UU",auto)
apply (drule stream_exhaust_eq [THEN iffD1],auto)
done

(* ----------------------------------------------------------------------- *)
   subsection "pointwise equality"
(* ----------------------------------------------------------------------- *)

lemma ex_last_stream_take_scons: "stream_take (Suc n)\<cdot>s =
                     stream_take n\<cdot>s ooo i_rt n (stream_take (Suc n)\<cdot>s)"
by (insert sconc_lemma [of n "stream_take (Suc n)\<cdot>s"],simp)

lemma i_th_stream_take_eq:
  "\<And>n. \<forall>n. i_th n s1 = i_th n s2 \<Longrightarrow> stream_take n\<cdot>s1 = stream_take n\<cdot>s2"
apply (induct_tac n,auto)
apply (subgoal_tac "stream_take (Suc na)\<cdot>s1 =
                    stream_take na\<cdot>s1 ooo i_rt na (stream_take (Suc na)\<cdot>s1)")
 apply (subgoal_tac "i_rt na (stream_take (Suc na)\<cdot>s1) =
                    i_rt na (stream_take (Suc na)\<cdot>s2)")
  apply (subgoal_tac "stream_take (Suc na)\<cdot>s2 =
                    stream_take na\<cdot>s2 ooo i_rt na (stream_take (Suc na)\<cdot>s2)")
   apply (insert ex_last_stream_take_scons,simp)
  apply blast
 apply (erule_tac x="na" in allE)
 apply (insert i_th_last_eq [of _ s1 s2])
by blast+

lemma pointwise_eq_lemma[rule_format]: "\<forall>n. i_th n s1 = i_th n s2 \<Longrightarrow> s1 = s2"
by (insert i_th_stream_take_eq [THEN stream.take_lemma],blast)

(* ----------------------------------------------------------------------- *)
   subsection "finiteness"
(* ----------------------------------------------------------------------- *)

lemma slen_sconc_finite1:
  "\<lbrakk>#(x ooo y) = \<infinity>; enat n = #x\<rbrakk> \<Longrightarrow> #y = \<infinity>"
apply (case_tac "#y \<noteq> \<infinity>",auto)
apply (drule_tac y=y in rt_sconc1)
apply (insert stream_finite_i_rt [of n "x ooo y"])
apply (simp add: slen_infinite)
done

lemma slen_sconc_infinite1: "#x=\<infinity> \<Longrightarrow> #(x ooo y) = \<infinity>"
by (simp add: sconc_def)

lemma slen_sconc_infinite2: "#y=\<infinity> \<Longrightarrow> #(x ooo y) = \<infinity>"
apply (case_tac "#x")
 apply (simp add: sconc_def)
 apply (rule someI2_ex)
  apply (drule ex_sconc,auto)
 apply (erule contrapos_pp)
 apply (insert stream_finite_i_rt)
 apply (fastforce simp add: slen_infinite,auto)
by (simp add: sconc_def)

lemma sconc_finite: "#x \<noteq> \<infinity> \<and> #y \<noteq> \<infinity> \<longleftrightarrow> #(x ooo y) \<noteq> \<infinity>"
apply auto
  apply (metis not_infinity_eq slen_sconc_finite1)
 apply (metis not_infinity_eq slen_sconc_infinite1)
apply (metis not_infinity_eq slen_sconc_infinite2)
done

(* ----------------------------------------------------------------------- *)

lemma slen_sconc_mono3: "\<lbrakk>enat n = #x; enat k = #(x ooo y)\<rbrakk> \<Longrightarrow> n \<le> k"
apply (insert slen_mono [of "x" "x ooo y"])
apply (cases "#x") apply simp_all
apply (cases "#(x ooo y)") apply simp_all
done

(* ----------------------------------------------------------------------- *)
   subsection "finite slen"
(* ----------------------------------------------------------------------- *)

lemma slen_sconc: "\<lbrakk>enat n = #x; enat m = #y\<rbrakk> \<Longrightarrow> #(x ooo y) = enat (n + m)"
apply (case_tac "#(x ooo y)")
 apply (frule_tac y=y in rt_sconc1)
 apply (insert take_i_rt_len [of "THE j. enat j = #(x ooo y)" "x ooo y" n n m],simp)
 apply (insert slen_sconc_mono3 [of n x _ y],simp)
apply (insert sconc_finite [of x y],auto)
done

(* ----------------------------------------------------------------------- *)
   subsection "flat prefix"
(* ----------------------------------------------------------------------- *)

lemma sconc_prefix: "(s1::'a::flat stream) << s2 \<Longrightarrow> \<exists>t. s1 ooo t = s2"
apply (case_tac "#s1")
 apply (subgoal_tac "stream_take nat\<cdot>s1 = stream_take nat\<cdot>s2")
  apply (rule_tac x="i_rt nat s2" in exI)
  apply (simp add: sconc_def)
  apply (rule someI2_ex)
   apply (drule ex_sconc)
   apply (simp,clarsimp,drule streams_prefix_lemma1)
   apply (simp+,rule slen_take_lemma3 [of _ s1 s2])
  apply (simp+,rule_tac x="UU" in exI)
apply (insert slen_take_lemma3 [of _ s1 s2])
apply (rule stream.take_lemma,simp)
done

(* ----------------------------------------------------------------------- *)
   subsection "continuity"
(* ----------------------------------------------------------------------- *)

lemma chain_sconc: "chain S \<Longrightarrow> chain (\<lambda>i. (x ooo S i))"
by (simp add: chain_def,auto simp add: sconc_mono)

lemma chain_scons: "chain S \<Longrightarrow> chain (\<lambda>i. a && S i)"
apply (simp add: chain_def,auto)
apply (rule monofun_cfun_arg,simp)
done

lemma contlub_scons_lemma: "chain S \<Longrightarrow> (LUB i. a && S i) = a && (LUB i. S i)"
by (rule cont2contlubE [OF cont_Rep_cfun2, symmetric])

lemma finite_lub_sconc: "chain Y \<Longrightarrow> stream_finite x \<Longrightarrow>
                        (LUB i. x ooo Y i) = (x ooo (LUB i. Y i))"
apply (rule stream_finite_ind [of x])
 apply (auto)
apply (subgoal_tac "(LUB i. a && (s ooo Y i)) = a && (LUB i. s ooo Y i)")
 apply (force,blast dest: contlub_scons_lemma chain_sconc)
done

lemma contlub_sconc_lemma:
  "chain Y \<Longrightarrow> (LUB i. x ooo Y i) = (x ooo (LUB i. Y i))"
apply (case_tac "#x=\<infinity>")
 apply (simp add: sconc_def)
apply (drule finite_lub_sconc,auto simp add: slen_infinite)
done

lemma monofun_sconc: "monofun (\<lambda>y. x ooo y)"
by (simp add: monofun_def sconc_mono)

(* ----------------------------------------------------------------------- *)
   section "constr_sconc"
(* ----------------------------------------------------------------------- *)

lemma constr_sconc_UUs [simp]: "constr_sconc UU s = s"
by (simp add: constr_sconc_def zero_enat_def)

lemma "x ooo y = constr_sconc x y"
apply (case_tac "#x")
 apply (rule stream_finite_ind [of x],auto simp del: scons_sconc)
  defer 1
  apply (simp add: constr_sconc_def del: scons_sconc)
  apply (case_tac "#s")
   apply (simp add: eSuc_enat)
   apply (case_tac "a=UU",auto simp del: scons_sconc)
   apply (simp)
  apply (simp add: sconc_def)
 apply (simp add: constr_sconc_def)
apply (simp add: stream.finite_def)
apply (drule slen_take_lemma1,auto)
done

end


theory weird_nat_mul3acc_comm23
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S y2) z = add3acc Z y2 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul3acc :: "Nat => Nat => Nat => Nat" where
"mul3acc (Z) y z = Z"
| "mul3acc (S x2) (Z) z = Z"
| "mul3acc (S x2) (S x3) (Z) = Z"
| "mul3acc (S (Z)) (S (Z)) (S (Z)) = S Z"
| "mul3acc (S (Z)) (S (Z)) (S (S x5)) =
     S (add3acc
          (mul3acc Z Z (S x5))
          (add3acc
             (mul3acc (S Z) Z (S x5)) (mul3acc Z (S Z) (S x5))
             (mul3acc Z Z (S Z)))
          (add3acc Z Z (S x5)))"
| "mul3acc (S (Z)) (S (S x6)) (S x4) =
     S (add3acc
          (mul3acc Z (S x6) x4)
          (add3acc
             (mul3acc (S Z) (S x6) x4) (mul3acc Z (S Z) x4)
             (mul3acc Z (S x6) (S Z)))
          (add3acc Z (S x6) x4))"
| "mul3acc (S (S x7)) (S x3) (S x4) =
     S (add3acc
          (mul3acc (S x7) x3 x4)
          (add3acc
             (mul3acc (S Z) x3 x4) (mul3acc (S x7) (S Z) x4)
             (mul3acc (S x7) x3 (S Z)))
          (add3acc (S x7) x3 x4))"

(*hipster add3acc mul3acc *)

theorem x0 :
  "!! (x :: Nat) (y :: Nat) (z :: Nat) .
     (mul3acc x y z) = (mul3acc x z y)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(*File: Logic.thy
  Author: L Beringer & M Hofmann, LMU Munich
  Date: 05/12/2008
  Purpose: Definition of axiomatic semantics, with strong
           invariants, pre- and postconditions, and local assertions.
*)
(*<*)
theory Logic imports Language begin
(*>*)

section\<open>Axiomatic semantics\<close>

subsection\<open>Assertion forms\<close>

text\<open>We introduce two further kinds of states. Initial states do not
contain operand stacks, terminal states lack operand stacks and local
variables, but include return values.\<close>

type_synonym InitState = "Store \<times> Heap"
type_synonym TermState = "Heap \<times> Val"

text\<open>A judgements relating to a specific program point $C.m.l$
consists of pre- and post-conditions, an invariant, and
-- optionally -- a local annotation. Local pre-conditions and
annotations relate initial states to states,
i.e.~are of type\<close>

type_synonym Assn = "InitState \<Rightarrow> State \<Rightarrow> bool"

text\<open>Post-conditions additionally depend on a terminal state\<close>

type_synonym Post = "InitState \<Rightarrow> State \<Rightarrow> TermState \<Rightarrow> bool"

text\<open>Invariants hold for the heap components of all future
(reachable) states in the current frame as well as its subframes. They
relate these heaps to the current state and the initial state of the
current frame.\<close>

type_synonym Inv = "InitState \<Rightarrow> State \<Rightarrow> Heap \<Rightarrow> bool"

text\<open>Local annotations of a method implementation are collected in a
table of type\<close>

type_synonym ANNO = "(Label, Assn) AssList"

text\<open>Implicitly, the labels are always interpreted with respect to
the current method. In addition to such a table, the behaviour of
methods is specified by a partial-correctness assertion of type\<close>

type_synonym MethSpec = "InitState \<Rightarrow> TermState \<Rightarrow> bool"

text\<open>and a method invariant of type\<close>

type_synonym MethInv = "InitState \<Rightarrow> Heap \<Rightarrow> bool"

text\<open>A method invariant is expected to be satisfied by the heap
components of all states during the execution of the method, including
states in subframes, irrespectively of the termination behaviour.\<close>

text\<open>All method specifications are collected in a table of type\<close>

type_synonym MSPEC = "(Class \<times> Method, MethSpec \<times> MethInv \<times> ANNO) AssList"

text\<open>A table of this type assigns to each method a
partial-correctness specification, a method invariant, and a table of
local annotations for the instructions in this method.\<close>

subsection\<open>Proof system \label{SectionSPJudgementProofSystem}\<close>

text\<open>The proof system derives judgements of the form $G \rhd \lbrace
A \rbrace C,m,l \lbrace B \rbrace\; I$ where $A$ is a pre-condition,
$B$ is a post-condition, $I$ is a strong invariant, $C.m.l$ represents
a program point, and $G$ is a proof context (see below). The proof
system consists of syntax-directed rules and structural rules. These
rules are formulated in such a way that assertions in the conclusions
are unconstrained, i.e.~a rule can be directly applied to derive a
judgement. In the case of the syntax-directed rules, the hypotheses
require the derivation of related statements for the control flow
successor instructions. Judgements occurring as hypotheses involve
assertions that are notationally constrained, and relate to the
conclusions' assertions via uniform constructions that resemble
strongest postconditions in Hoare-style logics.\<close>

text\<open>On pre-conditions, the operator\<close>

definition SP_pre::"Mbody \<Rightarrow> Label \<Rightarrow> Assn \<Rightarrow> Assn"
where "SP_pre M l A = (\<lambda> s0 r . (\<exists> s l1 n. A s0 s \<and> (M,l,s,n,l1,r):Step))"

text\<open>constructs an assertion that holds of a state $r$ precisely if
the argument assertion $A$ held at the predecessor state of
$r$. Similar readings explain the constructions on post-conditions\<close>

definition SP_post::"Mbody \<Rightarrow> Label \<Rightarrow> Post \<Rightarrow> Post"
where "SP_post M l B = (\<lambda> s0 r t . (\<forall> s l1 n. (M,l,s,n,l1,r):Step \<longrightarrow> B s0 s t))"

text\<open>and invariants\<close>

definition SP_inv::"Mbody \<Rightarrow> Label \<Rightarrow> Inv \<Rightarrow> Inv"
where "SP_inv M l I = (\<lambda> s0 r h . \<forall> s l1 n. (M,l,s,n,l1,r):Step \<longrightarrow> I s0 s h)"

text\<open>For the basic instructions, the appearance of the single-step
execution relation in these constructions makes the
strongest-postcondition interpretation apparent, but could easily be
eliminated by unfolding the definition of \<open>Step\<close>. In the proof
rule for static method invocations, such a direct reference to the
operational semantics is clearly undesirable. Instead, the proof rule
extracts the invoked method's specification from the specification
table. In order to simplify the formulation of the proof rule, we
introduce three operators which manipulate the extracted assertions in
a similar way as the above \<open>SP\<close>-operators.\<close>

definition SINV_pre::"Var list \<Rightarrow> MethSpec \<Rightarrow> Assn \<Rightarrow> Assn" where
"SINV_pre par T A =
  (\<lambda> s0 s . (\<exists> ops1 ops2 S R h k w.
               (ops1,par,R,ops2) : Frame \<and> T (R, k) (h,w) \<and>
               A s0 (ops1,S,k) \<and> s = (w#ops2,S, h)))"

definition SINV_post::"Var list \<Rightarrow> MethSpec \<Rightarrow> Post \<Rightarrow> Post" where
"SINV_post par T B =
  (\<lambda> s0 s t . \<forall> ops1 ops2 S R h k w r.
               (ops1,par,R,ops2) : Frame \<longrightarrow> T (R, k) (h,w) \<longrightarrow>
               s=(w#ops2,S,h) \<longrightarrow> r=(ops1,S,k) \<longrightarrow> B s0 r t)"

definition SINV_inv::"Var list \<Rightarrow> MethSpec \<Rightarrow> Inv \<Rightarrow> Inv" where
"SINV_inv par T I =
  (\<lambda> s0 s h' . \<forall> ops1 ops2 S R h k w.
                (ops1,par,R,ops2) : Frame \<longrightarrow> T (R,k) (h,w) \<longrightarrow>
                s=(w#ops2,S,h) \<longrightarrow> I s0 (ops1,S,k) h')"

text\<open>The derivation system is formulated using contexts $G$ of
proof-theoretic assumptions representing local judgements. The type of
contexts is\<close>

type_synonym CTXT = "(Class \<times> Method \<times> Label, Assn \<times> Post \<times> Inv) AssList"

text\<open>The existence of the proof context also motivates that the
hypotheses in the syntax-directed rules are formulated using an
auxiliary judgement form, $G \rhd \langle A \rangle C,m,l \langle B
\rangle\; I$. Statements for this auxiliary form can be derived by
essentially two rules. The first rule, \<open>AX\<close>, allows us to
extract assumptions from the context, while the second rule, \<open>INJECT\<close>, converts an ordinary judgement $G \rhd \lbrace A \rbrace C,m,l
\lbrace B \rbrace\; I$ into $G \rhd \langle A \rangle C,m,l \langle B
\rangle\; I$. No rule is provided for a direct embedding in the
opposite direction. As a consequence of this formulation, contextual
assumptions cannot be used directly to justify a statement $G \rhd
\lbrace A \rbrace C,m,l \lbrace B \rbrace\; I$. Instead, the
extraction of such an assumption has to be followed by at least one
''proper'' (syntax-driven) rule. In particular, attempts to verify
jumps by assuming a judgement and immediately using it to prove the
rule's hypothesis are ruled out.  More specifically, the purpose of
this technical device will become obvious when we discharge the
context in the proof of soundness (Section
\ref{SectionContextElimination}). Here, each entry
$((C',m',l'),(A',B',I'))$ of the context will need to be justified by
a derivation $G \rhd \lbrace A' \rbrace C',m',l' \lbrace B' \rbrace\;
I'$. This justification should in principle be allowed to rely on
other entries of the context. However, an axiom rule for judgements
$G \rhd \lbrace A \rbrace C,m,l \lbrace B \rbrace\; I$ would allow a
trivial discharge of any context entry. The introduction of the
auxiliary judgement form $G \rhd \langle A \rangle C,m,l \langle B
\rangle\; I$ thus ensures that the discharge of a contextual
assumption involves at least one application of a "proper"
(i.e.~syntax-directed) rule. Rule \<open>INJECT\<close> is used to chain
together syntax-directed rules. Indeed, it allows us to discharge a
hypothesis $G \rhd \langle A \rangle C,m,l \langle B \rangle\; I$ of a
syntax-directed rule using a derivation of $G \rhd \lbrace A \rbrace
C,m,l \lbrace B \rbrace\; I$.\<close>

text\<open>The proof rules are defined relative to a fixed method
specification table $\mathit{MST}$.\<close>

axiomatization MST::MSPEC

text\<open>In Isabelle, the distinction between the two judgement forms may
for example be achieved by introducing a single judgement form that
includes a boolean flag, and definiing two pretty-printing notions.\<close>

inductive_set SP_Judgement ::
  "(bool \<times> CTXT \<times> Class \<times> Method \<times> Label \<times> Assn \<times> Post \<times> Inv) set"
and
 SP_Deriv :: "CTXT => Assn => Class => Method => Label =>
              Post => Inv => bool"
  ("_ \<rhd> \<lbrace> _ \<rbrace> _,_,_ \<lbrace> _ \<rbrace> _" [100,100,100,100,100,100,100] 50)
and
 SP_Assum :: "CTXT => Assn => Class => Method => Label =>
              Post => Inv => bool"
   ("_ \<rhd> \<langle> _ \<rangle> _,_,_ \<langle> _ \<rangle> _" [100,100,100,100,100,100,100] 50)
where
 "G \<rhd> \<lbrace> A \<rbrace> C,m,l \<lbrace> B \<rbrace> I == (False, G, C, m, l, A, B, I):SP_Judgement"
|
 "G \<rhd> \<langle> A \<rangle> C,m,l \<langle> B \<rangle> I == (True, G, C, m, l, A, B, I):SP_Judgement"
|
INSTR:
 "\<lbrakk> mbody_is C m M; get_ins M l = Some ins;
    lookup MST (C,m) = Some (Mspec,Minv,Anno);
    \<forall> Q . lookup Anno l = Some Q \<longrightarrow> (\<forall> s0 s . A s0 s \<longrightarrow> Q s0 s);
    \<forall> s0 s . A s0 s \<longrightarrow> I s0 s (heap s);
    ins \<in> { const c, dup, pop, swap, load x, store x, binop f, unop g,
            new d, getfield d F, putfield d F, checkcast d};
    G \<rhd> \<langle> (SP_pre M l A) \<rangle> C,m,(l+1) \<langle> (SP_post M l B) \<rangle> (SP_inv M l I) \<rbrakk>
 \<Longrightarrow> G \<rhd> \<lbrace> A \<rbrace> C,m,l \<lbrace> B \<rbrace> I"
|
GOTO:
 "\<lbrakk> mbody_is C m M; get_ins M l = Some (goto pc);
    MST\<down>(C,m) = Some (Mspec,Minv,Anno);
    \<forall> Q . Anno\<down>(l) = Some Q \<longrightarrow> (\<forall> s0 s . A s0 s \<longrightarrow> Q s0 s);
    \<forall> s0 s . A s0 s \<longrightarrow> I s0 s (heap s);
    G \<rhd> \<langle>SP_pre M l A\<rangle> C,m,pc \<langle>SP_post M l B\<rangle> (SP_inv M l I)\<rbrakk>
 \<Longrightarrow> G \<rhd> \<lbrace> A \<rbrace> C,m,l \<lbrace> B \<rbrace> I"
|
IF:
 "\<lbrakk> mbody_is C m M; get_ins M l = Some (iftrue pc);
    MST\<down>(C,m) = Some (Mspec,Minv,Anno);
    \<forall> Q . Anno\<down>(l) = Some Q \<longrightarrow> (\<forall> s0 s . A s0 s \<longrightarrow> Q s0 s);
    \<forall> s0 s . A s0 s \<longrightarrow> I s0 s (heap s);

    G \<rhd> \<langle> SP_pre M l (\<lambda> s0 s . (\<forall> ops S k . s=(TRUE#ops,S,k) \<longrightarrow> A s0 s))\<rangle>
        C,m,pc
        \<langle> SP_post M l (\<lambda> s0 s t .
           (\<forall> ops S k . s=(TRUE#ops,S,k) \<longrightarrow> B s0 s t))\<rangle>
        ( SP_inv M l (\<lambda> s0 s t .
           (\<forall> ops S k . s=(TRUE#ops,S,k) \<longrightarrow> I s0 s t)) );

    G \<rhd> \<langle> SP_pre M l (\<lambda> s0 s .
           (\<forall> ops S k v . s = (v#ops,S,k) \<longrightarrow> v \<noteq> TRUE \<longrightarrow> A s0 s))\<rangle>
         C,m,(l+1)
         \<langle> SP_post M l (\<lambda> s0 s t.
           (\<forall> ops S k v . s = (v#ops,S,k) \<longrightarrow> v \<noteq> TRUE \<longrightarrow> B s0 s t))\<rangle>
         ( SP_inv M l (\<lambda> s0 s t.
           (\<forall> ops S k v . s = (v#ops,S,k) \<longrightarrow> v \<noteq> TRUE \<longrightarrow> I s0 s t)) )\<rbrakk>
 \<Longrightarrow> G \<rhd> \<lbrace> A \<rbrace> C,m,l \<lbrace> B \<rbrace> I"
|
VRET:
 "\<lbrakk> mbody_is C m M; get_ins M l = Some vreturn;
    MST\<down>(C,m) = Some (Mspec,Minv,Anno);
    \<forall> Q . Anno\<down>(l) = Some Q \<longrightarrow> (\<forall> s0 s . A s0 s \<longrightarrow> Q s0 s);
    \<forall> s0 s . A s0 s \<longrightarrow> I s0 s (heap s);
    \<forall> s0 s . A s0 s \<longrightarrow> (\<forall> v ops S h . s = (v#ops,S,h) \<longrightarrow> B s0 s (h,v))\<rbrakk>
 \<Longrightarrow> G \<rhd> \<lbrace> A \<rbrace> C,m,l \<lbrace> B \<rbrace> I"
|
INVS:
 "\<lbrakk> mbody_is C m M; get_ins M l = Some (invokeS D m');
    MST\<down>(C,m) = Some (Mspec,Minv,Anno);
    MST\<down>(D,m') = Some (T,MI,Anno2); mbody_is D m' (par,code,l0);
    \<forall> Q . Anno\<down>(l) = Some Q \<longrightarrow> (\<forall> s0 s . A s0 s \<longrightarrow> Q s0 s);
    \<forall> s0 s . A s0 s \<longrightarrow> I s0 s (heap s);
    \<forall> s0 ops1 ops2 S R k t . (ops1,par,R,ops2) : Frame \<longrightarrow>
           A s0 (ops1,S,k) \<longrightarrow> MI (R,k) t \<longrightarrow> I s0 (ops1,S,k) t;
    G \<rhd> \<langle>SINV_pre par T A\<rangle> C,m,(l+1) \<langle>SINV_post par T B\<rangle>
        (SINV_inv par T I)\<rbrakk>
 \<Longrightarrow> G \<rhd> \<lbrace> A \<rbrace> C,m,l \<lbrace> B \<rbrace> I"
|
CONSEQ:
 "\<lbrakk> (b,G,C,m,l,AA,BB,II) \<in> SP_Judgement;
    \<forall> s0 s . A s0 s \<longrightarrow> AA s0 s; \<forall> s0 s t . BB s0 s t \<longrightarrow> B s0 s t;
    \<forall> s0 s k. II s0 s k \<longrightarrow> I s0 s k\<rbrakk>
 \<Longrightarrow> (b,G,C,m,l,A,B,I) \<in> SP_Judgement"
|
INJECT: "\<lbrakk> G \<rhd> \<lbrace> A \<rbrace> C,m,l \<lbrace> B \<rbrace> I\<rbrakk> \<Longrightarrow> G \<rhd> \<langle> A \<rangle> C,m,l \<langle> B \<rangle> I"
|
AX:
 "\<lbrakk> G\<down>(C,m,l) = Some (A,B,I); MST\<down>(C,m) = Some (Mspec,Minv,Anno);
    \<forall> Q . Anno\<down>(l) = Some Q \<longrightarrow> (\<forall> s0 s . A s0 s \<longrightarrow> Q s0 s);
    \<forall> s0 s . A s0 s \<longrightarrow> I s0 s (heap s)\<rbrakk>
 \<Longrightarrow> G \<rhd> \<langle> A \<rangle> C,m,l \<langle> B \<rangle> I"

text\<open>As a first consequence, we can prove by induction on the proof
system that a derivable judgement entails its strong invariant and an
annotation that may be attached to the instruction.\<close>

(*<*)
lemma AssertionsImplyInvariantsAux[rule_format]:
"G \<rhd> \<lbrace> A \<rbrace> C,m,l \<lbrace> B \<rbrace> I \<Longrightarrow>
  ((\<forall> s0 s t. A s0 s \<longrightarrow> I s0 s (heap s)) \<and>
   (\<forall> Mspec Minv Anno .
        MST\<down>(C,m) = Some (Mspec,Minv,Anno) \<longrightarrow>
        (\<forall> Q . Anno\<down>(l) = Some Q \<longrightarrow>
               (\<forall> s0 s . A s0 s \<longrightarrow> Q s0 s))))"
apply (erule SP_Judgement.induct)
apply clarsimp
apply clarsimp
apply clarsimp
apply clarsimp
apply clarsimp
apply clarsimp
apply clarsimp (*fast*)
apply clarsimp (*fast*)
done
(*>*)
lemma AssertionsImplyMethInvariants:
 "\<lbrakk> G \<rhd> \<lbrace> A \<rbrace> C,m,l \<lbrace> B \<rbrace> I; A s0 s\<rbrakk> \<Longrightarrow> I s0 s (heap s)"
(*<*)
by (drule AssertionsImplyInvariantsAux, fast)
(*>*)

lemma AssertionsImplyAnnoInvariants:
 "\<lbrakk> G \<rhd> \<lbrace> A \<rbrace> C,m,l \<lbrace> B \<rbrace> I; MST\<down>(C,m) = Some(Mspec,Minv,Anno);
    Anno\<down>(l) = Some Q; A s0 s\<rbrakk> \<Longrightarrow> Q s0 s"
(*<*)
by (drule AssertionsImplyInvariantsAux, fast)
(*>*)

text\<open>For \emph{verified} \emph{programs}, all preconditions can be
justified by proof derivations, and initial labels of all methods
(again provably) satisfy the method preconditions.\<close>

definition mkState::"InitState \<Rightarrow> State"
where "mkState s0 = ([],fst s0,snd s0)"

definition mkPost::"MethSpec \<Rightarrow> Post"
where "mkPost T = (\<lambda> s0 s t . s=mkState s0 \<longrightarrow> T s0 t)"

definition mkInv::"MethInv \<Rightarrow> Inv"
where "mkInv MI = (\<lambda> s0 s t . s=mkState s0 \<longrightarrow> MI s0 t)"

definition VP_G::"CTXT \<Rightarrow> bool" where
"VP_G G =
  ((\<forall> C m l A B I. G\<down>(C,m,l) = Some (A,B,I) \<longrightarrow> G \<rhd> \<lbrace>A\<rbrace> C,m,l \<lbrace>B\<rbrace> I) \<and>
  (\<forall> C m par code l0 T MI Anno.
      mbody_is C m (par,code,l0) \<longrightarrow> MST\<down>(C,m) = Some(T,MI,Anno) \<longrightarrow>
      G \<rhd> \<lbrace>(\<lambda> s0 s. s = mkState s0)\<rbrace> C,m,l0 \<lbrace>mkPost T\<rbrace> (mkInv MI)))"

definition VP::bool where "VP = (\<exists> G . VP_G G)"

(*<*)
end
(*>*)