(******************************************************************************
 * Orca: A Functional Correctness Verifier for Imperative Programs
 *       Based on Isabelle/UTP
 *
 * Copyright (c) 2016-2018 Virginia Tech, USA
 *               2016-2018 Technische Universität München, Germany
 *               2016-2018 University of York, UK
 *               2016-2018 Université Paris-Saclay, Univ. Paris-Sud, France
 *
 * This software may be distributed and modified according to the terms of
 * the GNU Lesser General Public License version 3.0 or any later version.
 * Note that NO WARRANTY is provided.
 *
 * See CONTRIBUTORS, LICENSE and CITATION files for details.
 ******************************************************************************)

theory utp_rec_total_des
  imports "../AlgebraicLaws/Algebraic_laws_design"
begin
section {*Total correctness for recursion*}

subsection {*AUX lemmas on healthy fixed points*}

lemma nu_design_is_healthy_des[simp]: (*This should be generated automatically in utp_theory*)
  "\<nu>\<^sub>D F is \<H>\<^bsub>DES\<^esub>"
  by (simp add: is_Hcarrier_is_hdesigns)

lemma nu_normal_design_is_healthy_des[simp]: (*This should be generated automatically in utp_theory*)
  "\<nu>\<^sub>N F is \<H>\<^bsub>NDES\<^esub>"
  by (simp add: is_Ncarrier_is_ndesigns)

lemma mu_design_is_healthy_des[simp]: (*This should be generated automatically in utp_theory*)
  "\<mu>\<^sub>D F is \<H>\<^bsub>DES\<^esub>"
  by (simp add: is_Hcarrier_is_hdesigns)

lemma mu_normal_design_is_healthy_des[simp]: (*This should be generated automatically in utp_theory*)
  "\<mu>\<^sub>N F is \<H>\<^bsub>NDES\<^esub>"
  by (simp add: is_Ncarrier_is_ndesigns)

lemma  design_nu_wf_refine_intro:
  assumes   WF: "wf R"
    and      M: "Mono\<^bsub>uthy_order DES\<^esub> F"
    and      H: "F \<in> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H"
    and      Okey1:"$ok\<acute> \<sharp> p"
    and      Okey2:"$ok\<acute> \<sharp> e"
    and  induct_step:
    "\<And>st. ((p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile> q) \<sqsubseteq> (F((p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile> q))"
  shows "(p \<turnstile> q) \<sqsubseteq> \<nu>\<^sub>D F"
proof -
  {
    fix st
    have "(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile> q \<sqsubseteq> \<nu>\<^sub>D F"
      using WF proof (induction rule: wf_induct_rule)
      case (less st)
      hence 0: "(p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile> q \<sqsubseteq> \<nu>\<^sub>D F"
        by rel_blast
      from M H design_theory_continuous.GFP_lemma2 mono_Monotone_utp_order
      have 1: " (\<nu>\<^sub>D F) \<sqsubseteq> F(\<nu>\<^sub>D F)"
        by blast
      from 0 1 have 2:" (p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile> q \<sqsubseteq> F (\<nu>\<^sub>D F)"
        by simp
      have 3: "F ((p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile> q) \<sqsubseteq> F (\<nu>\<^sub>D F)"
      proof (rule Mono_utp_orderD[OF M "nu_design_is_healthy_des" "design_is_healthy_DES_intro" 0], goal_cases)
        case 1
        then show ?case by (simp add: Okey1 Okey2 unrest)
      qed
      have 4:"(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile> q \<sqsubseteq> \<dots>"
        by (rule induct_step)
      show ?case
        using order_trans[OF 3 4] Okey1 H M design_theory_continuous.GFP_lemma3 dual_order.trans mono_Monotone_utp_order
        by blast
    qed
  }
  thus ?thesis
    by pred_simp
qed

lemma  design_mu_wf_refine_intro:
  assumes   WF: "wf R"
    and      M: "Mono\<^bsub>uthy_order DES\<^esub> F"
    and      H: "F \<in> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H"
    and      Okey1:"$ok\<acute> \<sharp> p"
    and      Okey2:"$ok\<acute> \<sharp> e"
    and  induct_step:
    "\<And>st. ((p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile> q) \<sqsubseteq> (F((p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile> q))"
  shows "(p \<turnstile> q) \<sqsubseteq> \<mu>\<^sub>D  F"
proof -
  {
    fix st
    have "(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile> q \<sqsubseteq> \<mu>\<^sub>D F"
      using WF proof (induction rule: wf_induct_rule)
      case (less st)
      hence 0: "(p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile> q \<sqsubseteq> \<mu>\<^sub>D F"
        by rel_blast
      from M H design_theory_continuous.LFP_lemma3 mono_Monotone_utp_order
      have 1: "\<mu>\<^sub>D F \<sqsubseteq>  F (\<mu>\<^sub>D F)"
        by blast
      from 0 1 have 2:"(p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile> q \<sqsubseteq> F (\<mu>\<^sub>D F)"
        by simp
      have 3: "F ((p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile> q) \<sqsubseteq> F (\<mu>\<^sub>D F)"
      proof (rule Mono_utp_orderD[OF M "mu_design_is_healthy_des" "design_is_healthy_DES_intro" 0], goal_cases)
        case 1
        then show ?case by (simp add: Okey2 Okey1 unrest)
      qed
      have 4:"(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile> q \<sqsubseteq> \<dots>"
        by (rule induct_step)
      show ?case
        using order_trans[OF 3 4] Okey1 H M design_theory_continuous.LFP_lemma2 dual_order.trans mono_Monotone_utp_order
        by blast
    qed
  }
  thus ?thesis
    by pred_simp
qed

lemma rdesign_nu_wf_refine_intro:
  assumes   WF: "wf R"
    and      M: "Mono\<^bsub>uthy_order DES\<^esub> F"
    and      H: "F \<in> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H"
    and  induct_step:
    "\<And>st. ((p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>r q) \<sqsubseteq> (F ((p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>r q))"
  shows "(p \<turnstile>\<^sub>r q) \<sqsubseteq> \<nu>\<^sub>D F"
proof -
  {
  fix st
  have "(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>r q \<sqsubseteq> \<nu>\<^sub>D F"
    using WF proof (induction rule: wf_induct_rule)
    case (less st)
    hence 0: "(p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>r q \<sqsubseteq> \<nu>\<^sub>D F"
      by rel_blast
    from M H design_theory_continuous.GFP_lemma2 mono_Monotone_utp_order
    have 1: "\<nu>\<^sub>D F \<sqsubseteq>  F (\<nu>\<^sub>D F)"
      by blast
    from 0 1 have 2:"(p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>r q \<sqsubseteq> F (\<nu>\<^sub>D F)"
      by simp
    have 3: "F ((p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>r q) \<sqsubseteq> F (\<nu>\<^sub>D F)"
      by (auto intro: Mono_utp_orderD M 0)
    have 4:"(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>r q \<sqsubseteq> \<dots>"
      by (rule induct_step)
    show ?case
      using order_trans[OF 3 4] H M design_theory_continuous.GFP_lemma3 dual_order.trans mono_Monotone_utp_order
      by blast
  qed
  }
  thus ?thesis
    by pred_simp
qed

lemma rdesign_mu_wf_refine_intro:
  assumes   WF: "wf R"
    and      M: "Mono\<^bsub>uthy_order DES\<^esub> F"
    and      H: "F \<in> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>H\<rbrakk>\<^sub>H"
    and  induct_step:
    "\<And>st. ((p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>r q) \<sqsubseteq> (F ((p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>r q))"
  shows "(p \<turnstile>\<^sub>r q) \<sqsubseteq> \<mu>\<^sub>D F"
proof -
  {
  fix st
  have "(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>r q \<sqsubseteq> \<mu>\<^sub>D F"
    using WF proof (induction rule: wf_induct_rule)
    case (less st)
    hence 0: "(p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>r q \<sqsubseteq> \<mu>\<^sub>D F"
      by rel_blast
    from M H design_theory_continuous.LFP_lemma3 mono_Monotone_utp_order
    have 1: "\<mu>\<^sub>D F \<sqsubseteq>  F (\<mu>\<^sub>D F)"
      by blast
    from 0 1 have 2:"(p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>r q \<sqsubseteq> F (\<mu>\<^sub>D F)"
      by simp
    have 3: "F ((p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>r q) \<sqsubseteq> F (\<mu>\<^sub>D F)"
      by (auto intro: Mono_utp_orderD M 0)
    have 4:"(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>r q \<sqsubseteq> \<dots>"
      by (rule induct_step)
    show ?case
      using order_trans[OF 3 4] H M design_theory_continuous.LFP_lemma2 dual_order.trans mono_Monotone_utp_order
      by blast
  qed
  }
  thus ?thesis
    by pred_simp
qed

lemma ndesign_nu_wf_refine_intro:
  assumes   WF: "wf R"
    and      M: "Mono\<^bsub>uthy_order NDES\<^esub> F"
    and      H: "F \<in> \<lbrakk>\<^bold>N\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>N\<rbrakk>\<^sub>H"
    and  induct_step:
    "\<And>st. ((p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>n q) \<sqsubseteq> (F ((p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n q))"
  shows "(p \<turnstile>\<^sub>n q) \<sqsubseteq> \<nu>\<^sub>N F"
proof -
  {
  fix st
  have "(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>n q \<sqsubseteq> \<nu>\<^sub>N F"
    using WF proof (induction rule: wf_induct_rule)
    case (less st)
    hence 0: "(p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n q \<sqsubseteq> \<nu>\<^sub>N F"
      by rel_blast
    from M H normal_design_theory_continuous.GFP_lemma2 mono_Monotone_utp_order
    have 1: "\<nu>\<^sub>N F \<sqsubseteq>  F (\<nu>\<^sub>N F)"
      by blast
    from 0 1 have 2:"(p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n q \<sqsubseteq> F (\<nu>\<^sub>N F)"
      by simp
    have 3: "F((p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n q) \<sqsubseteq> F (\<nu>\<^sub>N F)"
      by (auto intro: Mono_utp_orderD M 0)
    have 4:"(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>n q \<sqsubseteq> \<dots>"
      by (rule induct_step)
    show ?case
      using order_trans[OF 3 4] H M normal_design_theory_continuous.GFP_lemma3 dual_order.trans mono_Monotone_utp_order
      by blast
  qed
  }
  thus ?thesis
    by pred_simp
qed

lemma ndesign_mu_wf_refine_intro:
  assumes   WF: "wf R"
    and      M: "Mono\<^bsub>uthy_order NDES\<^esub> F"
    and      H: "F \<in> \<lbrakk>\<^bold>N\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<^bold>N\<rbrakk>\<^sub>H"
    and  induct_step:
    "\<And>st. ((p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>n q) \<sqsubseteq> (F ((p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n q))"
  shows "(p \<turnstile>\<^sub>n q) \<sqsubseteq> \<mu>\<^sub>N F"
proof -
  {
  fix st
  have "(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>n q \<sqsubseteq> \<mu>\<^sub>N F"
    using WF proof (induction rule: wf_induct_rule)
    case (less st)
    hence 0: "(p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n q \<sqsubseteq> \<mu>\<^sub>N F"
      by rel_blast
    from M H normal_design_theory_continuous.LFP_lemma3 mono_Monotone_utp_order
    have 1: "\<mu>\<^sub>N F \<sqsubseteq>  F (\<mu>\<^sub>N F)"
      by blast
    from 0 1 have 2:"(p \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u\<in>\<^sub>u\<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n q \<sqsubseteq> F (\<mu>\<^sub>N F)"
      by simp
    have 3: "F((p \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>) \<turnstile>\<^sub>n q) \<sqsubseteq> F (\<mu>\<^sub>N F)"
      by (auto intro: Mono_utp_orderD M 0)
    have 4:"(p \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>) \<turnstile>\<^sub>n q \<sqsubseteq> \<dots>"
      by (rule induct_step)
    show ?case
      using order_trans[OF 3 4] H M normal_design_theory_continuous.LFP_lemma2 dual_order.trans mono_Monotone_utp_order
      by blast
  qed
  }
  thus ?thesis
    by pred_simp
qed
end


(*  Title:       Compose
    Authors:     Jasmin Blanchette, Andrei Popescu, Dmitriy Traytel
    Maintainer:  Dmitriy Traytel <traytel at inf.ethz.ch>
*)

section \<open>Normalized Composition of BNFs\<close>

text \<open>Expected normal form: outer m-ary BNF is composed with m inner n-ary BNFs.\<close>

(*<*)
theory Compose
  imports "HOL-Library.BNF_Axiomatization"
begin
(*>*)

unbundle cardinal_syntax

declare [[bnf_internals]]
bnf_axiomatization (dead 'p1, F1set1: 'a1, F1set2: 'a2) F1
  [wits: "('p1, 'a1, 'a2) F1"]
  for map: F1map rel: F1rel
bnf_axiomatization (dead 'p2, F2set1: 'a1, F2set2: 'a2) F2
  [wits: "'a1 \<Rightarrow> ('p2, 'a1, 'a2) F2" "'a2 \<Rightarrow> ('p2, 'a1, 'a2) F2"]
  for map: F2map rel: F2rel
bnf_axiomatization (dead 'p3, F3set1: 'a1, F3set2: 'a2) F3
  [wits: "'a1 \<Rightarrow> 'a2 \<Rightarrow> ('p3, 'a1, 'a2) F3"]
  for map: F3map rel: F3rel
bnf_axiomatization (dead 'p, Gset1: 'b1, Gset2: 'b2, Gset3: 'b3) G
  [wits: "'b1 \<Rightarrow> 'b3 \<Rightarrow> ('p, 'b1, 'b2, 'b3) G" "'b2 \<Rightarrow> 'b3 \<Rightarrow> ('p, 'b1, 'b2, 'b3) G"]
  for map: Gmap rel: Grel
type_synonym ('p1, 'p2, 'p3, 'p, 'a1, 'a2) H =
  "('p, ('p1, 'a1, 'a2) F1, ('p2, 'a1, 'a2) F2, ('p3, 'a1, 'a2) F3) G"
type_synonym ('p1, 'p2, 'p3, 'p) Hbd_type =
  "('p1 bd_type_F1 + 'p2 bd_type_F2 + 'p3 bd_type_F3) \<times> 'p bd_type_G"

abbreviation F1in where "F1in A1 A2 \<equiv> {x. F1set1 x \<subseteq> A1 \<and> F1set2 x \<subseteq> A2}"
abbreviation F2in where "F2in A1 A2 \<equiv> {x. F2set1 x \<subseteq> A1 \<and> F2set2 x \<subseteq> A2}"
abbreviation F3in where "F3in A1 A2 \<equiv> {x. F3set1 x \<subseteq> A1 \<and> F3set2 x \<subseteq> A2}"
abbreviation Gin where "Gin A1 A2 A3 \<equiv> {x. Gset1 x \<subseteq> A1 \<and> Gset2 x \<subseteq> A2 \<and> Gset3 x \<subseteq> A3}"

abbreviation Gset where
  "Gset \<equiv> BNF_Def.collect {Gset1, Gset2, Gset3}"

abbreviation Hmap :: "('a1 \<Rightarrow> 'b1) \<Rightarrow> ('a2 \<Rightarrow> 'b2) \<Rightarrow>
  ('p1, 'p2, 'p3, 'p, 'a1, 'a2) H \<Rightarrow> ('p1, 'p2, 'p3, 'p, 'b1, 'b2) H" where
  "Hmap f g \<equiv> Gmap (F1map f g) (F2map f g) (F3map f g)"

abbreviation Hset1 :: "('p1, 'p2, 'p3, 'p, 'a1, 'a2) H \<Rightarrow> 'a1 set" where
  "Hset1 \<equiv> Union o Gset o Gmap F1set1 F2set1 F3set1"

abbreviation Hset2 :: "('p1, 'p2, 'p3, 'p, 'a1, 'a2) H \<Rightarrow> 'a2 set" where
  "Hset2 \<equiv> Union o Gset o Gmap F1set2 F2set2 F3set2"

lemma Hset1_alt:
  "Hset1 = Union o BNF_Def.collect {image F1set1 o Gset1, image F2set1 o Gset2, image F3set1 o Gset3}"
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_set_alt_tac @{context} @{thm G.collect_set_map}\<close>)

lemma Hset2_alt:
  "Hset2 = Union o BNF_Def.collect {image F1set2 o Gset1, image F2set2 o Gset2, image F3set2 o Gset3}"
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_set_alt_tac @{context} @{thm G.collect_set_map}\<close>)

abbreviation Hbd where
  "Hbd \<equiv> (bd_F1 +c bd_F2 +c bd_F3) *c bd_G"

theorem Hmap_id: "Hmap id id = id"
  unfolding G.map_id0 F1.map_id0 F2.map_id0 F3.map_id0 ..

theorem Hmap_cong: "\<lbrakk>\<And>z. z \<in> Hset1 x \<Longrightarrow> f1 z = g1 z; \<And>z. z \<in> Hset2 x \<Longrightarrow> f2 z = g2 z\<rbrakk> \<Longrightarrow>
  Hmap f1 f2 x = Hmap g1 g2 x"
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_map_cong0_tac @{context}
  [] @{thms Hset1_alt Hset2_alt} @{thm G.map_cong0} @{thms F1.map_cong0 F2.map_cong0 F3.map_cong0}\<close>)

theorem Hset1_natural: "Hset1 o Hmap f1 f2 = image f1 o Hset1"
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_set_map0_tac @{context} @{thm refl} @{thm G.map_comp0} @{thm G.map_cong0}
  @{thm G.collect_set_map} @{thms F1.set_map0(1) F2.set_map0(1) F3.set_map0(1)}\<close>)

theorem Hbd_card_order: "card_order Hbd"
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_bd_card_order_tac @{context}
  @{thms F1.bd_card_order F2.bd_card_order F3.bd_card_order} @{thm G.bd_card_order}\<close>)

theorem Hbd_cinfinite: "cinfinite Hbd"
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_bd_cinfinite_tac @{context}
  @{thm F1.bd_cinfinite} @{thm G.bd_cinfinite}\<close>)

theorem Hset1_bd: "|Hset1 (x :: ('p1, 'p2, 'p3, 'p, 'a1, 'a2) H )| \<le>o
  (Hbd :: ('p1, 'p2, 'p3, 'p) Hbd_type rel)"
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_set_bd_tac @{context} @{thm refl} NONE @{thm Hset1_alt}
      @{thms comp_single_set_bd[OF F1.bd_Card_order F1.set_bd(1) G.set_bd(1)]
             comp_single_set_bd[OF F2.bd_Card_order F2.set_bd(1) G.set_bd(2)]
             comp_single_set_bd[OF F3.bd_Card_order F3.set_bd(1) G.set_bd(3)]}\<close>)

theorem Hset2_bd: "|Hset2 (x :: ('p1, 'p2, 'p3, 'p, 'a1, 'a2) H )| \<le>o
  (Hbd :: ('p1, 'p2, 'p3, 'p) Hbd_type rel)"
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_set_bd_tac @{context} @{thm refl} NONE @{thm Hset2_alt}
      @{thms comp_single_set_bd[OF F1.bd_Card_order F1.set_bd(2) G.set_bd(1)]
             comp_single_set_bd[OF F2.bd_Card_order F2.set_bd(2) G.set_bd(2)]
             comp_single_set_bd[OF F3.bd_Card_order F3.set_bd(2) G.set_bd(3)]}\<close>)

abbreviation Hin where "Hin A1 A2 \<equiv> {x. Hset1 x \<subseteq> A1 \<and> Hset2 x \<subseteq> A2}"

lemma Hin_alt: "Hin A1 A2 = Gin (F1in A1 A2) (F2in A1 A2) (F3in A1 A2)"
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_in_alt_tac @{context} @{thms Hset1_alt Hset2_alt}\<close>)

definition Hwit1 where "Hwit1 b c = wit1_G wit_F1 (wit_F3 b c)"
definition Hwit21 where "Hwit21 b c = wit2_G (wit1_F2 b) (wit_F3 b c)"
definition Hwit22 where "Hwit22 b c = wit2_G (wit2_F2 c) (wit_F3 b c)"

lemma Hwit1:
  "\<And>x. x \<in> Hset1 (Hwit1 b c) \<Longrightarrow> x = b"
  "\<And>x. x \<in> Hset2 (Hwit1 b c) \<Longrightarrow> x = c"
  unfolding Hwit1_def
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_wit_tac @{context} [] @{thms G.wit1 G.wit2}
  @{thm G.collect_set_map} @{thms F1.wit F2.wit1 F2.wit2 F3.wit}\<close>)

lemma Hwit21:
  "\<And>x. x \<in> Hset1 (Hwit21 b c) \<Longrightarrow> x = b"
  "\<And>x. x \<in> Hset2 (Hwit21 b c) \<Longrightarrow> x = c"
  unfolding Hwit21_def
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_wit_tac @{context} [] @{thms G.wit1 G.wit2}
  @{thm G.collect_set_map} @{thms F1.wit F2.wit1 F2.wit2 F3.wit}\<close>)

lemma Hwit22:
  "\<And>x. x \<in> Hset1 (Hwit22 b c) \<Longrightarrow> x = b"
  "\<And>x. x \<in> Hset2 (Hwit22 b c) \<Longrightarrow> x = c"
  unfolding Hwit22_def
  by (tactic \<open>BNF_Comp_Tactics.mk_comp_wit_tac @{context} [] @{thms G.wit1 G.wit2}
  @{thm G.collect_set_map} @{thms F1.wit F2.wit1 F2.wit2 F3.wit}\<close>)

(* Relator structure for H *)

lemma Grel_cong: "\<lbrakk>R1 = S1; R2 = S2; R3 = S3\<rbrakk> \<Longrightarrow> Grel R1 R2 R3 = Grel S1 S2 S3"
  by hypsubst (rule refl)

definition Hrel where
  "Hrel R1 R2 = (BNF_Def.Grp (Hin (Collect (case_prod R1)) (Collect (case_prod R2))) (Hmap fst fst))^--1 OO
                (BNF_Def.Grp (Hin (Collect (case_prod R1)) (Collect (case_prod R2))) (Hmap snd snd))"

lemmas Hrel_unfold = trans[OF Hrel_def trans[OF OO_Grp_cong[OF Hin_alt]
      trans[OF arg_cong2[of _ _ _ _ relcompp, OF trans[OF arg_cong[of _ _ conversep, OF sym[OF G.rel_Grp]] G.rel_conversep[symmetric]] sym[OF G.rel_Grp]]
        trans[OF G.rel_compp[symmetric] Grel_cong[OF sym[OF F1.rel_compp_Grp] sym[OF F2.rel_compp_Grp] sym[OF F3.rel_compp_Grp]]]]]]

bnf H: "('p1, 'p2, 'p3, 'p, 'a1, 'a2) H"
  map: Hmap
  sets: Hset1 Hset2
  bd: "Hbd :: ('p1, 'p2, 'p3, 'p) Hbd_type rel"
  rel: Hrel
            apply -
            apply (rule Hmap_id)
           apply (rule Hmap_comp)
          apply (erule Hmap_cong) apply assumption
         apply (rule Hset1_natural)
        apply (rule Hset2_natural)
       apply (rule Hbd_card_order)
      apply (rule Hbd_cinfinite)
     apply (rule Hset1_bd)
    apply (rule Hset2_bd)
   apply (unfold Hrel_unfold G.rel_compp[symmetric] F1.rel_compp[symmetric] F2.rel_compp[symmetric] F3.rel_compp[symmetric] eq_OO) [1] apply (rule order_refl)
  apply (rule Hrel_def[unfolded OO_Grp_alt mem_Collect_eq])
  done

(*<*)
end
(*>*)


(*
   Copyright 2016 Yoichi Hirai

   Licensed under the Apache License, Version 2.0 (the "License");
   you may not use this file except in compliance with the License.
   You may obtain a copy of the License at

       http://www.apache.org/licenses/LICENSE-2.0

   Unless required by applicable law or agreed to in writing, software
   distributed under the License is distributed on an "AS IS" BASIS,
   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
   See the License for the specific language governing permissions and
   limitations under the License.
*)

section {* What can Happen during a Contract Invocation *}

text {* This section defines a set of sequence of account states that can appeear during an
invocation of a countract.  The invocation can be a nested reentrancy, but we focus on one
invocation.  This means we do not look into details of further reentrancy, but just assume
that the inner reentrancy keeps the invariant of the contract.  Of course we need to prove
that the invariant holds for the code, but when we do that we can assume that the inner
nested calls keep the invariants (we can say we are doing mathematical induction on the depth
of reentrancy)\footnote{This poses troubles dealing with DELEGATECALL and CALLCODE instructions.
Currently execution of these instructions causes an immediate annotation failure.}.  *}

theory RelationalSem

imports Main "./ContractSem"

begin

subsection {* Some Possible Changes on Our Account State *}

text {* The account state might change even when the account's code is not executing. *}

text {* Between blocks, the account might gain balances because somebody mines
Eth for the account.  Even within a single block,
the balance might increase also while other contracts execute
because they might destroy themselves and send their balance to our account.
When a transaction finishes, if our contract is marked as killed, it is destroyed.
The following relation captures these possibilities.
*}

inductive account_state_natural_change :: "account_state \<Rightarrow> account_state \<Rightarrow> bool"
where
natural: -- {* The balance of this account might increase
whenever the code in our contract is not executing.  Some other account might
destroy itself and give its balance to our account.  *}
 "old_bal \<le> new_bal \<Longrightarrow>
  account_state_natural_change
   \<lparr> account_address = addr
   , account_storage = str
   , account_code = code
   , account_balance = old_bal
   , account_ongoing_calls = going
   , account_killed = killed
   \<rparr>
   \<lparr> account_address = addr
   , account_storage = str
   , account_code = code
   , account_balance = new_bal
   , account_ongoing_calls = going
   , account_killed = killed
   \<rparr>"
| cleaned: -- {* This happens only at the end of a transaction, but we don't know
              the transaction boundaries.
              So this can happen at any moment when there are no ongoing calls.  *}
  "account_state_natural_change
  \<lparr> account_address = addr
  , account_storage = str
  , account_code = code
  , account_balance = old_bal
  , account_ongoing_calls = []
  , account_killed = True
  \<rparr>
  (empty_account addr)"

declare account_state_natural_change.simps [simp]

text {* When the execution comes back from an external call, the account state might have changed
arbitrarily.  Our strategy is to assume that an invariant is kept here; and later prove that
the invariant actually holds (that is, for fewer depth of reentrancy).
The whole argument can be seen as a mathematical induction over depths of reentrancy, though
this idea has not been formalized yet. *}

inductive account_state_return_change ::
"(account_state \<Rightarrow> bool) \<Rightarrow> account_state \<Rightarrow> account_state \<Rightarrow> bool"
where
account_return:
"invariant
 \<lparr> account_address = addr
 , account_storage = new_str
 , account_code = code
 , account_balance = new_bal
 , account_ongoing_calls = ongoing
 , account_killed = new_killed
 \<rparr>
 \<Longrightarrow>
 account_state_return_change
 invariant
 \<lparr> account_address = addr
 , account_storage = old_str
 , account_code = code
 , account_balance = old_bal
 , account_ongoing_calls = ongoing
 , account_killed = killed
 \<rparr>
 \<lparr> account_address = addr
 , account_storage = new_str
 , account_code = code
 , account_balance = new_bal
 , account_ongoing_calls = ongoing
 , account_killed = new_killed
 \<rparr>
 "

declare account_state_return_change.simps [simp]

text "Next we specify which program results might see a return."

fun returnable_result :: "instruction_result \<Rightarrow> bool"
where
  "returnable_result (InstructionContinue _) = False"
| "returnable_result (InstructionToEnvironment (ContractCall _) _ _) = True"
| "returnable_result (InstructionToEnvironment (ContractDelegateCall _) _ _) = False"
| "returnable_result (InstructionToEnvironment (ContractCreate _) _ _) = True"
| "returnable_result (InstructionToEnvironment (ContractSuicide _) _ _) = False"
| "returnable_result (InstructionToEnvironment (ContractFail _) _ _) = False"
-- {* because we are not modeling nested calls here, the effect of the nested calls are modeled in
      account\_state\_return\_change *}
| "returnable_result (InstructionToEnvironment (ContractReturn _) _ _) = False"

fun returnable_from_delegate_call :: "instruction_result \<Rightarrow> bool"
where
  "returnable_from_delegate_call (InstructionContinue _) = False"
| "returnable_from_delegate_call (InstructionToEnvironment (ContractCall _) _ _) = False"
| "returnable_from_delegate_call (InstructionToEnvironment (ContractDelegateCall _) _ _) = True"
| "returnable_from_delegate_call (InstructionToEnvironment (ContractCreate _) _ _) = False"
| "returnable_from_delegate_call (InstructionToEnvironment (ContractSuicide _) _ _) = False"
| "returnable_from_delegate_call (InstructionToEnvironment (ContractFail _) _ _) = False"
-- {* because we are not modeling nested calls here, the effect of the nested calls are modeled in
      account\_state\_return\_change *}
| "returnable_from_delegate_call (InstructionToEnvironment (ContractReturn _) _ _) = False"

subsection {* A Round of the Game *}

text {* Now we are ready to specify the environment's turn. *}

datatype environment_input =
    Execution "instruction_result"
  | Init "call_env"

inductive environment_turn ::
"(account_state \<Rightarrow> bool) (* The invariant of our contract*)
\<Rightarrow> (account_state * environment_input)
   (* the account state before the environment's move
      and the last thing our account did *)
\<Rightarrow> (account_state * variable_ctx)
   (* the account state after the environment's move
      and the variable environment from which our contract must start. *)
\<Rightarrow> bool (* a boolean indicating if that is a possible environment's move. *)"
where
  environment_call: -- {* the environment might call our contract.  We only consider the initial invocation here
  because the deeper reentrant invocations are considered as a part of the adversarial environment.
  The deeper reentrant invocations are performed without the environment replying to the contract. *}
  "(* If a variable environment is built from the old account state *)
   (* and the call arguments, *)
   build_vctx_called old_state callargs next_vctx \<Longrightarrow>

   (* the environment makes a move, showing the variable environment. *)
   environment_turn I (old_state, Init callargs) (old_state, next_vctx)"
| environment_return: -- {* the environment might return to our contract. *}
  "(* If the account state can be changed during reentrancy,*)
   account_state_return_change I account_state_going_out account_state_back \<Longrightarrow>

   (* and a variable environment can be recovered from the changed account state,*)
   build_vctx_returned account_state_back result new_v \<Longrightarrow>

   (* and the previous move of the contract was a call-like action, *)
   returnable_result program_r \<Longrightarrow>

   (* the environment can make a move, telling the contract to continue with *)
   (* the variable environment. *)
   environment_turn I (account_state_going_out, Execution program_r)
                (account_state_pop_ongoing_call account_state_back, new_v)"

| environment_return_after_delegate_call: -- {* the environment might return to our contract. *}
  "(* If the account state can be changed during reentrancy,*)
   (* the account state might be completely broken *)
   build_vctx_returned account_state_back result new_v \<Longrightarrow>

   (* and the previous move of the contract was a call-like action, *)
   returnable_from_delegate_call program_r \<Longrightarrow>

   (* the environment can make a move, telling the contract to continue with *)
   (* the variable environment. *)
   environment_turn I (account_state_going_out, Execution program_r)
                (account_state_pop_ongoing_call account_state_back, new_v)"

| environment_fail: -- {* the environment might fail from an account into our contract. *}
  "(* If a variable environment can be recovered from the previous account state,*)
   build_vctx_failed account_state_going_out = Some new_v \<Longrightarrow>

   (* and if the previous action from the contract was a call, *)
   returnable_result result = True \<Longrightarrow>

   (* the environment can make a move, telling the contract to continue with *)
   (* the variable environment. *)
   environment_turn I (account_state_going_out, Execution result)
                (account_state_pop_ongoing_call account_state_going_out, new_v)"

text {* As a reply, our contract might make a move, or report an annotation failure.*}

inductive contract_turn ::
"network \<Rightarrow> (account_state * variable_ctx) \<Rightarrow> (account_state * environment_input) \<Rightarrow> bool"
where
  contract_to_environment:
  "(* Under a constant environment built from the old account state, *)
   build_cctx old_account = cctx \<Longrightarrow>

   (* if the program behaves like this, *)
   program_sem k cctx steps net (InstructionContinue old_vctx)
      = InstructionToEnvironment act v opt_v \<Longrightarrow>

   (* and if the account state is updated from the program's result, *)
   account_state_going_out
     = update_account_state old_account act v opt_v \<Longrightarrow>

   (* the contract makes a move and udates the account state. *)
   contract_turn net (old_account, old_vctx)
      (account_state_going_out, Execution (InstructionToEnvironment act v opt_v))"

text {* When we combine the environment's turn and the contract's turn, we get one round.
The round is a binary relation over a single set.
*}

inductive one_round ::
"network \<Rightarrow> (account_state \<Rightarrow> bool) \<Rightarrow>
(account_state * environment_input) \<Rightarrow>
(account_state * environment_input) \<Rightarrow> bool"
where
round:
"environment_turn I a b \<Longrightarrow> contract_turn net b c \<Longrightarrow> one_round net I a c"

subsection {* Repetitions of rounds *}

text {* So, we can repeat rounds and see where they bring us.  *}
text {* The definition is taken from the book Concrete Semantics, and then modified *}
inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
refl: "star r x x" |
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

text {* The repetition of rounds is either zero-times or once and a repetition. *}
lemma star_case :
"star r a c \<Longrightarrow>
 (a = c \<or> (\<exists> b. r a b \<and> star r b c))"
apply(induction rule: star.induct; auto)
done

text {* The next lemma is purely for convenience.
Actually the rounds can go nowhere after this invocation fails.
*}
lemma no_entry_fail [dest!]:
"star (one_round net I)
      (a, Execution (InstructionToEnvironment (ContractFail x) v v_opt))
      (b, c) \<Longrightarrow> b = a \<and> c = Execution (InstructionToEnvironment (ContractFail x) v v_opt)"
apply(drule star_case; simp)
apply(simp add: one_round.simps add: environment_turn.simps)
done

text {* Similarly, the rounds can go nowhere after this invocation returns. *}
lemma no_entry_return [dest!]:
"star (one_round net I)
      (a, Execution (InstructionToEnvironment (ContractReturn data) v v_opt))
      (b, c) \<Longrightarrow> b = a \<and> c = Execution (InstructionToEnvironment (ContractReturn data) v v_opt)"
apply(drule star_case; simp)
apply(simp add: one_round.simps add: environment_turn.simps)
done

text {* Also similarly, the rounds can go nowhere after this invocation
causes our contract to destroy itself.
*}
lemma no_entry_suicide [dest!]:
"star (one_round net I)
      (a, Execution (InstructionToEnvironment (ContractSuicide dst) v v_opt))
      (b, c) \<Longrightarrow> b = a \<and> c = Execution (InstructionToEnvironment (ContractSuicide dst) v v_opt)"
apply(drule star_case; simp)
apply(simp add: one_round.simps add: environment_turn.simps)
done

subsection {* How to State an Invariant *}

text {* For any invariant @{term I} over account states, now @{term "star net (one_round I)"}
relation shows all possibilities during one invocation\footnote{More precisely,
this transitive closure of rounds guides us through all the possible states when the contract loses the control flow.}, assuming that the
invariant is kept during external calls\footnote{This assumption about deeper reentrancy should
be considered as an induction hypothesis.  There has to be a lemma actually perform
such induction.}.
The following template traverses the states and states that the invariant is actually kept
after every possible round.  Also the template states that no annotation failures happen.
When I state something, I will be then obliged to prove the statement.  This happens in the next section.
*}

text {* I define the conjunction of the properties requested at the final states.
The whole thing is more readable when I inline-expand @{term invariant_holds_post},
but if I do that, the @{text auto} tactic splits out a subgoal for each conjunct.
This doubles the already massive number of subgoals.
*}

definition invariant_holds_post ::
  "(account_state \<Rightarrow> bool) \<Rightarrow> (account_state \<times> environment_input) \<Rightarrow> bool"
where
"invariant_holds_post I fin =
 (I (fst fin)(* The invariant holds. *))
"

lemma invariant_holds_in_fail [simp] :
"I state \<Longrightarrow>
 invariant_holds_post I (state, Execution (InstructionToEnvironment (ContractFail x) v v_opt))"
apply(simp add: invariant_holds_post_def)
done

text {* @{term "invariant_holds"} is a template for statements.
It takes a single argument @{term I} for the invariant.
The invariant is assumed to hold at the initial state.
The initial state is when the contract is called (this can be the first
invocation of this contract in this transaction, or a reentrancy).
The statement will request us to prove that the invariant also
holds whenever the invocation loses the control flow.
The invocation loses the control flow when the contract returns or fails
from the invocation, and also when it calls an account.
When the contract calls an account, the invocation does not finish so
I need to verify further final states against the postconditions, after
the call finishes.
The repetition is captured by the transitive closure
@{term "star (one_round net I)"}.

We prove the invariant when our contract calls out,
and we assume that reentrancy into this contract will
keep the invariant.
The whole argument can be seen as a mathematical induction
over the depth of reentrancy.  So we can assume that
reentrancy of a fewer depth keeps the invariant.
This idea comes from Christian Reitwiessner's treatment of
reentrancy in Why ML.
I have not justified the idea in Isabelle/HOL.
*}

definition invariant_holds :: "network \<Rightarrow> (account_state \<Rightarrow> bool) \<Rightarrow> bool"
where
"invariant_holds net (I :: account_state \<Rightarrow> bool) \<equiv>
  (\<forall> addr str code bal ongoing killed callenv.
    I \<lparr> account_address = addr, account_storage = str, account_code = code,
       account_balance = bal,
       account_ongoing_calls = ongoing,
       account_killed = killed \<rparr> \<longrightarrow>
  (\<forall> fin. star (one_round net I) (
    \<lparr> account_address = addr, account_storage = str, account_code = code,
      account_balance = bal,
      account_ongoing_calls = ongoing,
      account_killed = killed \<rparr>
  , Init callenv) fin \<longrightarrow>
  invariant_holds_post I fin))"

subsection {* How to State a Pre-Post Condition Pair *}

text {* After proving a theorem of the above form, I might be interested in
a more specific case (e.g.\,if the caller is not this particular account, nothing should change).
For that purpose, here is another template statement.  This contains everything above plus
an assumption about the initial call, and a conclusion about the state after the invocation.
*}

text {* I pack everything that I want when the contract fails or returns.
This definition reduces the number of goals that I need to prove.
Without this definition, the @{text auto} tactic
splits a goal @{prop "A \<Longrightarrow> B \<and> D"} into two subgoals @{prop "A \<Longrightarrow> B"} and @{prop "A \<Longrightarrow> D"}.
When I do complicated case analysis on @{prop A}, the number of subgoals grow rapidly.
So, I define @{term packed} to be @{prop "B \<and> D"} and prevent the @{text auto} tactic from noticing that it is a conjunction.
*}

text {* The following snippet says the invariant still holds in the observed final state%
\footnote{After the invocation finishes, some miner can credit Eth to the account under
verification.  The ``observed'' final state is an arbitrary state
after such possible balance increases.}
and the postconditions hold there. *}

definition postcondition_pack
where
"postcondition_pack I postcondition fin_observed initial_account initial_call fin
=
  (I fin_observed \<and>
  postcondition initial_account initial_call (fin_observed, snd fin))"

text {* The whole template takes an invariant @{term I}, a @{term precondition}
and a @{term postcondition}. The statement is about one invocation of the contract.
This invocation can be a reentrancy.  The initial state is when the contract is invoked,
and the final states\footnote{Since I am considering all possible executions, there are multiple
final states.  Also, even when I concetrate on a single execution, every time the contract calls an
account, I have to check the invariants.  Otherwise, I have no knowledge about what happens
during the following reentrancy. } are
when this invocation makes a call to an account, returns or fails.
We further consider natural balance increases\footnote{The balnace of an Ethereum account increases
naturally when a contract destroys itself and sends its balance to our account, for instance.}
and use the ``observed final state'' to
evaluate the post condition.
Of course, in between, there might be nesting reentrant invocations, that might alter
the storage and the balance of the contract.

At the time of invocation, the invariant and the preconditions are assumed.
During reentrant calls (that are deeper than the current invocation),
the statement will request us to prove that the invariant holds at any moment when
the contract loses the control flow (when the contract returns, fails or calls an account).
Also we will be requested to prove that the postcondition holds on these occasions.
The contract regains the control flow after a deeper call finishes, and the contract
would lose the control flow again.
All these requirements are captured by the transitive closure of @{term one_round} relation.
*}

definition pre_post_conditions ::
"network \<Rightarrow> (account_state \<Rightarrow> bool) \<Rightarrow> (account_state \<Rightarrow> call_env \<Rightarrow> bool) \<Rightarrow>
 (account_state \<Rightarrow> call_env \<Rightarrow> (account_state \<times> environment_input) \<Rightarrow> bool) \<Rightarrow> bool"
where
"pre_post_conditions
  net
  (I :: account_state \<Rightarrow> bool)
  (precondition :: account_state \<Rightarrow> call_env\<Rightarrow> bool)
  (postcondition :: account_state \<Rightarrow> call_env \<Rightarrow>
                    (account_state \<times> environment_input) \<Rightarrow> bool) \<equiv>

  (* for any initial call and initial account state that satisfy *)
  (* the invariant and the precondition, *)
  (\<forall> initial_account initial_call. I initial_account \<longrightarrow>
     precondition initial_account initial_call \<longrightarrow>

  (* for any final state that are reachable from these initial conditions, *)
  (\<forall> fin. star (one_round net I) (initial_account, Init initial_call) fin \<longrightarrow>

  (* and for any observed final state after this final state, *)
  (\<forall> fin_observed. account_state_natural_change (fst fin) fin_observed \<longrightarrow>

  (* the postcondition and the invariant holds. *)
  postcondition_pack
  I postcondition fin_observed initial_account initial_call fin)))
"

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

section "Signed Words"

theory Signed_Words
imports "HOL-Word.Word"
begin

text \<open>Signed words as separate (isomorphic) word length class. Useful for tagging words in C.\<close>

typedef ('a::len0) signed = "UNIV :: 'a set" ..

lemma card_signed [simp]: "CARD (('a::len0) signed) = CARD('a)"
  unfolding type_definition.card [OF type_definition_signed]
  by simp

instantiation signed :: (len0) len0
begin

definition
  len_signed [simp]: "len_of (x::'a::len0 signed itself) = LENGTH('a)"

instance ..

end

instance signed :: (len) len
  by (intro_classes, simp)

type_synonym 'a sword = "'a signed word"
type_synonym  sword8 =  "8 sword"
type_synonym sword16 = "16 sword"
type_synonym sword32 = "32 sword"
type_synonym sword64 = "64 sword"

end


theory AbstractSepreftime_Thin
  imports "HOL-Library.Extended_Nat" "Refine_Monadic.RefineG_Domain"  Refine_Monadic.Refine_Misc
  "HOL-Library.Monad_Syntax"   "HOL-Library.Groups_Big_Fun"
  Complex_Main
  "HOL-Library.Function_Algebras"

begin

section "Auxiliaries"

subsection "Auxiliaries for option"

lemma less_eq_option_None_is_None': "x \<le> None \<longleftrightarrow> x = None" by(auto simp: less_eq_option_None_is_None)

lemma everywhereNone: "(\<forall>x\<in>X. x = None) \<longleftrightarrow> X = {} \<or> X = {None}"
  by auto

subsection "Auxiliaries for enat"

lemma helper: "x2 \<le> x2a \<Longrightarrow> \<not> x2 < a \<Longrightarrow> \<not> x2a < a \<Longrightarrow>  x2 - (a::enat) \<le> x2a - a"
  apply(cases x2; cases x2a) apply auto apply(cases a) by auto

lemma helper2: "x2b \<le> x2 \<Longrightarrow> \<not> x2a < x2  \<Longrightarrow> \<not> x2a < x2b \<Longrightarrow> x2a - (x2::enat) \<le> x2a - x2b"
  apply(cases x2; cases x2a) apply auto apply(cases x2b) by auto

lemma Sup_finite_enat: "Sup X = Some (enat a) \<Longrightarrow> Some (enat a) \<in> X"
  by (auto simp: Sup_option_def Sup_enat_def these_empty_eq Max_eq_iff in_these_eq split: if_splits)

lemma Sup_enat_less2: " Sup X = \<infinity> \<Longrightarrow> (\<exists>x\<in>X. enat t < x)"
  unfolding  Sup_enat_def using    finite_enat_bounded linear
  apply(auto split: if_splits)
   apply (smt Max_in empty_iff enat_ord_code(4))
  by (smt not_less)

subsection "Auxiliary (for Sup and Inf)"

lemma aux11: "f`X={y} \<longleftrightarrow> (X\<noteq>{} \<and> (\<forall>x\<in>X. f x = y))" by auto

lemma aux2: "(\<lambda>f. f x) ` {[x \<mapsto> t1] |x t1. M x = Some t1} = {None} \<longleftrightarrow> (M x = None \<and> M\<noteq>Map.empty)"
  apply (cases "M x"; auto simp: aux11)
  by force

lemma aux3: "(\<lambda>f. f x) ` {[x \<mapsto> t1] |x t1. M x = Some t1} = {Some t1 | t1. M x = Some t1} \<union> ({None | y. y\<noteq>x \<and> M y \<noteq> None })"
  by (fastforce split: if_splits simp: image_iff)

lemma Sup_pointwise_eq_fun: "(SUP f\<in>{[x \<mapsto> t1] |x t1. M x = Some t1}. f x) = M x"
  unfolding Sup_option_def
  apply (simp add: aux2)
  apply (auto simp: aux3)
  by (metis (mono_tags, lifting) Some_image_these_eq Sup_least in_these_eq mem_Collect_eq sup_absorb1 these_image_Some_eq)

lemma SUP_eq_None_iff: "(SUP f\<in>X. f x) = None \<longleftrightarrow> X={} \<or> (\<forall>f\<in>X. f x = None)"
  by (smt SUP_bot_conv(2) SUP_empty Sup_empty empty_Sup)

lemma SUP_eq_Some_iff: "(SUP f\<in>X. f x) = Some t \<longleftrightarrow> (\<exists>f\<in>X. f x \<noteq> None) \<and> (t=Sup {t' | f t'. f\<in>X \<and> f x = Some t' })"
  apply auto
  subgoal
    by (smt Sup_bot_conv(1) Sup_empty Sup_option_def Sup_pointwise_eq_fun imageE option.distinct(1))
  subgoal
    unfolding Sup_option_def
    apply (clarsimp split: if_splits)
    apply (fo_rule arg_cong)
    apply (auto simp: Option.these_def)
    apply (metis (mono_tags, lifting) image_iff mem_Collect_eq option.sel)
    apply (metis (mono_tags, lifting) image_iff mem_Collect_eq option.sel)
    done
  subgoal
    unfolding Sup_option_def
    apply (clarsimp split: if_splits; safe)
    subgoal by (force simp: image_iff)
    apply (fo_rule arg_cong)
    apply (auto simp: Option.these_def)
    apply (metis (mono_tags, lifting) image_iff mem_Collect_eq option.sel)
    done
  done

lemma Sup_enat_less: "X \<noteq> {} \<Longrightarrow> enat t \<le> Sup X \<longleftrightarrow> (\<exists>x\<in>X. enat t \<le> x)"
  apply rule
  subgoal
  by (metis Max_in Sup_enat_def finite_enat_bounded linear)
  subgoal apply auto
    by (simp add: Sup_upper2)
  done

(*
  This is how implication can be phrased with an Inf operation.
  Generalization from boolean to enat can be explained this way.
 *)

lemma fixes Q P  shows
    "Inf { P x \<le> Q x |x. True}  \<longleftrightarrow> P \<le> Q" unfolding le_fun_def by simp

subsection \<open>continuous\<close>
term sup_continuous

text \<open>That might by Scott continuity;

     https://en.wikipedia.org/wiki/Scott_continuity \<close>

text \<open>There is scott_continuous in Complete_Non_Orders.Fixed_Points\<close>

definition continuous :: "('a::{Sup} \<Rightarrow> 'b::{Sup}) \<Rightarrow> bool"  where
  "continuous f \<longleftrightarrow> (\<forall>A. Sup (f ` A) = f (Sup A) )"

term sup_continuous
thm continuous_at_Sup_mono

lemma "continuous (f::'a::{complete_lattice}\<Rightarrow>'b::{complete_lattice})
         \<longleftrightarrow> (\<forall>A. Inf (f ` A) = f (Inf A) )" (* wrong conjecture *) oops

lemma continuousI: "(\<And>A. f (Sup A) = Sup (f ` A)) \<Longrightarrow> continuous f" by (auto simp: continuous_def)
lemma continuousD: "continuous f \<Longrightarrow> f (Sup A) = Sup (f ` A)" by (auto simp: continuous_def)

lemma continuous_Domain: "continuous Domain"
  apply(rule continuousI) by (fact Domain_Union)

lemma continuous_Range: "continuous Range"
  apply(rule continuousI) by (fact Range_Union)

subsubsection \<open>combinations are continuous\<close>

lemma continuous_app: "continuous (\<lambda>f. f x)"
  apply(rule continuousI)
  by simp

lemma
  continuous_fun:
  assumes *: "continuous f" shows "continuous  (\<lambda>X x. (f (X x)))"
  apply(rule continuousI)
  unfolding Sup_fun_def  apply(rule ext)
  apply(subst continuousD[OF *]) apply(subst image_image) apply(subst image_image) ..

lemma SupD: "Sup A = Some f \<Longrightarrow> A \<noteq> {} \<and> A\<noteq>{None}"
  unfolding Sup_option_def by auto

lemma ffF: "Option.these (case_option None (\<lambda>e. Some (f e)) ` A)
        = f `(Option.these A)"
  unfolding Option.these_def apply (auto split: option.splits)
   apply force
  using image_iff by fastforce

lemma zzz: "Option.these A \<noteq> {}
 \<Longrightarrow> Sup ( (\<lambda>x. case x of None \<Rightarrow> None | Some e \<Rightarrow> Some (f e)) ` A)
        = Some (Sup ( f ` Option.these A))"
  apply(subst Sup_option_def)
  apply simp
  apply safe
  subgoal
    by simp
  subgoal
    by (metis SupD aux11 empty_Sup in_these_eq option.simps(5))
  subgoal apply(subst ffF) by simp
  done

lemma assumes "continuous f"
  shows "continuous (case_option None (Some o f))" (* TODO: generalize to adding top/bottom element *)
  apply(rule continuousI)
  apply(auto split: option.splits)
  subgoal unfolding Sup_option_def by (auto split: if_splits)
proof -
  fix A   and a :: "'a::{complete_lattice}"
  assume a: "Sup A = Some a"
  with SupD have A: "A \<noteq> {} \<and> A \<noteq> {None}" by auto

  then have a': "a= Sup (Option.these A)"
    by (metis Sup_option_def a option.inject)

  from A have oA: "Option.these A \<noteq> {}" unfolding Option.these_def by auto

  have *: "\<And>x. Some (f x) = (Some o f) x" by simp
  have "(SUP x\<in>A. case x of None \<Rightarrow> None | Some x \<Rightarrow> (Some \<circ> f) x)
        = (SUP x\<in>A. case x of None \<Rightarrow> None | Some s \<Rightarrow> Some (f s))"
    by(simp only: *)
  also have "\<dots> = Some (SUP s\<in>(Option.these A). (f s))"
   using oA zzz by metis

  also have "(SUP s\<in>(Option.these A). (f s)) = f a"
    using a' assms(1)[THEN continuousD] by metis

  finally show "Some (f a) = (SUP x\<in>A. case x of None \<Rightarrow> None | Some x \<Rightarrow> (Some \<circ> f) x)"  by simp
qed

text \<open>a shorter proof\<close>

lemma my_these_def: "Option.these M = {f. Some f \<in> M}"
  unfolding  Option.these_def by (auto intro: rev_image_eqI)

lemma option_Some_image:
    "A \<noteq> {} \<Longrightarrow> A \<noteq> {None} \<Longrightarrow> case_option None (Some \<circ> f) ` A \<noteq> {None}"
  by (metis (mono_tags, hide_lams) comp_apply empty_iff everywhereNone
                  imageI in_these_eq option.exhaust option.simps(5) these_insert_None)

lemma continuous_option: (* or generally, adding a bottom element *)
  assumes *: "continuous f"
  shows "continuous (case_option None (Some o f))"
  apply(rule continuousI)
  unfolding Sup_option_def[unfolded my_these_def]
  apply (simp add: option_Some_image continuousD[OF *])
  apply rule+
  apply(rule arg_cong[where f=Sup])
    by  (auto split: option.splits  intro: rev_image_eqI)

abbreviation (input) "SUPREMUM S f \<equiv> Sup (f ` S)"

definition myminus where "myminus x y = (if x=\<infinity> \<and> y=\<infinity> then 0 else x - y)"
lemma "(a::enat) + x \<ge> b  \<longleftrightarrow> x \<ge> myminus b a "
  unfolding myminus_def
  apply(cases a; cases b; cases x) apply auto oops

section "NREST"

datatype ('a,'b) nrest = FAILi | REST "'a \<Rightarrow> ('b::complete_lattice) option"

instantiation nrest :: (type,complete_lattice) complete_lattice
begin

fun less_eq_nrest where
  "_ \<le> FAILi \<longleftrightarrow> True" |
  "(REST a) \<le> (REST b) \<longleftrightarrow> a \<le> b" |
  "FAILi \<le> (REST _) \<longleftrightarrow> False"

fun less_nrest where
  "FAILi < _ \<longleftrightarrow> False" |
  "(REST _) < FAILi \<longleftrightarrow> True" |
  "(REST a) < (REST b) \<longleftrightarrow> a < b"

fun sup_nrest where
  "sup _ FAILi = FAILi" |
  "sup FAILi _ = FAILi" |
  "sup (REST a) (REST b) = REST (\<lambda>x. sup (a x) (b x))"

fun inf_nrest where
  "inf x FAILi = x" |
  "inf FAILi x = x" |
  "inf (REST a) (REST b) = REST (\<lambda>x. inf (a x) (b x))"

lemma "min (None) (Some (1::enat)) = None" by simp
lemma "max (None) (Some (1::enat)) = Some 1" by eval

definition "Sup X \<equiv> if FAILi\<in>X then FAILi else REST (Sup {f . REST f \<in> X})"
definition "Inf X \<equiv> if \<exists>f. REST f\<in>X then REST (Inf {f . REST f \<in> X}) else FAILi"

definition "bot \<equiv> REST (Map.empty)"
definition "top \<equiv> FAILi"

instance
  apply(intro_classes)
  unfolding Sup_nrest_def  Inf_nrest_def  bot_nrest_def top_nrest_def
  apply (case_tac x, case_tac [!] y, auto) []
  apply (case_tac x, auto) []
  apply (case_tac x, case_tac [!] y, case_tac [!] z, auto) []
  apply (case_tac x, (case_tac [!] y)?, auto) []
  apply (case_tac x, (case_tac [!] y)?, simp_all  add: le_fun_def) []
  apply (case_tac x, (case_tac [!] y)?, auto   simp: le_fun_def) []
  apply (case_tac x, case_tac [!] y, case_tac [!] z, auto   simp: le_fun_def) []
  apply (case_tac x, (case_tac [!] y)?, auto   simp: le_fun_def) []
  apply (case_tac x, (case_tac [!] y)?, auto   simp: le_fun_def) []
  apply (case_tac x, case_tac [!] y, case_tac [!] z, auto   simp: le_fun_def) []
  apply (case_tac x, auto simp add: Inf_lower ) []
  apply (case_tac z, fastforce+) [] using le_Inf_iff apply fastforce
  apply (case_tac x, auto simp add: Sup_upper) []
  apply (case_tac z, fastforce+) []  using Sup_le_iff less_eq_nrest.simps(2) apply fastforce
  apply auto []
  apply (auto simp: bot_option_def) []
  done
end

definition RETURNT :: "'a \<Rightarrow> ('a, 'b::{complete_lattice, zero}) nrest" where
  "RETURNT x \<equiv> REST (\<lambda>e. if e=x then Some 0 else None)"
abbreviation "FAILT \<equiv> top::(_,_) nrest"
abbreviation "SUCCEEDT \<equiv> bot::(_,_) nrest"
abbreviation SPECT where "SPECT \<equiv> REST"

definition "consume M t \<equiv> case M of
          FAILi \<Rightarrow> FAILT |
          REST X \<Rightarrow> REST (map_option ((+) t) o (X))"

definition "SPEC P t = REST (\<lambda>v. if P v then Some (t v) else None)"

lemma consume_mono:
  fixes  t :: "'a::{ordered_ab_semigroup_add,complete_lattice}"
  shows "t\<le>t' \<Longrightarrow> M \<le> M' \<Longrightarrow> consume M t \<le> consume M' t'"
  unfolding consume_def apply (auto split: nrest.splits )
  unfolding le_fun_def apply auto
  subgoal for m m' x apply(cases "m' x";cases "m x" ) apply auto
     apply (metis less_eq_option_Some_None)
    by (metis add_mono less_eq_option_Some)
  done

instantiation unit :: plus
begin
fun plus_unit where "() + () = ()"
instance
  apply(intro_classes) .
end

instantiation unit :: zero
begin
definition zero_unit where "0 = ()"
instance
  apply(intro_classes) .
end
(*
instantiation "fun" :: (type, zero) zero
begin
fun zero_fun where "zero_fun x = 0"
instance
  apply(intro_classes) .
end
*)

instantiation unit :: ordered_ab_semigroup_add
begin
instance
  apply(intro_classes) by auto
end

(*
instantiation "fun" :: (type, ordered_ab_semigroup_add) ordered_ab_semigroup_add
begin

fun plus_fun where "plus_fun a b x= a x + b x"

term "a::('f::ab_semigroup_add)"

thm ab_semigroup_add.add_commute

instance
  apply(intro_classes)
  subgoal apply (rule ext) by (simp add: add.assoc)
  subgoal apply (rule ext) by (simp add: add.commute)
  subgoal by (simp add: add_left_mono le_fun_def)
  done
end
*)
lemma RETURNT_alt: "RETURNT x = REST [x\<mapsto>0]"
  unfolding RETURNT_def by auto

lemma nrest_inequalities[simp]:
  "FAILT \<noteq> REST X"
  "FAILT \<noteq> SUCCEEDT"
  "FAILT \<noteq> RETURNT x"
  "SUCCEEDT \<noteq> FAILT"
  "SUCCEEDT \<noteq> RETURNT x"
  "REST X \<noteq> FAILT"
  "RETURNT x \<noteq> FAILT"
  "RETURNT x \<noteq> SUCCEEDT"
  unfolding top_nrest_def bot_nrest_def RETURNT_def
  apply (auto) by (metis option.distinct(1))+

lemma nrest_more_simps[simp]:
  "SUCCEEDT = REST X \<longleftrightarrow> X=Map.empty"
  "REST X = SUCCEEDT \<longleftrightarrow> X=Map.empty"
  "REST X = RETURNT x \<longleftrightarrow> X=[x\<mapsto>0]"
  "REST X = REST Y \<longleftrightarrow> X=Y"
  "RETURNT x = REST X \<longleftrightarrow> X=[x\<mapsto>0]"
  "RETURNT x = RETURNT y \<longleftrightarrow> x=y"
  unfolding top_nrest_def bot_nrest_def RETURNT_def apply (auto split: if_splits)
  by (metis option.distinct(1))

lemma nres_simp_internals:
  "REST Map.empty = SUCCEEDT"
   "FAILi = FAILT"
  unfolding top_nrest_def bot_nrest_def by simp_all

lemma nres_order_simps[simp]:
  "\<not> FAILT \<le> REST M"
  "REST M \<le> REST M' \<longleftrightarrow> (M\<le>M')"
  by (auto simp: nres_simp_internals[symmetric])

lemma nres_top_unique[simp]:" FAILT \<le> S' \<longleftrightarrow> S' = FAILT"
  by (rule top_unique)

lemma FAILT_cases[simp]: "(case FAILT of FAILi \<Rightarrow> P | REST x \<Rightarrow> Q x) = P"
  by (auto simp: nres_simp_internals[symmetric])

lemma nrest_Sup_FAILT:
  "Sup X = FAILT \<longleftrightarrow> FAILT \<in> X"
  "FAILT = Sup X \<longleftrightarrow> FAILT \<in> X"
  by (auto simp: nres_simp_internals Sup_nrest_def)

lemma nrest_Sup_SPECT_D: "Sup X = SPECT m \<Longrightarrow> m x = Sup {f x | f. REST f \<in> X}"
  unfolding Sup_nrest_def apply(auto split: if_splits) unfolding Sup_fun_def
  apply(fo_rule arg_cong) by blast

declare nres_simp_internals(2)[simp]

lemma nrest_noREST_FAILT[simp]: "(\<forall>x2. m \<noteq> REST x2) \<longleftrightarrow> m=FAILT"
  apply (cases m) apply auto done

lemma   no_FAILTE:
  assumes "g xa \<noteq> FAILT"
  obtains X where "g xa = REST X" using assms by (cases "g xa") auto

lemma case_prod_refine:
  fixes P Q :: "'a \<Rightarrow> 'b \<Rightarrow> ('c,_) nrest"
  assumes
    "\<And>a b. P a b \<le> Q a b"
  shows
 "(case x of (a,b) \<Rightarrow> P a b) \<le> (case x of (a,b) \<Rightarrow> Q a b)"
  using assms
  by (simp add: split_def)

lemma case_option_refine: (* obsolete ? *)
  fixes P Q :: "'a \<Rightarrow> 'b \<Rightarrow> ('c,_) nrest"
  assumes
    "PN \<le> QN"
    "\<And>a. PS a \<le> QS a"
  shows
 "(case x of None \<Rightarrow> PN | Some a \<Rightarrow> PS a ) \<le> (case x of None \<Rightarrow> QN | Some a \<Rightarrow> QS a )"
  using assms
  by (auto split: option.splits)

section "time refine"

definition timerefine ::"('b \<Rightarrow> 'c \<Rightarrow> enat)  \<Rightarrow> ('a, 'b \<Rightarrow> enat) nrest \<Rightarrow> ('a, 'c \<Rightarrow> enat) nrest"  where
  "timerefine R m = (case m of FAILi \<Rightarrow> FAILi |
                REST M \<Rightarrow> REST (\<lambda>r. case M r of None \<Rightarrow> None |
                  Some cm \<Rightarrow> Some (\<lambda>cc. Sum_any (\<lambda>ac. cm ac * R ac cc))))"

definition wfn :: "('a, 'b \<Rightarrow> enat) nrest \<Rightarrow> bool" where
  "wfn m = (case m of FAILi \<Rightarrow> True |
                REST M \<Rightarrow> \<forall>r\<in>dom M. (case M r of None \<Rightarrow> True | Some cm \<Rightarrow> finite {x. cm x \<noteq> 0}))"

definition wfR :: "('b \<Rightarrow> 'c \<Rightarrow> enat) \<Rightarrow> bool" where
  "wfR R = (finite {(s,f). R s f \<noteq> 0})"

lemma wfR_fst: "\<And>y. wfR R \<Longrightarrow> finite {x. R x y \<noteq> 0}"
  unfolding wfR_def apply(rule finite_subset[where B="fst ` {(s, f). R s f \<noteq> 0}"])
  subgoal by auto
  apply(rule finite_imageI) by simp

lemma wfR_snd: "\<And>x. wfR R \<Longrightarrow> finite {y. R x y \<noteq> 0}"
  unfolding wfR_def apply(rule finite_subset[where B="snd ` {(s, f). R s f \<noteq> 0}"])
  subgoal by auto
  apply(rule finite_imageI) by simp

(*
lemma finite_same_support:
  "\<And>f. finite {(x,y). R x y \<noteq> 0} \<Longrightarrow> (\<And>x.  f (R x) = 0 \<longleftrightarrow> R x = 0) \<Longrightarrow> finite {x. f (R x) \<noteq> 0}"
  oops*)

lemma
  finite_wfR_middle_mult:
  assumes "wfR R1" "wfR R2"
  shows "finite {a. R2 x a * R1 a y \<noteq> (0::enat)}"
proof -
  have "{a. R2 x a * R1 a y \<noteq> 0} = {a. R2 x a \<noteq> 0 \<and> R1 a y \<noteq> 0}" by simp
  also have "\<dots> \<subseteq> fst ` {(a,a)| a. R2 x a \<noteq> 0 \<and> R1 a y \<noteq> 0}" by auto
  also have "\<dots> \<subseteq> fst ` ({a. R2 x a \<noteq> 0} \<times> {a. R1 a y \<noteq> 0})"
    apply(rule image_mono) by auto
  finally
  show ?thesis apply(rule finite_subset)
    apply(rule finite_imageI)
    apply(rule finite_cartesian_product)
    apply(rule wfR_snd) apply fact
    apply(rule wfR_fst) by fact
qed

lemma wfR_finite_mult_left:
  assumes "wfR R2"
  shows "finite {a. Mc a * R2 a ac \<noteq> (0::enat)}"
proof -

  have "{a. Mc a * R2 a ac \<noteq> 0} \<subseteq> {a. R2 a ac \<noteq> 0}"
    by auto
  then
  show ?thesis
    apply(rule finite_subset)
    apply(rule wfR_fst) by fact
qed

lemma
  wfR_finite_crossprod:
  assumes "wfR R2"
  shows "finite ({a. \<exists>b. Mc a * (R2 a b * R1 b cc) \<noteq> (0::enat)} \<times> {b. \<exists>a. Mc a * (R2 a b * R1 b cc) \<noteq> 0})"
proof -
  have i: "{a. \<exists>b. Mc a * (R2 a b * R1 b cc) \<noteq> 0} \<subseteq> fst ` ({(a,b).  R2 a b \<noteq> 0} \<inter> {(a,b). R1 b cc \<noteq> 0})" by auto
  have ii: "{b. \<exists>a. Mc a * (R2 a b * R1 b cc) \<noteq> 0} \<subseteq> snd ` ({(a,b).  R2 a b \<noteq> 0} \<inter> {(a,b). R1 b cc \<noteq> 0})" by auto

  show ?thesis
    apply(rule finite_cartesian_product)
    subgoal  apply(rule finite_subset[OF i]) apply(rule finite_imageI)
      apply(rule finite_Int)   using assms wfR_def by auto
    subgoal  apply(rule finite_subset[OF ii]) apply(rule finite_imageI)
      apply(rule finite_Int)   using assms wfR_def by auto
    done
qed

lemma wfR_finite_Sum_any:
  assumes *: "wfR R"
  shows "finite {x. ((Sum_any (\<lambda>ac. ((Mc ac) * (R ac x)))) \<noteq> (0::enat))}"
proof -
  {fix x
    have "((Sum_any (\<lambda>ac. ((Mc ac) * (R ac x)))) \<noteq> 0)
      \<Longrightarrow> \<exists>ac. (Mc ac) * (R ac x) \<noteq> 0"
      using Sum_any.not_neutral_obtains_not_neutral by blast
  } then
  have "{x. ((Sum_any (\<lambda>ac. ((Mc ac) * (R ac x)))) \<noteq> 0)}
          \<subseteq> {x. \<exists>ac. ((Mc ac) * (R ac x)) \<noteq> 0}" by blast
  also have "\<dots> \<subseteq> snd ` {(ac,x). ((Mc ac) * (R ac x)) \<noteq> 0}" by auto
  also have "\<dots> \<subseteq> snd ` {(ac,x).  (R ac x) \<noteq> 0}" by auto

  finally  show ?thesis
    apply(rule finite_subset )
    apply(rule finite_imageI) using * unfolding wfR_def by auto
qed

lemma assumes "R' \<le> R" "wfR R" shows "wfR R'"
proof -
  from assms(1) have *: "\<And> a b. R' a b\<le> R a b"
  unfolding le_fun_def   by auto
  {fix  a b have "R a b  = 0 ==> R' a b = 0 "
      using * [of a b] by auto}
  note f=this
  show "wfR R'"
    using \<open>wfR R\<close> unfolding wfR_def apply(rule rev_finite_subset)
    apply safe using f by simp
qed

lemma wfn_timerefine: "wfn m \<Longrightarrow> wfR R \<Longrightarrow> wfn (timerefine R m)"
proof -
  assume "wfR R"
  then show "wfn (timerefine R m)"
    unfolding wfn_def timerefine_def
    apply(auto split: nrest.splits option.splits)
    apply(rule wfR_finite_Sum_any) by simp
qed

lemma [simp]: "timerefine R FAILT = FAILT" by(auto simp: timerefine_def)

definition pp where
  "pp R2 R1 = (\<lambda>a c. Sum_any (%b. R1 a b * R2 b c  ) )"

lemma Sum_any_mono:
  assumes fg: "\<And>x.    f x \<le> g x"
    and finG: "finite {x. g x \<noteq> (0::enat)}"
shows "Sum_any f \<le> Sum_any g"
proof -
  have "{x. f x \<noteq> (0::enat)} \<subseteq> {x. g x \<noteq> (0::enat)}"
    apply auto using fg
    by (metis ile0_eq)
  with finG have "finite {x. f x \<noteq> (0::enat)}"
    using finite_subset by blast

  thm sum_mono sum_mono2

  have "sum f {x. f x \<noteq> (0::enat)} \<le> sum f {x. g x \<noteq> (0::enat)}"
    apply(rule sum_mono2) apply fact apply fact
    by simp
  also have "\<dots> \<le> sum g {x. g x \<noteq> (0::enat)}"
    apply(rule sum_mono) using fg by simp
  finally show ?thesis unfolding Sum_any.expand_set .
qed

lemma finite_support_mult:
  assumes "finite {xa.  R1 xa \<noteq> (0::enat)}"
  and "finite {xa. R2 xa \<noteq> 0}"
shows "finite {xa. R2 xa * R1 xa \<noteq> 0}"
proof -

  have "{(xa,xa)|xa. R2 xa * R1 xa \<noteq> 0} = {(xa,xa)|xa. R2 xa \<noteq> 0 \<and> R1 xa \<noteq> 0}" by auto
  also have "\<dots> \<subseteq> {(xa,xb)|xa xb. R2 xa \<noteq> 0 \<and> R1 xb \<noteq> 0}" by auto
  also have "\<dots> = {xa. R2 xa \<noteq> 0} \<times> {xb. R1 xb \<noteq> 0}" by auto
  finally have k: "{xa. R2 xa * R1 xa \<noteq> 0} \<subseteq> fst ` ({xa. R2 xa \<noteq> 0} \<times> {xb. R1 xb \<noteq> 0})" by blast

  show ?thesis
    apply(rule finite_subset[OF k])
    apply(rule finite_imageI)
    apply(rule finite_cartesian_product) by fact+
qed

lemma timerefine_mono:
  assumes "wfR R"
  shows "c\<le>c' \<Longrightarrow> timerefine R c \<le> timerefine R c'"
  apply(cases c) apply simp
  apply(cases c') apply (auto simp: timerefine_def split: nrest.splits option.splits simp: le_fun_def)
  subgoal  by (metis le_some_optE)
  proof (goal_cases)
    case (1 x2 x2a x x2b x2c xa)
    then have l: "\<And>ac. x2b ac \<le> x2c ac"
      by (metis le_funD less_eq_option_Some)
    show ?case
      apply(rule Sum_any_mono)
      subgoal using l apply(rule mult_right_mono) by simp
      apply(rule wfR_finite_mult_left) by fact
  qed

lemma assumes "wfR R1" "wfR R2"
  shows timerefine_iter: "timerefine R1 (timerefine R2 c) =  timerefine (pp R1 R2) c"
  unfolding timerefine_def
  apply(cases c) apply simp
  apply (auto simp: le_fun_def pp_def split: option.splits) apply (rule ext)
  apply (auto simp: le_fun_def pp_def split: option.splits)
    apply(subst Sum_any_right_distrib)
  subgoal apply(rule finite_wfR_middle_mult) using assms by simp_all
    apply (rule ext)
  subgoal for mc r Mc cc
        apply (subst Sum_any.swap[where C="{a. \<exists>b. Mc a * (R2 a b * R1 b cc) \<noteq> 0} \<times> {b. \<exists>a. Mc a * (R2 a b * R1 b cc) \<noteq> 0}"])
        subgoal apply(rule wfR_finite_crossprod) using assms by simp
        subgoal by simp
        apply(subst Sum_any_left_distrib)
        subgoal apply(rule wfR_finite_mult_left) using assms by simp
        by (meson Sum_any.cong ab_semigroup_mult_class.mult_ac(1))
      done

lemma timerefine_trans:
  assumes "wfR R1" "wfR R2" shows
  "a \<le> timerefine R1 b \<Longrightarrow> b \<le> timerefine R2 c \<Longrightarrow> a \<le> timerefine (pp R1 R2) c"
  apply(subst timerefine_iter[symmetric, OF assms])
    apply(rule order.trans) apply simp
    apply(rule timerefine_mono) using assms by auto

section "pointwise reasoning"

named_theorems refine_pw_simps
ML \<open>
  structure refine_pw_simps = Named_Thms
    ( val name = @{binding refine_pw_simps}
      val description = "Refinement Framework: " ^
        "Simplifier rules for pointwise reasoning" )
\<close>

definition nofailT :: "('a,_) nrest \<Rightarrow> bool" where "nofailT S \<equiv> S\<noteq>FAILT"

lemma nofailT_simps[simp]:
  "nofailT FAILT \<longleftrightarrow> False"
  "nofailT (REST X) \<longleftrightarrow> True"
  "nofailT (RETURNT x) \<longleftrightarrow> True"
  "nofailT SUCCEEDT \<longleftrightarrow> True"
  unfolding nofailT_def
  by (simp_all add: RETURNT_def)

lemma pw_Sup_nofail[refine_pw_simps]: "nofailT (Sup X) \<longleftrightarrow> (\<forall>x\<in>X. nofailT x)"
  apply (cases "Sup X")
   apply auto unfolding Sup_nrest_def apply (auto split: if_splits)
  apply force unfolding nofailT_def apply(force simp add: nres_simp_internals)
  done

lemma nofailT_SPEC[refine_pw_simps]: "nofailT (SPEC a b)"
  unfolding SPEC_def by auto

subsection "pw reasoning for enat"

definition inresT :: "('a,enat) nrest \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> bool" where
  "inresT S x t \<equiv> (case S of FAILi \<Rightarrow> True | REST X \<Rightarrow> (\<exists>t'. X x = Some t' \<and>  enat t\<le>t'))"

lemma inresT_alt: "inresT S x t \<longleftrightarrow> REST ([x\<mapsto>enat t]) \<le> S"
  unfolding inresT_def apply(cases S)
  by (auto dest!: le_funD[where x=x] simp: le_funI less_eq_option_def split: option.splits )

lemma inresT_mono: "inresT S x t \<Longrightarrow> t' \<le> t \<Longrightarrow> inresT S x t'"
  unfolding inresT_def apply(cases S) apply auto
  using enat_ord_simps(1) order_trans by blast

lemma inresT_RETURNT[simp]: "inresT (RETURNT x) y t \<longleftrightarrow> t = 0 \<and> y = x"
  by(auto simp: inresT_def RETURNT_def enat_0_iff split: nrest.splits)

lemma inresT_FAILT[simp]: "inresT FAILT r t"
  by(simp add: inresT_def)

lemma fail_inresT[refine_pw_simps]: "\<not> nofailT M \<Longrightarrow> inresT M x t"
  unfolding nofailT_def by simp

lemma pw_inresT_Sup[refine_pw_simps]: "inresT (Sup X) r t \<longleftrightarrow> (\<exists>M\<in>X. \<exists>t'\<ge>t.  inresT M r t')"
  apply(rule)
  subgoal (* \<rightarrow> *)
    apply(cases "Sup X")
    subgoal by (force simp: nrest_Sup_FAILT)
    subgoal
      apply(auto simp: inresT_def  Sup_nrest_def split: if_splits)
      apply(auto simp: SUP_eq_Some_iff split: nrest.splits)
      apply(subst (asm) Sup_enat_less)
       apply auto []
      apply auto  by blast
    done
  subgoal (* <- *)
    apply(cases "Sup X")
    subgoal by (auto simp: nrest_Sup_FAILT top_Sup)
    subgoal
      apply(auto simp: inresT_def  Sup_nrest_def split: if_splits)
      apply(auto simp: SUP_eq_Some_iff split: nrest.splits)
      apply(subst Sup_enat_less)
       apply auto []
      apply auto
      using dual_order.trans enat_ord_simps(1) by blast
    done
  done

lemma inresT_REST[simp]:
  "inresT (REST X) x t \<longleftrightarrow> (\<exists>t'\<ge>t. X x = Some t')"
  unfolding inresT_def
  by (auto )

lemma inres_simps[simp]:
  "inresT FAILT = (\<lambda>_ _. True)"
  "inresT SUCCEEDT = (\<lambda>_ _ . False)"
  unfolding inresT_def [abs_def]
  by (auto split: nrest.splits simp add: RETURNT_def)

lemma pw_le_iff:
  "S \<le> S' \<longleftrightarrow> (nofailT S'\<longrightarrow> (nofailT S \<and> (\<forall>x t. inresT S x t \<longrightarrow> inresT S' x t)))"
  apply (cases S; cases S', simp_all)
  unfolding nofailT_def inresT_def apply (auto split: nrest.splits)
   apply (metis le_fun_def le_some_optE order.trans)
  apply(auto intro!: le_funI simp: less_eq_option_def split: option.splits)
  apply (metis option.distinct(1) zero_enat_def zero_le)
  by (smt Suc_ile_eq enat.exhaust linorder_not_le option.simps(1) order_refl)

lemma pw_eq_iff:
  "S=S' \<longleftrightarrow> (nofailT S = nofailT S' \<and> (\<forall>x t. inresT S x t \<longleftrightarrow> inresT S' x t))"
  apply (rule iffI)
  apply simp
  apply (rule antisym)
  apply (auto simp add: pw_le_iff)
  done

lemma pw_flat_ge_iff: "flat_ge S S' \<longleftrightarrow>
  (nofailT S) \<longrightarrow> nofailT S' \<and> (\<forall>x t. inresT S x t \<longleftrightarrow> inresT S' x t)"
  apply (simp add: flat_ord_def)
  apply(simp add: pw_eq_iff) apply safe
  by (auto simp add: nofailT_def)

lemma pw_eqI:
  assumes "nofailT S = nofailT S'"
  assumes "\<And>x t. inresT S x t \<longleftrightarrow> inresT S' x t"
  shows "S=S'"
  using assms by (simp add: pw_eq_iff)

lemma inresT_SPEC[refine_pw_simps]: "inresT (SPEC a b) = (\<lambda>x t. a x \<and>  b x \<ge> t)"
    unfolding SPEC_def inresT_REST apply(rule ext) by(auto split: if_splits)

subsection "pw reasoning for 'b => enat"

definition inresT2 :: "('a,'b \<Rightarrow> enat) nrest \<Rightarrow> 'a \<Rightarrow> ('b \<Rightarrow> nat) \<Rightarrow> bool" where
  "inresT2 S x t \<equiv> (case S of FAILi \<Rightarrow> True | REST X \<Rightarrow> (\<exists>t'. X x = Some t' \<and>  enat o t\<le>t'))"

lemma inresT2_REST[simp]:
  "inresT2 (SPECT X) x t \<longleftrightarrow> (\<exists>t'\<ge>t. X x = Some t')"
  unfolding inresT2_def
  by (auto simp: le_fun_def)

definition limitF :: "'b \<Rightarrow> ('b\<Rightarrow>enat) \<Rightarrow> enat" where
  "limitF b f  \<equiv> f b"

lemma limitF: "limitF b (Sup A)  = Sup (limitF b ` A)"
  unfolding limitF_def by simp

lemma continuous_limitF: "continuous (limitF b)"
  apply(rule continuousI) by (fact limitF)

lemma limitF_Inf: "limitF b (Inf A)  = Inf (limitF b ` A)"
  unfolding limitF_def by simp

definition limitO :: "'b \<Rightarrow> ( ('b \<Rightarrow> enat) option) \<Rightarrow> enat option" where
  "limitO b F = (case F of None \<Rightarrow> None | Some f \<Rightarrow> Some (limitF b f) )"

lemma "(SUP e\<in>A. (f e)) = Sup (f ` A)" by simp

lemma limitO: "limitO b (Sup A) = Sup (limitO b ` A)"
  unfolding limitO_def apply(auto split: option.splits)
  subgoal unfolding Sup_option_def by (auto split: if_splits)
proof -
  fix a assume a: "Sup A = Some a"
  with SupD have A: "A \<noteq> {} \<and> A \<noteq> {None}" by auto

  then have a': "a= Sup (Option.these A)"
    by (metis Sup_option_def a option.inject)

  from A have oA: "Option.these A \<noteq> {}" unfolding Option.these_def by auto

  have "(SUP x\<in>A. case x of None \<Rightarrow> None | Some f \<Rightarrow> Some (limitF b f))
        = Some (SUP f\<in>(Option.these A). (limitF b f))"
   using oA zzz by metis

  also have "(SUP f\<in>(Option.these A). (limitF b f)) = limitF b a"
    using a' limitF by metis

  finally show "Some (limitF b a) = (SUP x\<in>A. case x of None \<Rightarrow> None | Some f \<Rightarrow> Some (limitF b f))"  by simp
qed

lemma limitO_Inf: "limitO b (Inf A) = Inf (limitO b ` A)"
  unfolding limitO_def apply(auto split: option.splits)
  subgoal unfolding Inf_option_def apply (auto split: if_splits)
    by force
  subgoal using limitF_Inf
    by (smt Inf_option_def ffF image_cong image_iff option.case_eq_if option.discI option.sel)
  done

definition limit :: " 'b \<Rightarrow> ('a,'b\<Rightarrow>enat) nrest \<Rightarrow>('a,enat) nrest" where
  "limit b S  \<equiv> (case S of FAILi \<Rightarrow> FAILi | REST X \<Rightarrow> REST (\<lambda>x. case X x of None \<Rightarrow> None | Some m \<Rightarrow> Some (m b)))"

lemma limit_limitO: "limit b S =  (case S of FAILi \<Rightarrow> FAILi | REST X \<Rightarrow> REST (\<lambda>x. (limitO b (X x))))"
  unfolding limitO_def limitF_def limit_def by simp

definition limitOF where "limitOF b X = (\<lambda>x. (limitO b (X x)))"

thm Sup_fun_def
lemma "(Sup A) x = (Sup ((\<lambda>f. f x) `A ))" unfolding Sup_fun_def by simp

lemma limitOF: "limitOF b (Sup A) = Sup (limitOF b ` A)"
  unfolding limitOF_def Sup_fun_def  apply(rule ext)
  apply(subst limitO) apply(subst image_image) apply(subst image_image) ..

lemma limitOF_Inf: "limitOF b (Inf A) = Inf (limitOF b ` A)"
  unfolding limitOF_def Inf_fun_def apply(rule ext)
  apply(subst limitO_Inf) apply(subst image_image) apply(subst image_image) ..

lemma limit_limitOF: "limit b S =  (case S of FAILi \<Rightarrow> FAILi | REST X \<Rightarrow> REST (limitOF b X))"
  unfolding limit_limitO limitOF_def by simp

lemma continuous_nrest: (* or generally, adding a top element *)
  assumes *: "continuous f"
  shows "continuous (case_nrest FAILi (REST o f))"
  apply(rule continuousI)
  unfolding Sup_nrest_def apply (auto split: nrest.splits)
  apply(subst continuousD[OF *])
  apply(rule arg_cong[where f=Sup])
  apply  (auto split: nrest.splits)
  using image_iff by fastforce
thm Option.these_def

lemma limit_Sup: "limit b (Sup A) = Sup (limit b ` A)"
  unfolding limit_limitOF Sup_nrest_def apply (auto split: nrest.splits)
  apply(subst limitOF)
  apply(rule arg_cong[where f=Sup])
  apply  (auto split: nrest.splits simp: )
    using image_iff by fastforce

lemma limit_Inf: "limit b (Inf A) = Inf (limit b ` A)"
  unfolding limit_limitOF Inf_nrest_def apply (auto split: nrest.splits)
  subgoal by force
  apply(subst limitOF_Inf)
  apply(rule arg_cong[where f=Inf])
  apply  (auto split: nrest.splits simp: )
    using image_iff by fastforce

lemma pw_f_le_iff':
  fixes S:: "('a,'b\<Rightarrow>enat) nrest"
  shows
  "S \<le> S' \<longleftrightarrow> (\<forall>b. (nofailT (limit b S')\<longrightarrow> (nofailT (limit b S) \<and> (\<forall> x t. inresT (limit b S) x t \<longrightarrow> inresT (limit b S') x t))))"
  apply (cases S; cases S', simp_all)
  unfolding nofailT_def inresT_def limit_def apply (auto split: nrest.splits)
  subgoal
    apply(auto split: option.splits)
    apply (metis le_fun_def le_some_optE)
    by (metis le_fun_def less_eq_option_Some order.trans)
  apply(auto intro!: le_funI simp: less_eq_option_def split: option.splits)
  subgoal for  x2 x2a x x2b
    by (metis enat_0_iff(1) i0_lb option.distinct(1))
  subgoal  for x2 x2a x x2b x2c xa
  proof -
    assume a1: "\<forall>b x x2b. x2 x = Some x2b \<longrightarrow> ((\<exists>y. x2a x = Some y) \<or> (\<forall>t. \<not> enat t \<le> x2b b)) \<and> (\<forall>x2. x2a x = Some x2 \<longrightarrow> (\<forall>t. enat t \<le> x2b b \<longrightarrow> enat t \<le> x2 b))"
    assume a2: "x2 x = Some x2b"
assume "x2a x = Some x2c"
  then have f3: "\<forall>n b f. (x2b b \<le> enat n \<or> enat n < f b) \<or> Some x2c \<noteq> Some f"
    using a2 a1 by (metis (full_types) Suc_ile_eq not_le)
  obtain nn :: "enat \<Rightarrow> nat" where
f4: "\<forall>e. e = enat (nn e) \<or> e = \<infinity>"
    by moura
  have "x2c xa = \<infinity> \<longrightarrow> x2b xa \<le> \<infinity>"
    by auto
then show ?thesis
  using f4 f3 by (metis (no_types) le_less not_le)
qed
  done

lemma pw_f_le_iff:
  fixes S:: "('a,'b\<Rightarrow>enat) nrest"
  shows
  "S \<le> S' \<longleftrightarrow> (nofailT S'\<longrightarrow> (nofailT S \<and> (\<forall>b x t. inresT (limit b S) x t \<longrightarrow> inresT (limit b S') x t)))"
  apply (cases S; cases S', simp_all)
  unfolding nofailT_def inresT_def limit_def apply (auto split: nrest.splits)
  subgoal
    apply(auto split: option.splits)
    apply (metis le_fun_def le_some_optE)
    by (metis le_fun_def less_eq_option_Some order.trans)
  apply(auto intro!: le_funI simp: less_eq_option_def split: option.splits)
  subgoal for  x2 x2a x x2b
    by (metis enat_0_iff(1) i0_lb option.distinct(1))
  subgoal  for x2 x2a x x2b x2c xa
  proof -
    assume a1: "\<forall>b x x2b. x2 x = Some x2b \<longrightarrow> ((\<exists>y. x2a x = Some y) \<or> (\<forall>t. \<not> enat t \<le> x2b b)) \<and> (\<forall>x2. x2a x = Some x2 \<longrightarrow> (\<forall>t. enat t \<le> x2b b \<longrightarrow> enat t \<le> x2 b))"
    assume a2: "x2 x = Some x2b"
assume "x2a x = Some x2c"
  then have f3: "\<forall>n b f. (x2b b \<le> enat n \<or> enat n < f b) \<or> Some x2c \<noteq> Some f"
    using a2 a1 by (metis (full_types) Suc_ile_eq not_le)
  obtain nn :: "enat \<Rightarrow> nat" where
f4: "\<forall>e. e = enat (nn e) \<or> e = \<infinity>"
    by moura
  have "x2c xa = \<infinity> \<longrightarrow> x2b xa \<le> \<infinity>"
    by auto
then show ?thesis
  using f4 f3 by (metis (no_types) le_less not_le)
qed
  done

definition inresTf :: "('a,'b\<Rightarrow>enat) nrest \<Rightarrow> 'a \<Rightarrow> ('b\<Rightarrow>nat) \<Rightarrow> bool" where
  "inresTf S x t \<equiv> (\<forall>b. (case S of FAILi \<Rightarrow> True | REST X \<Rightarrow> (\<exists>t'. X x = Some t' \<and> enat (t b) \<le> t' b)) )"

lemma "inresTf S x t \<longleftrightarrow> (\<forall>b. inresT (limit b S) x (t b))"
  unfolding inresTf_def inresT_def limit_def
  apply (auto split: nrest.split)
  apply force
proof (goal_cases)
  case (1 b x2)
  then obtain t' where  "(case x2 x of None \<Rightarrow> None | Some m \<Rightarrow> Some (m b)) = Some t'" and *: "enat (t b) \<le> t'" by auto
  then obtain m where **: "x2 x = Some m" "t' = m b" by(auto split: option.splits)
  show ?case apply(rule exI[where x="m"])
    using * ** by simp
qed
(*
lemma inresTf_alt: "inresTf S x t \<longleftrightarrow> REST ([x\<mapsto>  t]) \<le> S"
  unfolding inresTf_def apply(cases S)
  by (auto dest!: le_funD[where x=x] simp: le_funI less_eq_option_def split: option.splits )

lemma inresTf_mono: "inresTf S x t \<Longrightarrow> t' \<le> t \<Longrightarrow> inresTf S x t'"
  unfolding inresTf_def apply(cases S) apply (auto simp: le_fun_def)
  using enat_ord_simps(1) order_trans by blast

lemma inresTf_RETURNT[simp]: "inresTf (RETURNT x) y t \<longleftrightarrow> t = 0 \<and> y = x"
  by(auto simp: le_fun_def inresTf_def RETURNT_def enat_0_iff split: nrest.splits)

lemma inresTf_FAILT[simp]: "inresTf FAILT r t"
  by(simp add: inresTf_def)

lemma fail_inresTf[refine_pw_simps]: "\<not> nofailT M \<Longrightarrow> inresTf M x t"
  unfolding nofailT_def by simp

thm Max_in Sup_enat_def finite_enat_bounded linear

lemma "inresTf (Sup X) r t \<longleftrightarrow> G"
  unfolding inresTf_def  oops

(*
lemma Sup_f_enat_less: "X \<noteq> {} \<Longrightarrow> enat o t \<le> Sup X \<longleftrightarrow> (\<exists>x\<in>X. enat o t \<le> x)"
  apply rule
  subgoal  unfolding Sup_fun_def le_fun_def apply simp
    unfolding Sup_enat_def
    sorry
  subgoal apply auto
    by (simp add: Sup_upper2)
  oops

lemma pw_inresTf_Sup: "inresTf (Sup X) r t \<longleftrightarrow> (\<exists>M\<in>X. \<exists>t'\<ge>t.  inresTf M r t')"
  apply(rule)
  subgoal (* \<rightarrow> *)
    apply(cases "Sup X")
    subgoal by (force simp: nrest_Sup_FAILT)
    subgoal
      apply(auto simp: inresTf_def  Sup_nrest_def split: if_splits)
      apply(auto simp: SUP_eq_Some_iff split: nrest.splits)
      apply(subst (asm) Sup_enat_less)
       apply auto []
      apply auto  by b last
    done
  subgoal (* <- *)
    apply(cases "Sup X")
    subgoal by (auto simp: nrest_Sup_FAILT top_Sup)
    subgoal
      apply(auto simp: inresT_def  Sup_nrest_def split: if_splits)
      apply(auto simp: SUP_eq_Some_iff split: nrest.splits)
      apply(subst Sup_enat_less)
       apply auto []
      apply auto
      using dual_order.trans enat_ord_simps(1) by bl ast
    done
  oops
*)

lemma inresTf_REST[simp]:
  "inresTf (REST X) x t \<longleftrightarrow> (\<exists>t'\<ge>t. X x = Some t')"
  unfolding inresTf_def
  by (auto simp: le_fun_def)

lemma inresTf_simps[simp]:
  "inresTf FAILT = (\<lambda>_ _. True)"
  "inresTf SUCCEEDT = (\<lambda>_ _ . False)"
  unfolding inresTf_def
  by (auto split: nrest.splits simp add: RETURNT_def)

lemma helpera:
  fixes ef :: "'a :: order"
  assumes "\<forall>tf. tf \<le> ef \<longrightarrow> tf \<le> ef'"
  shows "ef \<le> ef'"
  using assms
  by simp

lemma pw_f_le_iff:
  "S \<le> S' \<longleftrightarrow> (nofailT S'\<longrightarrow> (nofailT S \<and> (\<forall>x t. inresTf S x t \<longrightarrow> inresTf S' x t)))"
  apply (cases S; cases S', simp_all)
  unfolding nofailT_def inresTf_def apply (auto split: nrest.splits)
  subgoal
    by (metis le_fun_def le_some_optE order_trans)
  apply(auto intro!: le_funI simp: less_eq_option_def split: option.splits)
  subgoal
    by fastforce
  subgoal
    using le_funD by fastforce
  done

lemma inresTf_SPEC[refine_pw_simps]: "inresTf (SPEC a b) = (\<lambda>x t. a x \<and>  b x \<ge> t)"
    unfolding SPEC_def apply(rule ext) by(auto split: if_splits)

 *)

lemma pw_f_eq_iff':
  "S=S' \<longleftrightarrow> (\<forall>b. nofailT (limit b S) = nofailT (limit b S') \<and> (\<forall> x t. inresT (limit b S) x t \<longleftrightarrow> inresT (limit b S') x t))"
  apply (rule iffI)
  apply simp
  apply (rule antisym)
  apply (auto simp add: pw_f_le_iff')
  done

lemma pw_f_eq_iff:
  "S=S' \<longleftrightarrow> (nofailT S = nofailT S' \<and> (\<forall>b x t. inresT (limit b S) x t \<longleftrightarrow> inresT (limit b S') x t))"
  apply (rule iffI)
  apply simp
  apply (rule antisym)
  apply (auto simp add: pw_f_le_iff)
  done

lemma pw_f_flat_ge_iff: "flat_ge S S' \<longleftrightarrow>
  (nofailT S) \<longrightarrow> nofailT S' \<and> (\<forall>b x t. inresT (limit b S) x t \<longleftrightarrow> inresT (limit b S') x t)"
  apply (simp add: flat_ord_def)
  apply(simp add: pw_f_eq_iff) apply safe
  by (auto simp add: nofailT_def)

lemma pw_f_eqI:
  assumes "nofailT S = nofailT S'"
  assumes "\<And>b x t. inresT (limit b S) x t \<longleftrightarrow> inresT (limit b S') x t"
  shows "S=S'"
  using assms by (simp add: pw_f_eq_iff)

lemma pw_f_eqI':
  assumes "\<And>b. nofailT (limit b S) = nofailT (limit b S')"
  assumes "\<And>b x t. inresT (limit b S) x t \<longleftrightarrow> inresT (limit b S') x t"
  shows "S=S'"
  using assms by (simp add: pw_f_eq_iff')

section \<open> Monad Operators \<close>

definition bindT :: "('b,'c::{complete_lattice, plus}) nrest \<Rightarrow> ('b \<Rightarrow> ('a,'c) nrest) \<Rightarrow> ('a,'c) nrest" where
  "bindT M f \<equiv> case M of
  FAILi \<Rightarrow> FAILT |
  REST X \<Rightarrow> Sup { (case f x of FAILi \<Rightarrow> FAILT
                | REST m2 \<Rightarrow> REST (map_option ((+) t1) o (m2) ))
                    |x t1. X x = Some t1}"

lemma bindT_alt: "bindT M f = (case M of
  FAILi \<Rightarrow> FAILT |
  REST X \<Rightarrow> Sup { consume (f x) t1 |x t1. X x = Some t1})"
  unfolding bindT_def consume_def by simp

lemma "bindT (REST X) f =
  (SUP x\<in>dom X. consume (f x) (the (X x)))"
proof -
  have *: "\<And>f X. { f x t |x t. X x = Some t}
      = (\<lambda>x. f x (the (X x))) ` (dom X)"
    by force
  show ?thesis by (auto simp: bindT_alt *)
qed

adhoc_overloading
  Monad_Syntax.bind AbstractSepreftime_Thin.bindT

lemma bindT_FAIL[simp]: "bindT FAILT g = FAILT"
  by (auto simp: bindT_def)

lemma "bindT SUCCEEDT f = SUCCEEDT"
  unfolding bindT_def by(auto split: nrest.split simp add: bot_nrest_def)
(*

lemma pw_inresT_bindT_aux: "inresTf (bindT m f) r t \<longleftrightarrow>
     (nofailT m \<longrightarrow> (\<exists>r' t' t''. inresTf m r' t' \<and> inresTf (f r') r t'' \<and> t \<le> t' + t''))"
  apply(rule)
  subgoal (* \<rightarrow> *)
    apply(cases m)
    subgoal by auto
    subgoal apply(auto simp: bindT_def   split: nrest.splits)
      subgoal for M x t' t1
        apply(rule exI[where x=x])
        apply(cases "f x") apply auto
        subgoal for x2 z apply(cases t1)
           apply auto
          subgoal for n apply(rule exI[where x=n]) apply auto
            by (smt dual_order.trans enat_ile enat_ord_simps(1) le_add2 linear order_mono_setup.refl plus_enat_simps(1))
          subgoal
            by (metis le_add1 zero_enat_def zero_le)
          done
        done
      subgoal for x t' t1
        apply(rule exI[where x=x]) apply auto
        apply(cases t1) apply auto
        subgoal for n apply(rule exI[where x=n]) apply auto
          apply(rule exI[where x=t]) by auto
        subgoal
          by presburger
        done
      done
    done
  subgoal (* <- *)
    apply(cases m)
    subgoal by auto
    subgoal for x2
      apply (auto simp: bindT_def  split: nrest.splits)
      apply(auto simp: pw_inresT_Sup )
      subgoal for r' t' t'a t''
        apply(cases "f r'")
        subgoal apply auto apply(force) done
        subgoal for x2a
          apply(rule exI[where x="REST (map_option ((+) t'a) \<circ> x2a)"])
          apply auto
           apply(rule exI[where x=r'])
           apply auto
          using add_mono by fastforce
        done
      done
    done
  done
*)
lemma pw_inresT_bindT_aux: "inresT (bindT m f) r t \<longleftrightarrow>
     (nofailT m \<longrightarrow> (\<exists>r' t' t''. inresT m r' t' \<and> inresT (f r') r t'' \<and> t \<le> t' + t''))"
  apply(rule)
  subgoal (* \<rightarrow> *)
    apply(cases m)
    subgoal by auto
    subgoal apply(auto simp: bindT_def pw_inresT_Sup split: nrest.splits)
      subgoal for M x t' t1
        apply(rule exI[where x=x])
        apply(cases "f x") apply auto
        subgoal for x2 z apply(cases t1)
           apply auto
          subgoal for n apply(rule exI[where x=n]) apply auto
            by (smt dual_order.trans enat_ile enat_ord_simps(1) le_add2 linear order_mono_setup.refl plus_enat_simps(1))
          subgoal
            by (metis le_add1 zero_enat_def zero_le)
          done
        done
      subgoal for x t' t1
        apply(rule exI[where x=x]) apply auto
        apply(cases t1) apply auto
        subgoal for n apply(rule exI[where x=n]) apply auto
          apply(rule exI[where x=t]) by auto
        subgoal
          by presburger
        done
      done
    done
  subgoal (* <- *)
    apply(cases m)
    subgoal by auto
    subgoal for x2
      apply (auto simp: bindT_def  split: nrest.splits)
      apply(auto simp: pw_inresT_Sup )
      subgoal for r' t' t'a t''
        apply(cases "f r'")
        subgoal apply auto apply(force) done
        subgoal for x2a
          apply(rule exI[where x="REST (map_option ((+) t'a) \<circ> x2a)"])
          apply auto
           apply(rule exI[where x=r'])
           apply auto
          using add_mono by fastforce
        done
      done
    done
  done

lemma pw_inresT_bindT[refine_pw_simps]: "inresT (bindT m f) r t \<longleftrightarrow>
     (nofailT m \<longrightarrow> (\<exists>r' t' t''. inresT m r' t' \<and> inresT (f r') r t'' \<and> t = t' + t''))"
  apply (auto simp: pw_inresT_bindT_aux)
  by (metis (full_types) inresT_mono le_iff_add linear nat_add_left_cancel_le)

lemma pw_bindT_nofailT[refine_pw_simps]: "nofailT (bindT M f) \<longleftrightarrow> (nofailT M \<and> (\<forall>x t. inresT M x t \<longrightarrow> nofailT (f x)))"
  unfolding bindT_def
   apply (auto elim: no_FAILTE simp: refine_pw_simps  split: nrest.splits )
  apply force+
  by (metis enat_ile le_cases nofailT_def)

lemma inresT_limit_SPECT[refine_pw_simps]: "inresT (limit b (SPECT M) ) x t = (\<exists>t'. t' b \<ge> enat t \<and> M x = Some t')"
  unfolding inresT_def limit_def by (auto split: option.splits)

end


theory Memory_ExtraLemmas
  imports
    "../AutoCorres/Impl"
    "../lib/ExtraLemmas"
    "$ISABELLE_HOME/src/HOL/Library/LaTeXsugar"

begin

lemma contrapos: "(P \<longrightarrow> Q) = (\<not>Q \<longrightarrow> \<not>P)"
  by blast

lemma unat_add_le: "unat (a + b) \<le> unat (a::('a::len word)) + unat b "
  by unat_arith

lemma eight_eq_eight : "unat (8::32 word) = 8" by simp

lemma intvl_no_overflow_lower_bound:
  "(a :: ('a::{len}) word) \<in> {x ..+  sz} \<Longrightarrow> unat x + sz \<le> 2 ^ LENGTH('a) \<Longrightarrow> a \<ge> x"
  apply unat_arith unfolding intvl_def  apply unat_arith
  apply auto
  apply (subgoal_tac "unat (of_nat k) = k")
   apply (smt add.commute add_leD1 add_less_mono1 order_less_le_trans unat_of_nat unat_of_nat_eq word_nchotomy)
  by (smt add.commute add.left_neutral add_diff_cancel_right' add_leD1 add_lessD1 diff_add_inverse
      diff_diff_cancel diff_le_self le_Suc_ex less_diff_conv less_irrefl_nat less_or_eq_imp_le
      linorder_not_less nat_add_left_cancel_less nat_less_le not_add_less1 order_less_le_trans unat_of_nat_eq)

lemma intvl_upper_bound: "a \<in> {x ..+ sz} \<Longrightarrow>
  unat a < unat x + sz"
  unfolding intvl_def
  apply unat_arith
  apply (auto simp add: unat_of_nat)
  using mod_less by blast

lemma zero_not_in_intvl_lower_bound:
  "(a::('a::len) word) \<in> {x ..+ sz} \<Longrightarrow> 0 \<notin> {x ..+  sz}  \<Longrightarrow> a \<ge>  x "
  apply (drule zero_not_in_intvl_no_overflow)
  by (rule intvl_no_overflow_lower_bound)

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

lemma word_div_mult_lower_bound:
  assumes "unat x + unat y < 2 ^ 32"
    and "y \<noteq> 0"
  shows "((x:: word32) div ( y :: word32)) * y + y \<ge> x"
proof -
  have "unat ((x div y) * y) = unat (x div y) * unat y"
    apply unat_arith
    apply auto
    by (metis (no_types, hide_lams) Word_Miscellaneous.dtle le_unat_uoi unat_div word_arith_nat_mult)
  have "unat ((x div y) * y) = (unat x div unat y) * unat y"
    apply unat_arith
    apply auto
    by (simp add: \<open>unat (x div y * y) = unat (x div y) * unat y\<close> unat_div)
  have "unat x div unat y * unat y + unat x mod unat y = unat x"
    by simp
  show ?thesis
    using `unat x + unat y < 2 ^ 32` `y \<noteq> 0`
      `unat ((x div y) * y) = (unat x div unat y) * unat y`
  apply unat_arith
  apply auto
   apply unat_arith
     apply auto
    apply (subgoal_tac "unat x div unat y * unat y + unat x mod unat y = unat x")
     apply (metis mod_le_divisor nat_add_left_cancel_le)
     apply simp
    using `unat x div unat y * unat y + unat x mod unat y = unat x`
      by arith
qed

lemma scast_NOT_simp: "(scast (~~(flag :: 32 signed word)) :: word32) = ~~ ((scast flag)::word32)"
  unfolding word_not_def
  apply (subst scast_down_wi)
   defer
   apply (subst uint_scast)
   apply (rule refl)
  apply (subst is_down)
  by simp

(* Unused *)
(*
lemma c_guard_l1:
  assumes "c_guard (a::('a::mem_type) ptr)"
    "\<not> c_guard (a +\<^sub>p 1)"
    "b > a"
    "b \<ge> a +\<^sub>p 1"
  shows "\<not> c_null_guard b"
proof -
  have "\<not> c_null_guard ( a +\<^sub>p 1)" using `c_guard a` `\<not> c_guard (a +\<^sub>p 1)`
    unfolding c_guard_def apply auto
    apply(frule ptr_aligned_plus[where i = 1]) by auto
  hence "0 \<in> ptr_span (a +\<^sub>p 1)" unfolding c_null_guard_def by auto
  have "0 \<in> ptr_span b" using `b \<ge> a +\<^sub>p 1` using `0 \<in> ptr_span (a +\<^sub>p 1)` unfolding intvl_def
  proof simp
    assume "a +\<^sub>p 1 \<le> b"
      and "\<exists>k. ptr_val (a +\<^sub>p 1) + of_nat k = 0 \<and> k < size_of TYPE('a)"
    then obtain k where k:"ptr_val (a +\<^sub>p 1) + of_nat k = 0 \<and> k < size_of TYPE('a)" by auto
    hence "ptr_val (a +\<^sub>p 1) + of_nat k = 0" by auto
    {
      assume "((of_nat k)::32 word) \<noteq> 0"
      have "ptr_val b \<ge> ptr_val (a +\<^sub>p 1)" using `b \<ge> a +\<^sub>p 1`  by (simp add: ptr_le_def ptr_le_def')
      hence 1:"ptr_val b - ptr_val (a +\<^sub>p 1) \<le> of_nat k"
        using `ptr_val (a +\<^sub>p 1) + of_nat k = 0`
        apply unat_arith apply auto
        using `of_nat k \<noteq> 0`
        apply (subgoal_tac "unat ((of_nat k)::32 word) = 0 \<Longrightarrow> ((of_nat k)::32 word) = 0")
         apply auto[1]
        apply (subst (asm) (3) unat_eq_0)  by auto

      let ?k2' = "of_nat k - ( ptr_val b - ptr_val (a +\<^sub>p 1))"
      have "ptr_val b + ?k2' = of_nat k + ptr_val (a +\<^sub>p 1)" by simp
      hence "ptr_val b + ?k2' = 0" using k by (simp add: add.commute)
      hence 2:"ptr_val b + of_nat (unat ?k2') = 0" by simp

      let ?of_nat_k = "((of_nat k):: 32 word)"
      have "?k2' \<le> ?of_nat_k" using 1  word_sub_le by auto
      hence "unat ?k2' \<le> unat ?of_nat_k" by (simp add: word_le_nat_alt)
      moreover have "unat ?of_nat_k \<le> k" by (metis le_cases le_unat_uoi)
      moreover  have "k < size_of TYPE('a)" using k by simp
      ultimately have "(unat ?k2') < size_of TYPE('a)" by simp
      hence "ptr_val b + of_nat (unat ?k2') = 0 \<and> (unat ?k2') < size_of TYPE('a)" using 2 by simp
      hence "\<exists>k::nat. ptr_val b + of_nat k = (0::32 word) \<and> k < size_of TYPE('a)" by (frule exI)
    }
    moreover{
      assume k_eq_0:"((of_nat k)::32 word) = 0"
      let ?k2' = "of_nat (size_of TYPE('a)) - ( ptr_val b - ptr_val a)"
      have "ptr_val b > ptr_val a" using `b>a`
        by (simp add: ptr_less_def ptr_less_def')
      hence "unat (ptr_val b) > unat (ptr_val a)" using unat_mono by auto
      from k_eq_0 have "ptr_val (a +\<^sub>p 1)= 0" using k by unat_arith
      hence 1:"ptr_val a + of_nat (size_of TYPE('a)) = 0" unfolding ptr_add_def by simp
      hence 2: "ptr_val b - ptr_val a < of_nat (size_of TYPE('a))"
        using k_eq_0
        apply unat_arith (* SLOW! *) apply auto
         apply (subgoal_tac "unat (ptr_val a) \<noteq> (0::nat)")
          apply auto[1]
        using `c_guard a`
         apply (metis len_of_addr_card max_size mem_type_simps(3) neq0_conv unat_of_nat_len)
        using `unat (ptr_val b) > unat (ptr_val a)` by simp
      hence "ptr_val b + ?k2' = 0" using 1  by (simp add: add.commute)
      hence 3:"ptr_val b + of_nat (unat ?k2') = 0" by simp
      have "ptr_val b - ptr_val a > 0" using `ptr_val b > ptr_val a`
        using word_neq_0_conv by fastforce
      with 2 have "?k2' < of_nat (size_of TYPE('a))"  by unat_arith (* VERY SLOW! *)
      hence "unat ?k2' < size_of TYPE('a)" using unat_less_helper by auto
      with 3 have "ptr_val b + of_nat (unat ?k2') = 0 \<and> unat ?k2' < size_of TYPE('a)" by auto
      hence "\<exists>k::nat. ptr_val b + of_nat k = (0::32 word) \<and> k < size_of TYPE('a)" by (frule exI)
    }
    ultimately show "\<exists>k::nat. ptr_val b + of_nat k = (0::32 word) \<and> k < size_of TYPE('a)"
      by auto
  qed
  thus "\<not> c_null_guard b" unfolding c_null_guard_def by auto
qed
*)

lemma unat_add_lem_3:
  "unat (a::'a::len word) + unat b + unat c < 2 ^ LENGTH('a) =
    (unat (a + b + c) = unat a + unat b + unat c)"
  using unat_add_lem
  by (metis add_lessD1 unat_lt2p)

lemma unat_addition_less_pres:"unat (a::'a::len word) + unat b < unat c \<Longrightarrow> a + b < c"
  by unat_arith

lemma unat_addition_le_pres:"unat (a::'a::len word) + unat b \<le> unat c \<Longrightarrow> a + b \<le> c"
  by unat_arith

lemma shiftr3_upper_bound:"(x :: 32 word) >> 3 \<le> 0x1FFFFFFF"
  apply (simp add:shiftr3_is_div_8)
  apply unat_arith
  by auto

lemma intvl_no_overflow2:
  assumes asm: "unat (a::'a::len word) + b \<le> 2 ^ LENGTH('a)"
  shows "(x \<in> {a..+b}) = (a \<le> x \<and> unat x < unat a + b)"
proof -
  {
    assume "x \<in> {a ..+ b}"
    with intvl_no_overflow_lower_bound intvl_upper_bound asm
    have "(a \<le> x \<and> unat x < unat a + b)" by blast
  }moreover
  {
    assume "(a \<le> x \<and> unat x < unat a + b)"
    thm intvlI
    have "a + of_nat (unat x - unat a) \<in> {a ..+ b}"
      apply (rule intvlI)
      using `(a \<le> x \<and> unat x < unat a + b)` asm
      by unat_arith
    moreover have "a + of_nat (unat x - unat a) = x"
      using `(a \<le> x \<and> unat x < unat a + b)` asm
      apply unat_arith
      apply (subgoal_tac "unat (x - a) = unat x - unat a")
       apply auto
      by unat_arith
    ultimately have "x \<in> {a ..+ b}" by argo
  }
  ultimately show ?thesis by fast
qed

end